cards/0000755000176200001440000000000015113515064011347 5ustar liggesuserscards/tests/0000755000176200001440000000000015113474632012516 5ustar liggesuserscards/tests/testthat/0000755000176200001440000000000015113515064014351 5ustar liggesuserscards/tests/testthat/test-shuffle_ard.R0000644000176200001440000003644215113466401017744 0ustar liggesusersskip_if_pkg_not_installed("withr") test_that("shuffle/trim works", { withr::local_options(list(width = 200)) # shuffle without group/var levels ard_simple <- ard_summary(ADSL, variables = "AGE") # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_simple_shuffled <- ard_simple |> shuffle_ard(trim = FALSE) |> as.data.frame(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_snapshot(ard_simple_shuffled) # shuffle back-fills groupings ard_grp <- bind_ard( ard_tabulate(ADSL, variables = "ARM"), ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_grp_shuffled <- ard_grp |> shuffle_ard(trim = FALSE) |> dplyr::filter(!stat_name == "N"), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_true(all(!is.na(ard_grp_shuffled$ARM))) ard_hier <- ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_hier_shuff <- ard_hier |> shuffle_ard(trim = FALSE) |> as.data.frame(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_true(all(!is.na(ard_hier_shuff$AESOC))) # shuffle many different formats ard_test <- bind_ard( ard_tabulate(ADSL, variables = "ARM"), ard_summary( ADSL, by = "ARM", variables = "AGE", stat_label = ~ list(c("mean", "sd") ~ "Mean(SD)") ), ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), ard_missing(ADSL, by = "ARM", variables = c("AGEGR1", "AGE")) ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_shuffled <- ard_test |> shuffle_ard() |> as.data.frame(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_snapshot(ard_shuffled[1:5, ]) # shuffle & trim # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_shuff_trim <- ard_test |> shuffle_ard() |> as.data.frame(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_snapshot(ard_shuff_trim[1:5, ]) # only numeric stats expect_type(ard_shuff_trim$stat, "double") # no list columns expect_true(!any(map_lgl(ard_shuff_trim, is.list))) }) test_that("shuffle_ard handles protected names", { # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( ard_test <- ard_tabulate( ADSL |> dplyr::rename(stat = ARM), by = "stat", variables = "AGEGR1" ) |> shuffle_ard(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_equal(names(ard_test)[1], "stat.1") }) test_that("shuffle_ard notifies user about warnings/errors before dropping", { withr::local_options(list(width = 200)) expect_snapshot( ard_summary( ADSL, variables = AGEGR1 ) |> shuffle_ard() ) }) test_that("shuffle_ard fills missing group levels if the group is meaningful", { withr::local_options(list(width = 200)) # mix of missing/nonmissing group levels present before shuffle expect_snapshot( bind_ard( ard_summary( ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean") ), dplyr::tibble( group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05) ) ) |> dplyr::filter(dplyr::row_number() <= 5L) |> shuffle_ard() ) # no group levels present before shuffle expect_snapshot( bind_ard( ard_summary( ADSL, variables = "AGE", statistic = ~ continuous_summary_fns("mean") ), dplyr::tibble( group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05) ) ) |> dplyr::filter(dplyr::row_number() <= 5L) |> shuffle_ard() ) # mix of group variables - fills overall only if variable has been calculated by group elsewhere expect_snapshot( bind_ard( ard_tabulate(ADSL, by = ARM, variables = AGEGR1) |> dplyr::slice(1), ard_tabulate(ADSL, variables = AGEGR1) |> dplyr::slice(1), ard_summary(ADSL, by = SEX, variables = AGE) |> dplyr::slice(1), ard_summary(ADSL, variables = AGE) |> dplyr::slice(1) ) |> shuffle_ard() |> as.data.frame() ) # mix of hierarchical group variables - fills overall only if variable has been calculated by group elsewhere expect_snapshot( bind_ard( ard_tabulate(ADSL, by = c(ARM, SEX), variables = AGEGR1) |> dplyr::slice(1), ard_tabulate(ADSL, by = SEX, variables = AGEGR1) |> dplyr::slice(1), ard_tabulate(ADSL, variables = AGEGR1) |> dplyr::slice(1) ) |> shuffle_ard() ) # fills with a unique group value if one already exists in the df adsl_new <- ADSL |> dplyr::mutate(ARM = ifelse(ARM == "Placebo", "Overall ARM", ARM)) expect_snapshot( bind_ard( ard_summary( adsl_new, variables = "AGE", statistic = ~ continuous_summary_fns("mean") ), ard_summary( adsl_new, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean") ) ) |> shuffle_ard() ) }) test_that("shuffle_ard doesn't trim off NULL/NA values", { # mix of char NA, NULL values # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( res <- suppressMessages( data.frame(x = rep_len(NA, 10)) |> ard_summary( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> shuffle_ard() |> dplyr::pull(stat) ), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) # check that all rows present expect_length(res, 3) }) test_that("shuffle_ard coerces all factor groups/variables to character", { adsl_ <- ADSL |> dplyr::mutate(RACE = factor(RACE)) expect_no_error( expect_warning( res <- ard_tabulate( data = adsl_, by = TRT01A, variables = c(RACE, ETHNIC) ) |> shuffle_ard(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) res_classes <- res |> dplyr::select(-stat) |> sapply(class) # all are character expect_true(all(res_classes == "character")) # correct coersion expect_equal( sort(unique(res$variable_level)), sort(unique(c(as.character(adsl_$RACE), adsl_$ETHNIC))) ) }) test_that("shuffle_ard fills missing group levels if the group is meaningful for cardx output", { withr::local_options(list(width = 200)) # cardx ARD: this is a dput() of a cardx result (see commented out code below) SAVED 2024-08-30 ard_cardx <- structure( list( group1 = c("ARM", "ARM", "SEX", "SEX"), variable = c( "AGEGR1", "AGEGR1", "AGEGR1", "AGEGR1" ), context = c( "stats_chisq_test", "stats_chisq_test", "stats_chisq_test", "stats_chisq_test" ), stat_name = c("statistic", "p.value", "statistic", "p.value"), stat_label = c( "X-squared Statistic", "p-value", "X-squared Statistic", "p-value" ), stat = list( statistic = c(`X-squared` = 5.07944166638125), p.value = 0.0788884197453486, statistic = c(`X-squared` = 1.03944199945198), p.value = 0.594686442507218 ), fmt_fun = 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() ) }) test_that("shuffle_ard() fills grouping columns with `Overall ` or `Any `", { adae <- ADAE |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose"), AESOC %in% unique(AESOC)[1:2] ) |> dplyr::group_by(AESOC) |> dplyr::filter( AETERM %in% unique(AETERM)[1:2] ) |> dplyr::ungroup() adsl <- ADSL |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose") ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( shuffled_ard <- ard_stack_hierarchical( data = adae, by = TRTA, variables = c(AESOC, AETERM), denominator = adsl, id = USUBJID, overall = TRUE, over_variables = TRUE, total_n = TRUE, shuffle = FALSE ) |> shuffle_ard(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) |> dplyr::pull(TRTA), "Overall TRTA" ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) |> dplyr::pull(AESOC) |> unique(), "Any AESOC" ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) ) }) test_that("shuffle_ard() fills with multiple `by` columns", { adae <- ADAE |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose"), AESOC %in% unique(AESOC)[1:2] ) |> dplyr::group_by(AESOC) |> dplyr::filter( AETERM %in% unique(AETERM)[1:2] ) |> dplyr::ungroup() adsl <- ADSL |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose") ) ard <- ard_stack_hierarchical( data = adae, by = c(TRTA, SEX), variables = c(AESOC, AETERM), denominator = adsl, id = USUBJID, overall = TRUE, over_variables = TRUE, total_n = TRUE, shuffle = FALSE ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( shuffled_ard <- ard |> shuffle_ard(), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) |> dplyr::select( TRTA, AESOC, SEX ), data.frame( TRTA = "Overall TRTA", AESOC = NA_character_, SEX = NA_character_ ), # the shuffled_ard preserves the card attributes and returns a tibble. We # need to ignore the attributes for the purpose of this comparison ignore_attr = TRUE ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) |> dplyr::pull(AESOC) |> unique(), "Any AESOC" ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) ) }) test_that("shuffle_ard() messages about 'Overall ' or 'Any '", { test_data <- dplyr::tibble( ARM = c("..cards_overall..", "Overall ARM", NA, "BB", NA), TRTA = c(NA, NA, "..hierarchical_overall..", "C", "C") ) # messaging actually comes from .derive_overall_labels expect_snapshot( test_data |> dplyr::mutate( dplyr::across( ARM:TRTA, cards:::.derive_overall_labels ) ) ) adae <- ADAE |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose"), AESOC %in% unique(AESOC)[1:2] ) |> dplyr::group_by(AESOC) |> dplyr::filter( AETERM %in% unique(AETERM)[1:2] ) |> dplyr::ungroup() |> dplyr::mutate( TRTA = dplyr::if_else( TRTA == "Xanomeline High Dose", "Overall TRTA", TRTA ), AESOC = dplyr::if_else( AESOC == "GASTROINTESTINAL DISORDERS", "Any AESOC", AESOC ) ) adsl <- ADSL |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose") ) |> dplyr::mutate( TRTA = dplyr::if_else( TRTA == "Xanomeline High Dose", "Overall TRTA", TRTA ) ) ard <- ard_stack_hierarchical( data = adae, by = c(TRTA, SEX), variables = c(AESOC, AETERM), denominator = adsl, id = USUBJID, overall = TRUE, over_variables = TRUE, total_n = TRUE, shuffle = FALSE ) expect_snapshot( shuffled_ard <- ard |> shuffle_ard() ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) |> dplyr::select( TRTA, AESOC, SEX ), data.frame( TRTA = "Overall TRTA.1", AESOC = NA_character_, SEX = NA_character_ ), # the shuffled_ard preserves the card attributes and returns a tibble. We # need to ignore the attributes for the purpose of this comparison ignore_attr = TRUE ) expect_identical( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) |> dplyr::pull(AESOC) |> unique(), "Any AESOC.1" ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_total_n.." ) ) expect_snapshot( shuffled_ard |> dplyr::filter( variable == "..ard_hierarchical_overall.." ) ) }) test_that("shuffle_ard() preserves the attributes of a `card` object", { adae <- ADAE |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose"), AESOC %in% unique(AESOC)[1:2] ) |> dplyr::group_by(AESOC) |> dplyr::filter( AETERM %in% unique(AETERM)[1:2] ) |> dplyr::ungroup() adsl <- ADSL |> dplyr::filter( SAFFL == "Y", TRTA %in% c("Placebo", "Xanomeline High Dose") ) ard <- ard_stack_hierarchical( data = adae, by = TRTA, variables = c(AESOC, AETERM), denominator = adsl, id = USUBJID, overall = TRUE, over_variables = TRUE, total_n = TRUE ) # we expect it to work but with a warning messaged related to the deprecation expect_no_error( expect_warning( shuffled_ard <- shuffle_ard(ard), "`shuffle_ard()` was deprecated in cards 0.8.0.", fixed = TRUE ) ) expect_identical( attributes(ard)[["args"]], attributes(shuffled_ard)[["args"]] ) }) cards/tests/testthat/test-print.R0000644000176200001440000000171115050667010016604 0ustar liggesuserstest_that("print.card() works", { expect_snapshot( ard_summary(ADSL, by = "ARM", variables = "AGE") ) expect_snapshot( ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") ) expect_snapshot( ard_summary(ADSL, variables = "AGE", fmt_fun = AGE ~ list(~ \(x) round(x, 3))) ) # checking the print of Dates expect_snapshot( ard_summary( 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_fun) ) # checking the print of a complex matrix statistic result expect_snapshot( bind_ard( ard_attributes(mtcars, variables = mpg), ard_summary( mtcars, variables = mpg, statistic = ~ continuous_summary_fns( "mean", other_stats = list(vcov = \(x) lm(mpg ~ am, mtcars) |> vcov()) ) ) ) ) }) cards/tests/testthat/test-ard_mvsummary.R0000644000176200001440000001161115050667010020336 0ustar liggesuserstest_that("ard_mvsummary() works", { # we can replicate `ard_summary()` for univariate analysis # using the `x` arg in the mean function expect_equal( ard_mvsummary( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat), ard_summary( 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_mvsummary( 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_summary( 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_mvsummary( 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_mvsummary() messaging", { # correct messaging when BMIBL doesn't have any summary fns expect_snapshot( error = TRUE, ard_mvsummary( ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) ) }) test_that("ard_mvsummary() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_mvsummary( variables = c("AGE", "BMIBL"), statistic = ~ list(mean = \(x, ...) mean(x)) ), ard_mvsummary( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = ~ list(mean = \(x, ...) mean(x)) ) ) }) test_that("ard_mvsummary() follows ard structure", { expect_silent( ard_mvsummary( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) |> check_ard_structure(method = FALSE) ) }) test_that("ard_mvsummary() 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_mvsummary( 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_mvsummary( by = "am", variables = "mpg", statistic = list(mpg = list(mean = \(x, ...) mean(x))) ) ) }) test_that("ard_mvsummary() 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_mvsummary(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_works)), ard_mvsummary(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_mvsummary(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_error)) |> dplyr::pull("stat_name"), ard_mvsummary(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-rename_ard_groups.R0000644000176200001440000000214515050667010021146 0ustar liggesuserstest_that("rename_ard_groups_shift()", { # no errors when no grouping variables expect_equal( ard_summary(ADSL, variables = AGE) |> rename_ard_groups_shift(), ard_summary(ADSL, variables = AGE) ) # works under normal circumstances expect_snapshot( ard_summary(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_shift(shift = 1L) |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) test_that("rename_ard_groups_shift() messaging", { expect_snapshot( ard_summary(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_shift(shift = -1L) |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) test_that("rename_ard_groups_reverse()", { # no errors when no grouping variables expect_equal( ard_summary(ADSL, variables = AGE) |> rename_ard_groups_reverse(), ard_summary(ADSL, variables = AGE) ) # works under normal circumstances expect_snapshot( ard_summary(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_reverse() |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) cards/tests/testthat/test-ard_tabulate.R0000644000176200001440000007705015113340127020105 0ustar liggesuserstest_that("ard_tabulate() univariate", { expect_error( ard_cat_uni <- ard_tabulate(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_tabulate( mtcars, variables = starts_with("xxxxx") ), dplyr::tibble() |> as_card() ) # works for ordered factors expect_equal( ard_tabulate( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = TRUE)), variables = cyl ) |> dplyr::select(stat_name, stat_label, stat), ard_tabulate( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = FALSE)), variables = cyl ) |> dplyr::select(stat_name, stat_label, stat) ) expect_equal( ard_tabulate( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = TRUE)), by = vs, variables = cyl ) |> dplyr::select(stat_name, stat_label, stat), ard_tabulate( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = FALSE)), by = vs, variables = cyl ) |> dplyr::select(stat_name, stat_label, stat) ) }) test_that("ard_tabulate() univariate & specified denomiator", { expect_error( ard_cat_new_denom <- ard_tabulate( 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_tabulate(fmt_fun) argument works", { ard_tabulate( mtcars, variables = "am", fmt_fun = 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_fun() |> dplyr::select(variable, variable_level, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() ard_tabulate( mtcars, variables = c("am", "vs"), fmt_fun = list( am = list(p = function(x) round5(x * 100, digits = 3)), vs = list(p = function(x) round5(x * 100, digits = 1)) ) ) |> apply_fmt_fun() |> dplyr::select(variable, variable_level, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() }) test_that("ard_tabulate() 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_tabulate( data = ADAE_small, strata = c(AESOC, AELLT), by = TRTA, variables = AESEV, denominator = ADSL ), 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_tabulate( 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_tabulate(variables = trt, by = Species) ) expect_s3_class(ard_sort_test$group1_level[[1]], "factor") }) test_that("ard_tabulate(stat_label) argument works", { # formula expect_snapshot( ard_tabulate( 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_tabulate( 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_tabulate( 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_tabulate(denominator='cell') works", { expect_error( ard_crosstab <- ard_tabulate( 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_tabulate( 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_tabulate( 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_tabulate(denominator='row') works", { withr::local_options(list(width = 120)) expect_error( ard_crosstab_row <- ard_tabulate( 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_tabulate( ADSL, variables = "AGEGR1", by = "ARM", denominator = "row", statistic = list(AGEGR1 = c("n", "N")), fmt_fun = list(AGEGR1 = list("n" = 2)) ), NA ) expect_snapshot( ard_with_args |> apply_fmt_fun() |> dplyr::select(-fmt_fun, -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_tabulate( 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_tabulate( 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_tabulate(denominator='column') works", { expect_equal( ard_tabulate( ADSL, variables = "AGEGR1", by = "ARM", denominator = "column" ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat_name, stat), ard_tabulate(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_tabulate( 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_tabulate( 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_tabulate( 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_tabulate( 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_tabulate(denominator=integer()) works", { expect_equal( ard_tabulate(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_tabulate(denominator=) works", { expect_snapshot( error = TRUE, ard_tabulate( 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_tabulate( ADSL, by = ARM, variables = AGEGR1, denominator = data.frame(ARM = "Placebo", ...ard_N... = 86) ) ) expect_equal( ard_tabulate( 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_fun), ard_tabulate( ADSL, by = ARM, variables = AGEGR1 ) |> dplyr::select(-fmt_fun) ) }) test_that("ard_tabulate(denominator=) works", { expect_equal( ADSL |> dplyr::mutate(AGEGR1 = NA) |> ard_tabulate( 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_tabulate( 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_tabulate() and ARD column names", { ard_colnames <- c( "group1", "group1_level", "variable", "variable_level", "context", "stat_name", "stat_label", "stat", "fmt_fun", "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_tabulate( 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_summary( data = df, by = all_of(byvar), variables = "cyl" ) } ) }, NA ) }) test_that("ard_tabulate() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_tabulate(variables = AGEGR1), ard_tabulate(data = ADSL, by = "ARM", variables = "AGEGR1") ) }) test_that("ard_tabulate() and all NA columns", { expect_snapshot( error = TRUE, ADSL |> dplyr::mutate(AGEGR1 = NA_character_) |> ard_tabulate(variables = AGEGR1) ) }) test_that("ard_tabulate() can handle non-syntactic column names", { expect_equal( ADSL |> dplyr::mutate(`Age Group` = AGEGR1) |> ard_tabulate(variables = `Age Group`) |> dplyr::select(stat), ADSL |> ard_tabulate(variables = AGEGR1) |> dplyr::select(stat) ) expect_equal( ADSL |> dplyr::mutate(`Age Group` = AGEGR1) |> ard_tabulate(variables = "Age Group") |> dplyr::select(stat, error), ADSL |> ard_tabulate(variables = AGEGR1) |> dplyr::select(stat, error) ) expect_equal( ADSL |> dplyr::mutate(`Arm Var` = ARM, `Age Group` = AGEGR1) |> ard_tabulate(by = `Arm Var`, variables = "Age Group") |> dplyr::select(stat, error), ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> dplyr::select(stat, error) ) expect_equal( ADSL |> dplyr::mutate(`Arm Var` = ARM, `Age Group` = AGEGR1) |> ard_tabulate(strata = "Arm Var", variables = `Age Group`) |> dplyr::select(stat, error), ADSL |> ard_tabulate(strata = ARM, variables = AGEGR1) |> dplyr::select(stat, error) ) }) test_that("ard_tabulate(strata) returns results in proper order", { expect_equal( ard_tabulate( 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::select(group2_level) |> unlist() |> unique() |> as.character(), c("MILD", "MODERATE", "SEVERE") ) }) test_that("ard_tabulate(by) messages about protected names", { mtcars2 <- mtcars |> dplyr::mutate( variable = am, variable_level = cyl, by = am, by_level = cyl ) expect_snapshot( error = TRUE, ard_tabulate(mtcars2, by = variable, variables = gear) ) expect_error( ard_tabulate(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_tabulate() 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_tabulate( mtcars, variables = c(am, cyl), by = disp, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(variable, variable_level), by = by, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(cyl, am), by = gear, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(variable_level, variable), by = group1_level, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(gear, am), by = disp, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( 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_tabulate( mtcars, variables = c(am, cyl), by = disp, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(N, p), by = name, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(disp, gear), by = am, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(name, group1_level), by = N, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = gear, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(N, name), by = group1_level, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = cyl, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( 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_tabulate( mtcars, variables = c(gear, cyl), by = disp, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(n_unweighted, mean), by = p.std.error, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(gear, cyl), by = am, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(n_unweighted, mean), by = n, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = cyl, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(n, p.std.error), by = mean, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = gear, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( 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_tabulate( mtcars, variables = c(am, cyl), by = disp, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(N_unweighted, p_unweighted), by = column, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(disp, gear), by = am, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(column, row), by = N_unweighted, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = cyl, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(N_unweighted, column), by = p_unweighted, denominator = "row" ) |> dplyr::select(stat) ) expect_equal( ard_tabulate( mtcars, variables = c(am, disp), by = gear, denominator = "row" ) |> dplyr::select(stat), ard_tabulate( mtcars2, variables = c(N_unweighted, column), by = row, denominator = "row" ) |> dplyr::select(stat) ) }) test_that("ard_tabulate(by) messages about protected names", { mtcars2 <- mtcars %>% dplyr::rename( "variable" = am, "variable_level" = cyl, "by" = disp, "group1_level" = gear ) expect_snapshot( error = TRUE, ard_tabulate(mtcars2, by = variable, variables = by) ) expect_error( ard_tabulate(mtcars2, by = variable_level, variables = by), 'The `by` argument cannot include variables named "variable" and "variable_level".' ) }) test_that("ard_tabulate() follows ard structure", { expect_silent( ard_tabulate(mtcars, variables = "am") |> check_ard_structure(method = FALSE) ) }) test_that("ard_tabulate() with hms times", { # originally reported in https://github.com/ddsjoberg/gtsummary/issues/1893 skip_if_pkg_not_installed("hms") withr::local_package("hms") ADSL2 <- ADSL |> dplyr::mutate(time_hms = hms(seconds = 15)) expect_silent( ard <- ard_tabulate(ADSL2, by = ARM, variables = time_hms) ) expect_equal( ard$stat, ard_tabulate( ADSL2 |> dplyr::mutate(time_hms = as.numeric(time_hms)), by = ARM, variables = time_hms )$stat ) }) test_that("ard_tabulate() 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_tabulate(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_tabulate(variables = am) ) }) test_that("ard_tabulate(denominator='column') with cumulative counts", { # check cumulative stats work without `by/strata` expect_silent( ard <- ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # test the final cum n matches the nrow() expect_equal( ard |> dplyr::filter( stat_name == "n_cum", variable_level %in% dplyr::last(.unique_and_sorted(ADSL$AGEGR1)) ) |> dplyr::pull(stat) |> unlist(), nrow(ADSL) ) # test the final cum p is 1 expect_equal( ard |> dplyr::filter( stat_name == "p_cum", variable_level %in% dplyr::last(.unique_and_sorted(ADSL$AGEGR1)) ) |> dplyr::pull(stat) |> unlist(), 1 ) # check the cum n is correct expect_equal( ard |> dplyr::filter(stat_name %in% "n_cum") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_cum") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1) |> prop.table() |> cumsum() |> as.list() ) # check cumulative stats work with `by` expect_silent( ard <- ard_tabulate( ADSL, variables = "AGEGR1", by = ARM, statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # check the cum n is correct expect_equal( ard |> dplyr::filter(stat_name %in% "n_cum", group1_level == "Placebo") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo"]) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_cum", group1_level == "Placebo") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo"]) |> prop.table() |> cumsum() |> as.list() ) # check with by & strata expect_silent( ard <- ard_tabulate( ADSL, variables = "AGEGR1", by = ARM, strata = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # check the cum n is correct expect_equal( ard |> dplyr::filter( stat_name %in% "n_cum", group1_level == "Placebo", group2_level == "F" ) |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo" & ADSL$SEX == "F"]) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter( stat_name %in% "p_cum", group1_level == "Placebo", group2_level == "F" ) |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo" & ADSL$SEX == "F"]) |> prop.table() |> cumsum() |> as.list() ) # function works when only `n_cum` requested expect_equal( ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ "n_cum" ), ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) |> dplyr::filter(stat_name == "n_cum") ) # function works when only `p_cum` requested expect_equal( ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ "p_cum" ), ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) |> dplyr::filter(stat_name == "p_cum") ) }) test_that("ard_tabulate(denominator='row') with cumulative counts", { # check cumulative stats work without `by/strata` expect_silent( ard <- ard_tabulate( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = "row" ) ) # when no by, the n and n_cum should be the same expect_true( ard |> dplyr::filter(stat_name %in% c("n", "n_cum")) |> dplyr::mutate( .by = all_ard_variables(), check_equal = unlist(stat) == unlist(stat)[1] ) |> dplyr::pull(check_equal) |> unique() ) # when no by, the p and p_cum should be the same and equal to 1 expect_equal( ard |> dplyr::filter(stat_name %in% c("p", "p_cum")) |> dplyr::pull(stat) |> unlist() |> unique(), 1 ) # check cumulative stats work with `by` expect_silent( ard <- ard_tabulate( ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = "row" ) ) # check row n_cum expect_equal( ard |> dplyr::filter(variable_level %in% "<65", stat_name == "n_cum") |> dplyr::select(group1_level, stat) |> deframe(), table(ADSL$SEX[ADSL$AGEGR1 == "<65"]) |> cumsum() |> as.list() ) # check row p_cum expect_equal( ard |> dplyr::filter(variable_level %in% "<65", stat_name == "p_cum") |> dplyr::select(group1_level, stat) |> deframe(), table(ADSL$SEX[ADSL$AGEGR1 == "<65"]) |> prop.table() |> cumsum() |> as.list() ) }) test_that("ard_tabulate() with cumulative counts messaging", { # cumulative counts/percents only available when `denominator=c('column', 'row')` expect_snapshot( error = TRUE, ard_tabulate( ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = NULL ) ) }) test_that("ard_tabulate() ordering for multiple strata", { adae_mini <- ADAE |> dplyr::select(USUBJID, TRTA, AESOC, AEDECOD) |> dplyr::filter(AESOC %in% unique(AESOC)[1:4]) |> dplyr::group_by(AESOC) |> dplyr::filter(AEDECOD %in% unique(AEDECOD)[1:5]) |> dplyr::ungroup() res_actual <- ard_tabulate( adae_mini |> unique() |> dplyr::mutate(any_ae = TRUE), strata = c(AESOC, AEDECOD), by = TRTA, variables = any_ae ) |> dplyr::select(group2_level, group3_level) |> tidyr::unnest(everything()) |> unique() expect_equal( res_actual, adae_mini |> dplyr::select(group2_level = AESOC, group3_level = AEDECOD) |> unique() |> dplyr::arrange(group2_level, group3_level), ignore_attr = TRUE ) }) cards/tests/testthat/test-replace_null_statistic.R0000644000176200001440000000073415050667010022210 0ustar liggesuserstest_that("replace_null_statistic() works", { expect_error( ard_with_missing_stats <- data.frame(x = rep_len(NA_character_, 10)) |> ard_summary( 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.R0000644000176200001440000000040115050667010021466 0ustar liggesuserstest_that("check_ard_structure() works", { expect_snapshot( ard_summary(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.R0000644000176200001440000000114515026331522020115 0ustar liggesuserstest_that("nest_for_ard() works", { expect_equal( nest_for_ard(mtcars, strata = c("cyl", "gear"), rename = TRUE) |> nrow(), 8L ) expect_equal( nest_for_ard(mtcars, rename = TRUE) |> nrow(), 1L ) expect_equal( nest_for_ard(mtcars, by = "am", strata = c("cyl", "gear"), rename = TRUE) |> nrow(), 16L ) # check order of lgl variables (see Issue #411) expect_equal( mtcars |> dplyr::mutate(am = as.logical(am)) |> nest_for_ard(by = "am", include_data = FALSE) |> dplyr::pull(group1_level) |> unlist(), c(FALSE, TRUE) ) }) cards/tests/testthat/test-print_ard_conditions.R0000644000176200001440000000731215050667010021666 0ustar liggesuserstest_that("print_ard_conditions() works", { # nothing prints with no errors/warnings expect_snapshot( ard_summary(ADSL, variables = AGE) |> print_ard_conditions() ) # expected messaging without by variable expect_snapshot( ard_summary( 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_summary( 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_summary(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_summary( ADSL, variables = AGE, statistic = ~ list(err_fn = \(x) stop("'tis an error")) ) print_ard_conditions(ard) } tbl_summary() }) }) test_that("print_ard_conditions(condition_type)", { # expected warnings as warnings expect_snapshot( ard_summary( ADSL, variables = AGE, statistic = ~ list(mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }) ) |> print_ard_conditions(condition_type = "identity") ) # expected warnings as warnings expect_snapshot( error = TRUE, ard_summary( ADSL, variables = AGE, statistic = ~ list( mean = \(x) mean(x), err_fn = \(x) stop("'tis an error") ) ) |> print_ard_conditions(condition_type = "identity") ) }) test_that("print_ard_conditions() no error when 'error'/'warning' columns not present", { expect_snapshot( ard_summary( 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_fun = 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_summary(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.R0000644000176200001440000000226715050667010021314 0ustar liggesuserstest_that("rename_ard_columns(columns)", { expect_equal( ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> rename_ard_columns() %>% `[`(1:2) |> names(), c("ARM", "AGEGR1") ) # testing stack output expect_silent( ard_stack <- ard_stack( ADSL, ard_tabulate(variables = AGEGR1), .by = ARM ) |> rename_ard_columns() ) # check the overall ARM tabulations expect_equal( ard_stack |> dplyr::filter(is.na(AGEGR1)) |> dplyr::select(-AGEGR1), ard_tabulate(ADSL, variables = ARM) |> rename_ard_columns() ) }) test_that("rename_ard_columns(columns) messsaging", { expect_snapshot( error = TRUE, ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> rename_ard_columns(columns = all_ard_groups()) ) expect_snapshot( error = TRUE, ADSL |> dplyr::rename(stat = AGEGR1) |> ard_tabulate(by = ARM, variables = stat) |> rename_ard_columns() ) }) test_that("rename_ard_columns(unlist) lifecycle", { lifecycle::expect_deprecated( ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> rename_ard_columns(unlist = "stat") ) }) cards/tests/testthat/test-as_cards_fn.R0000644000176200001440000000035315026331667017724 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_identity.R0000644000176200001440000000206515026332263020134 0ustar liggesuserstest_that("ard_identity() works", { ttest_result <- t.test(formula = AGE ~ 1, data = ADSL) lst_result <- ttest_result[c("statistic", "parameter", "p.value")] # here we convert a named list to an ARD, then back to a list to ensure accurate conversion expect_equal( ard_identity(lst_result, variable = "AGE", context = "ard_onesample_t_test") |> get_ard_statistics(), lst_result[c("statistic", "parameter", "p.value")] ) expect_equal( as.data.frame(lst_result) |> ard_identity(variable = "AGE", context = "ard_onesample_t_test") |> get_ard_statistics(), lst_result[c("statistic", "parameter", "p.value")], ignore_attr = TRUE ) expect_silent( as.data.frame(lst_result) %>% {dplyr::bind_rows(., ., .)} |> #styler: off ard_identity(variable = "AGE", context = "ard_onesample_t_test") |> get_ard_statistics() ) }) test_that("ard_identity() messaging", { # passing results that are not a named list expect_snapshot( error = TRUE, ard_identity(x = as.list(letters), variable = "AGE") ) }) cards/tests/testthat/test-ard_attributes.R0000644000176200001440000000160315113340127020461 0ustar liggesusersskip_if_pkg_not_installed("withr") test_that("ard_attributes() works", { withr::local_options(list(width = 120)) expect_snapshot({ df <- dplyr::tibble(var1 = letters, var2 = LETTERS) attr(df$var1, "label") <- "Lowercase Letters" ard_attributes(df, variables = everything(), label = list(var2 = "UPPERCASE LETTERS")) |> as.data.frame() }) }) test_that("ard_attributes() errors when there is no dataframe", { expect_error( ard_attributes("test"), "There is no method for objects of class ." ) }) test_that("ard_attributes() follows ard structure", { expect_silent( ard_attributes(ADSL[c("AGE", "AGEGR1")]) |> check_ard_structure(method = FALSE) ) }) test_that("ard_attributes() requires label as a named list", { expect_snapshot( error = TRUE, ard_attributes(ADSL[c("AGE", "AGEGR1")], label = list("test") ) ) }) cards/tests/testthat/test-options.R0000644000176200001440000000226615113340127017146 0ustar liggesusersskip_if_pkg_not_installed("withr") test_that("options(cards.round_type)", { # test that the p is rounded to zero (ie rounded to even) for aliases called by `apply_fmt_fun()` withr::local_options(list(cards.round_type = "round-to-even")) expect_equal( data.frame(x = c(T, F)) |> ard_tabulate(variables = everything(), statistic = ~"p") |> update_ard_fmt_fun(stat_names = "p", fmt_fun = 0) |> apply_fmt_fun() |> dplyr::pull("stat_fmt") |> unique() |> unlist(), "0" ) # test that the p is rounded to zero (ie rounded to even) for default fmt functions expect_equal( data.frame(x = rep_len(TRUE, 1999) |> c(FALSE)) |> ard_tabulate(variables = everything(), statistic = ~"p") |> apply_fmt_fun() |> dplyr::filter(variable_level %in% FALSE) |> dplyr::pull("stat_fmt") |> unlist(), "0.0" ) }) test_that("options(cards.round_type) messaging", { # test message when the option is the wrong value expect_snapshot( error = TRUE, withr::with_options( list(cards.round_type = "NOT-CORRECT"), data.frame(x = c(T, F)) |> ard_tabulate(variables = everything(), statistic = ~"p") ) ) }) cards/tests/testthat/test-get_ard_statistics.R0000644000176200001440000000064215050667010021331 0ustar liggesuserstest_that("get_ard_statistics() works", { ard <- ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") expect_snapshot( get_ard_statistics( ard, group1_level %in% "Placebo", variable_level %in% "65-80" ) ) expect_snapshot( get_ard_statistics( ard, group1_level %in% "Placebo", variable_level %in% "65-80", .attributes = c("warning", "error") ) ) }) cards/tests/testthat/test-unlist_ard_columns.R0000644000176200001440000000274015050667010021357 0ustar liggesuserstest_that("unlist_ard_columns()", { expect_equal( ard_tabulate(ADSL, variables = AGEGR1) |> unlist_ard_columns() |> dplyr::pull("stat") |> class(), "numeric" ) expect_equal( ard_tabulate(ADSL, variables = AGEGR1) |> unlist_ard_columns() |> dplyr::pull("variable_level") |> class(), "character" ) expect_equal( ard_tabulate(ADSL, variables = AGEGR1) |> unlist_ard_columns(columns = "error") |> dplyr::pull("error") |> unique(), NA ) }) test_that("unlist_ard_columns() messaging", { expect_message( ard_tabulate(ADSL, variables = AGEGR1) |> dplyr::mutate( stat = ifelse(dplyr::row_number() == 1L, list(matrix(1:4)), stat) ) |> unlist_ard_columns(columns = "stat"), "Cannot unlist column" ) }) test_that("unlist_ard_columns(fct_as_chr)", { # check that a mixed-type column has factors converted to character by default. expect_true( cards::ADSL |> dplyr::mutate(ARM = factor(ARM)) |> ard_stack( ard_summary(variables = AGE), .by = ARM ) |> unlist_ard_columns() |> dplyr::pull("group1_level") |> is.character() ) # check fct_to_chr = FALSE expect_true( cards::ADSL |> dplyr::mutate(ARM = factor(ARM)) |> ard_stack( ard_summary(variables = AGE), .by = ARM ) |> unlist_ard_columns(fct_as_chr = FALSE) |> dplyr::pull("group1_level") |> is.integer() ) }) cards/tests/testthat/test-add_calculated_row.R0000644000176200001440000000171315050667010021252 0ustar liggesuserstest_that("add_calculated_row(x)", { expect_snapshot( ard_summary(mtcars, variables = mpg) |> add_calculated_row(expr = max - min, stat_name = "range") |> apply_fmt_fun() ) expect_snapshot( ard_summary(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_fun() ) }) test_that("add_calculated_row(expr) messaging", { expect_snapshot( ard_summary(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_summary(mtcars, variables = mpg, by = cyl) |> add_calculated_row(expr = max - min, stat_name = "range", by = "context"), error = TRUE ) }) cards/tests/testthat/test-ard_summary.R0000644000176200001440000003206215050667010017776 0ustar liggesuserstest_that("ard_summary() works", { expect_error( ard_test <- ard_summary(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_summary( mtcars, variables = starts_with("xxxxx") ), dplyr::tibble() |> as_card() ) }) test_that("ard_summary(fmt_fun) argument works", { ard_summary( ADSL, variables = "AGE", statistic = list(AGE = continuous_summary_fns(c("N", "mean", "median"))), fmt_fun = 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_fun() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() ard_summary( ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns("mean"), fmt_fun = list( AGE = list( mean = function(x) round5(x, digits = 3) |> as.character() ) ) ) |> apply_fmt_fun() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() # tidyselect works ard_summary( ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns(c("mean", "sd")), fmt_fun = ~ list(~ function(x) round(x, 4)) ) |> apply_fmt_fun() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() }) test_that("ard_summary() messaging", { # proper error message when statistic argument mis-specified expect_snapshot( ard_summary(mtcars, variables = "mpg", statistic = ~ list(mean = "this is a string")), error = TRUE ) # proper error message when non-data frame passed expect_snapshot( ard_summary(letters, variables = "mpg"), error = TRUE ) # proper error message when variables not passed expect_snapshot( ard_summary(mtcars), error = TRUE ) }) test_that("ard_summary(stat_label) argument works", { # formula expect_snapshot( ard_summary( 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_summary( 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_summary( 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_summary( 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_summary( 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_summary() and ARD column names", { ard_colnames <- c( "group1", "group1_level", "variable", "variable_level", "context", "stat_name", "stat_label", "statistic", "fmt_fun", "warning", "error" ) # no errors when these variables are the summary vars expect_error( { df <- mtcars names(df) <- ard_colnames ard_summary( 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_summary( data = df, by = all_of(byvar), variables = "mpg" ) } ) }, NA ) }) test_that("ard_summary() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_summary(variables = AGE), ard_summary(data = ADSL, by = ARM, variables = AGE) ) }) test_that("ard_summary() with dates works and displays as expected", { ard_date <- ADSL |> ard_summary( 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_summary() with empty/missing dates works, and preserves Date class", { empty_date <- data.frame(dt = as.Date(NA)) |> ard_summary( variables = dt, statistic = ~ continuous_summary_fns(c("min")) ) expect_equal(inherits(empty_date$stat[[1]], "Date"), TRUE) }) test_that("ard_summary() works with non-syntactic names", { expect_equal( ADSL |> dplyr::mutate(`BMI base` = BMIBL, `Age` = AGE) |> ard_summary( variables = `BMI base`, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error), ADSL |> ard_summary( 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_summary( variables = "BMI base", statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error), ADSL |> ard_summary( 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_summary( 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_summary() works when using generic names ", { mtcars2 <- mtcars %>% dplyr::rename("variable_level" = mpg, "variable" = cyl, "median" = disp, "p25" = gear) expect_equal( ard_summary(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(variable_level, variable), by = median) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(disp, gear), by = mpg) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(median, p25), by = variable_level) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(disp, gear), by = cyl) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(median, p25), by = variable) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(disp, mpg), by = gear) |> dplyr::select(stat), ard_summary(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_summary(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(by, statistic), by = weights) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(statistic, weights), by = by) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(by, p75), by = statistic) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(by, statistic), by = p75) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_summary(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_summary(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(mean, sd), by = var) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(sd, var), by = mean) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, disp), by = cyl) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(mean, var), by = sd) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(mean, sd), by = sum) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_summary(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_summary(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(deff, min), by = max) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(min, max), by = deff) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, disp), by = cyl) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(deff, max), by = min) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(deff, min), by = mean.std.error) |> dplyr::select(stat) ) expect_equal( ard_summary(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_summary(mtcars2, variables = c(deff, mean.std.error), by = min) |> dplyr::select(stat) ) }) test_that("ard_summary() follows ard structure", { expect_silent( ard_summary(mtcars, variables = c(mpg, gear), by = cyl) |> check_ard_structure(method = FALSE) ) }) test_that("ard_summary() 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_summary( 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_summary( by = am, variables = mpg ) ) }) test_that("ard_summary() 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_summary(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_works)), ard_summary(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_summary(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_error)) |> dplyr::pull("stat_name"), ard_summary(mtcars, variables = mpg, statistic = ~ list(ttest = \(x) t.test(x)[c("statistic", "p.value")])) |> dplyr::pull("stat_name") ) }) cards/tests/testthat/test-label_round.R0000644000176200001440000000056715026331557017755 0ustar liggesuserstest_that("label_round() works", { expect_equal( label_round(scale = 100, digits = 2)(9:10), c("900.00", "1000.00") ) expect_equal( label_round(digits = 2, width = 5)(9:10), c(" 9.00", "10.00") ) expect_equal( label_round()(NA), NA_character_ ) expect_equal( label_round(width = 5)(c(NA, 1)), c(NA_character_, " 1.0") ) }) cards/tests/testthat/test-mock.R0000644000176200001440000000516415027040570016407 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_fun() ) }) 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_fun() ) }) 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_fun() ) }) 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_fun() ) }) 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_fun() ) }) cards/tests/testthat/test-as_nested_list.R0000644000176200001440000000022015050667010020442 0ustar liggesuserstest_that("as_nested_list() works", { expect_snapshot( ard_summary(mtcars, by = "cyl", variables = "hp") |> as_nested_list() ) }) cards/tests/testthat/test-filter_ard_hierarchical.R0000644000176200001440000002325415066623147022301 0ustar liggesusersskip_on_cran() ADAE_subset <- cards::ADAE |> dplyr::filter(AETERM %in% unique(cards::ADAE$AETERM)[1:5]) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE, overall = TRUE ) test_that("filter_ard_hierarchical() works", { withr::local_options(width = 200) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 10)) expect_snapshot(ard_f) expect_equal(nrow(ard_f), 45) expect_silent(ard_f <- filter_ard_hierarchical(ard, p > 0.05)) expect_equal(nrow(ard_f), 117) }) test_that("filter_ard_hierarchical() works with non-standard filters", { expect_silent(ard_f <- filter_ard_hierarchical(ard, n == 2 & p < 0.02)) expect_equal(nrow(ard_f), 18) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 4)) expect_equal(nrow(ard_f), 144) expect_silent(ard_f <- filter_ard_hierarchical(ard, mean(n) > 4 | n > 3)) expect_equal(nrow(ard_f), 117) expect_silent(ard_f <- filter_ard_hierarchical(ard, any(n > 3 & TRTA == "Xanomeline High Dose"))) expect_equal(nrow(ard_f), 108) expect_silent( ard_f <- filter_ard_hierarchical( ard, any(n > 5 & TRTA == "Xanomeline High Dose") ) ) expect_equal(nrow(ard_f), 90) }) test_that("filter_ard_hierarchical() works with column-specific filters", { # test overall stat derivations (when overall=FALSE) are equal to stats when overall=TRUE ard_o <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE, overall = FALSE ) # difference between n's in columns 2 and 3 > 1 (one-sided) expect_message(ard_f <- filter_ard_hierarchical(ard, n_2 - n_3 > 1)) expect_equal(nrow(ard_f), 63) # difference between n's in columns 2 and 3 > 1 (absolute) expect_message(ard_f <- filter_ard_hierarchical(ard, abs(n_2 - n_3) > n_1)) expect_equal(nrow(ard_f), 144) # overall prevalence across row group > 30% expect_silent(ard_f <- filter_ard_hierarchical(ard, p_overall > 0.3)) # p_overall calculated correctly expect_identical( ard_f, ard |> filter_ard_hierarchical(sum(n) / sum(N) > 0.3), ) # derived p_overall equal to p_overall coming from overall=TRUE expect_identical( ard_f, ard_o |> filter_ard_hierarchical(p_overall > 0.3) ) # overall prevalence across row group > 15 expect_silent(ard_f <- filter_ard_hierarchical(ard, n_overall > 15)) # n_overall calculated correctly expect_identical( ard_f, ard |> filter_ard_hierarchical(sum(n) > 15) ) # derived n_overall equal to n_overall coming from overall=TRUE expect_identical( ard_f, ard_o |> filter_ard_hierarchical(n_overall > 15) ) # p_overall equal to n_overall / N_overall from overall=TRUE expect_silent(ard_f <- filter_ard_hierarchical(ard, n_overall / N_overall == p_overall)) # derived p_overall equal to derived n_overall / N_overall expect_identical( ard_f, ard_o |> filter_ard_hierarchical(n_overall / N_overall == p_overall) ) # check for number of rows expect_silent(ard_f <- filter_ard_hierarchical(ard, p_overall <= 0.1)) expect_equal(nrow(ard_f), 234) # column-wise n statistic equal to previous derivation with column name specified (both still work) expect_message(ard_f <- filter_ard_hierarchical(ard, n_2 > 5)) expect_identical( ard_f, ard |> filter_ard_hierarchical(any(n > 5 & TRTA == "Xanomeline High Dose")) ) # column-wise p statistics equal to previous derivation with column names specified (both still work) expect_message(ard_f <- filter_ard_hierarchical(ard, p_2 > 0.15 | p_3 > 0.2)) expect_identical( ard_f, ard |> filter_ard_hierarchical(any(p > 0.15 & TRTA == "Xanomeline High Dose") | any(p > 0.2 & TRTA == "Xanomeline Low Dose")) ) }) test_that("filter_ard_hierarchical() works with ard_stack_hierarchical_count() results", { withr::local_options(width = 200) ard <- ard_stack_hierarchical_count( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, over_variables = TRUE ) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 10)) expect_equal(nrow(ard_f), 39) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 15)) expect_equal(nrow(ard_f), 42) }) test_that("filter_ard_hierarchical() returns only summary rows when all rows filtered out", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, include = "AETERM", denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID ) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 200)) expect_equal( ard_f, ard |> dplyr::filter(variable != "AETERM") ) expect_true(all(ard_f$variable == "TRTA")) }) test_that("filter_ard_hierarchical(var) works", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(AESOC, AEDECOD, AETOXGR), by = TRTA, denominator = cards::ADSL, id = USUBJID ) # default uses the correct variable expect_identical( filter_ard_hierarchical(ard, n > 5, var = AETOXGR), filter_ard_hierarchical(ard, n > 5) ) # works with `var` specified expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 15, var = AEDECOD)) expect_equal(nrow(ard_f), 189) # works with first hierarchy variable expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 50, var = AESOC)) expect_equal(nrow(ard_f), 108) # works with no `by` variable, attributes ard_noby <- ard_stack_hierarchical( data = ADAE_subset, variables = c(AESOC, AEDECOD, AETOXGR), denominator = cards::ADSL, id = USUBJID, attributes = TRUE ) expect_silent(ard_f <- filter_ard_hierarchical(ard_noby, sum(n) > 10, var = AEDECOD)) expect_equal(nrow(ard_f), 67) }) test_that("filter_ard_hierarchical(keep_empty) works", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AEBODSYS, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID ) # keep summary rows expect_silent( ard_f <- filter_ard_hierarchical(ard, sum(n) > 10, keep_empty = TRUE) ) expect_equal(nrow(ard_f), 270) # remove summary rows expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 10)) expect_equal(nrow(ard_f), 153) # all inner rows removed (only header rows remain) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 1000)) expect_equal(nrow(ard_f), 9) ard_noincl <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AEBODSYS, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, include = AETERM ) # no summary rows to remove expect_silent(ard_f <- filter_ard_hierarchical(ard_noincl, sum(n) > 10)) expect_silent( ard_f_keep <- filter_ard_hierarchical( ard_noincl, sum(n) > 10, keep_empty = TRUE ) ) expect_equal(nrow(ard_f), 72) expect_identical(ard_f, ard_f_keep) }) test_that("filter_ard_hierarchical() works with only one variable in x", { ard_single <- ard_stack_hierarchical( data = ADAE_subset, variables = AETERM, by = TRTA, denominator = cards::ADSL, id = USUBJID ) expect_silent(ard_single <- filter_ard_hierarchical(ard_single, n > 20)) expect_equal(nrow(ard_single), 18) }) test_that("filter_ard_hierarchical() works when some variables not included in x", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, include = c(SEX, AETERM), over_variables = TRUE ) expect_silent(filter_ard_hierarchical(ard, n > 10)) }) test_that("filter_ard_hierarchical() works with overall data", { ard_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE, overall = TRUE ) expect_equal( ard_overall |> filter_ard_hierarchical(n > 5) |> nrow(), ard |> filter_ard_hierarchical(n > 5) |> nrow() ) }) test_that("filter_ard_hierarchical() error messaging works", { # invalid x input expect_snapshot( filter_ard_hierarchical( ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), n > 10 ), error = TRUE ) # invalid filter input expect_snapshot( filter_ard_hierarchical(ard, 10), error = TRUE ) # invalid filter parameters expect_snapshot( filter_ard_hierarchical(ard, A > 5), error = TRUE ) # invalid var input expect_snapshot( filter_ard_hierarchical(ard, n > 1, var = "A"), error = TRUE ) expect_snapshot( filter_ard_hierarchical(ard, n > 1, var = c(SEX, RACE)), error = TRUE ) # invalid var input - not in include ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, include = c(SEX, AETERM), denominator = cards::ADSL, id = USUBJID, over_variables = TRUE ) expect_snapshot( filter_ard_hierarchical(ard, n > 1, var = RACE), error = TRUE ) # invalid keep_empty input expect_snapshot( filter_ard_hierarchical(ard, n > 1, keep_empty = NULL), error = TRUE ) ard_stat_miss <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, statistic = ~"p" ) # unavailable filter statistic expect_snapshot( filter_ard_hierarchical(ard_stat_miss, n_1 > 1), error = TRUE ) # p_overall not valid expect_snapshot( filter_ard_hierarchical(ard_stat_miss, p_overall > 0.1), error = TRUE ) }) cards/tests/testthat/test-ard_hierarchical.R0000644000176200001440000002210615113340127020712 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 ), 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 ), 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, 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, 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 ), ard_hierarchical( data = ADAE, by = TRTA, variables = c(AESOC, AEDECOD), denominator = ADSL ) ) 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_pkg_not_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.R0000644000176200001440000000047615026331706017750 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.R0000644000176200001440000000246015113340127022016 0ustar liggesuserstest_that("tidy_ard_column_order() works", { skip_if_pkg_not_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_tabulate( 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.R0000644000176200001440000000360015051154501017570 0ustar liggesuserstest_that("ard_strata() works", { expect_snapshot( ard_strata( ADSL, .by = ARM, .f = ~ ard_summary(.x, variables = AGE) ) ) expect_snapshot( ard_strata( ADSL, .strata = ARM, .f = ~ ard_summary(.x, variables = AGE, by = AGEGR1) ) ) expect_equal( ard_strata(ADSL, .by = ARM, .f = ~ ard_summary(.x, by = c(SEX, AGEGR1), variables = AGE)) |> tidy_ard_column_order() |> tidy_ard_row_order(), ard_summary(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_summary(.x, variables = AGE)), ard_summary(ADSL, variables = AGE) ) expect_equal( ard_strata(ADSL, .f = ~ ard_summary(.x, by = ARM, variables = AGE)), ard_summary(ADSL, by = ARM, variables = AGE) ) }) test_that("ard_strata computes stats for parameter specific strata", { withr::local_options(list(width = 180)) df <- data.frame( USUBJID = 1:12, PARAMCD = rep(c("PARAM1", "PARAM2"), each = 6), AVALC = c( "Yes", "No", "Yes", # PARAM1 "Yes", "Yes", "No", # PARAM1 "Low", "Medium", "High", # PARAM2 "Low", "Low", "Medium" # PARAM2 ) ) param_levels <- list( PARAM1 = c("Yes", "No"), PARAM2 = c("Zero", "Low", "Medium", "High") ) tbl <- ard_strata( df, .strata = PARAMCD, .f = \(.x) { param <- .x[["PARAMCD"]][1] .x |> dplyr::mutate( AVALC = factor(AVALC, levels = param_levels[[param]]) ) |> ard_tabulate(variables = AVALC) } ) ## line added to fix failing snapshot test on ubuntu-latest (devel) ## TODO: resolve after release of R-devel skip_if_not(package_version(paste(R.version$major, R.version$minor, sep = ".")) <= package_version("4.5.0")) expect_snapshot(as.data.frame(tbl)) }) cards/tests/testthat/test-tidy_ard_row_order.R0000644000176200001440000000117615113340127021333 0ustar liggesuserstest_that("tidy_ard_row_order() works", { skip_if_pkg_not_installed("withr") withr::local_options(list(width = 120)) withr::local_seed(1) # ensure rows are ordered within descending groups but not variables expect_snapshot( data.frame( x1 = sample(LETTERS[1:5], 30, replace = TRUE), x2 = sample(LETTERS[6:10], 30, replace = TRUE), x3 = sample(LETTERS[11:15], 30, replace = TRUE), zz = 1L, aa = 1L ) |> ard_tabulate( by = x1:x3, variables = c(zz, aa), statistic = everything() ~ "n" ) |> dplyr::select(all_ard_groups(), all_ard_variables()) ) }) cards/tests/testthat/test-apply_fmt_fun.R0000644000176200001440000000525015050667010020315 0ustar liggesusersard_fmt_checks <- ard_summary( data = mtcars, variables = mpg, statistic = ~ continuous_summary_fns(c("mean", "sd")) ) test_that("apply_fmt_fun() works", { expect_equal( ard_fmt_checks |> apply_fmt_fun() |> 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_fun = list(NULL, 2) ) |> apply_fmt_fun() |> dplyr::pull(stat_fmt), list(NULL, "6.03") ) }) test_that("apply_fmt_fun() works with integer specification", { expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fun = list(2, 2) ) |> apply_fmt_fun() |> dplyr::pull(stat_fmt) |> unlist(), c("20.09", "6.03") ) }) test_that("apply_fmt_fun() works with xx specification", { expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fun = list("xx.xx", "xx.xx") ) |> apply_fmt_fun() |> dplyr::pull(stat_fmt) |> unlist(), c("20.09", " 6.03") ) expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fun = list("xx.xxx", "xx.xxx") ) |> apply_fmt_fun() |> dplyr::pull(stat_fmt) |> unlist(), c("20.091", " 6.027") ) expect_equal( ard_tabulate( data = mtcars, variables = am, fmt_fun = list( am = list( n = "xx", N = "xx", p = "xx.xx%" ) ) ) |> apply_fmt_fun() |> dplyr::pull(stat_fmt) |> unlist() |> unname(), c("19", "32", "59.38", "13", "32", "40.63") ) }) test_that("apply_fmt_fun() error messaging", { expect_snapshot( apply_fmt_fun(letters), error = TRUE ) expect_snapshot( ard_fmt_checks |> dplyr::mutate( fmt_fun = list("xoxo", "xoxo") ) |> apply_fmt_fun(), error = TRUE ) expect_snapshot( ard_fmt_checks |> dplyr::mutate( fmt_fun = list(1L, -1L) ) |> apply_fmt_fun(), 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_fun = list("xx", "xx") ) |> apply_fmt_fun() |> as.data.frame() ) }) test_that("apply_fmt_fun(replace)", { ard <- ADSL |> ard_tabulate(variables = AGEGR1, statistic = ~"n") |> dplyr::mutate( stat_fmt = ifelse(dplyr::row_number() == 1, list("144.000000"), list(NULL)) ) expect_snapshot( apply_fmt_fun(ard, replace = FALSE) ) expect_snapshot( apply_fmt_fun(ard, replace = TRUE) ) }) cards/tests/testthat/test-ard_stack.R0000644000176200001440000002115715113466401017412 0ustar liggesuserstest_that("ard_stack() works", { # with by variable expect_error( ard1 <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1) ), NA ) expect_equal( ard1, bind_ard( ard_summary(data = mtcars, by = "cyl", variables = "mpg"), ard_tabulate_value(data = mtcars, by = "cyl", variables = "vs", value = vs ~ 1), ard_tabulate(data = mtcars, variables = "cyl"), .order = TRUE ), ignore_function_env = TRUE, ignore_attr = TRUE ) # check equivalency NSE expect_equal( ard1, ard_stack( data = mtcars, .by = cyl, ard_summary(variables = mpg), ard_tabulate_value(variables = vs, value = vs ~ 1) ), ignore_function_env = TRUE, ignore_attr = 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_summary(variables = all_of(var_cont)), ard_tabulate_value(variables = all_of(var_cat), , value = all_of(var_cat) ~ 1) ) ) # without by variable expect_error( ard2 <- ard_stack( data = mtcars, .by = NULL, ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1) ), NA ) ard_match <- bind_ard( ard_summary(data = mtcars, variables = "mpg"), ard_tabulate_value(data = mtcars, variables = "vs", value = vs ~ 1), .order = TRUE ) attr(ard_match, "args") <- list( by = character(0) ) expect_equal( ard2, ard_match, ignore_function_env = TRUE ) expect_equal( ard2, ard_stack( data = mtcars2, ard_summary(variables = all_of(var_cont)), ard_tabulate_value(variables = all_of(var_cat), value = all_of(var_cat) ~ 1) ) ) }) test_that("ard_stack() adding overalls", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .overall = TRUE ), NA ) ard_match <- bind_ard( ard_summary(data = mtcars, by = "cyl", variables = "mpg"), ard_tabulate_value(data = mtcars, by = "cyl", variables = "vs", value = vs ~ 1), ard_summary(data = mtcars, variables = "mpg"), ard_tabulate_value(data = mtcars, variables = "vs", value = vs ~ 1), ard_tabulate(data = mtcars, variables = "cyl"), .update = TRUE, .order = TRUE ) attr(ard_match, "args") <- list( by = "cyl" ) expect_equal( ard_test, ard_match ) }) test_that("ard_stack() adding missing/attributes", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .missing = TRUE, .attributes = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_summary(data = mtcars, by = "cyl", variables = "mpg"), ard_tabulate_value(data = mtcars, by = "cyl", variables = "vs", value = vs ~ 1), ard_missing(data = mtcars, by = "cyl", variables = c("mpg", "vs")), ard_tabulate(data = mtcars, variables = "cyl"), ard_attributes(mtcars, variables = c("mpg", "vs", "cyl")), .update = TRUE, .order = TRUE ), ignore_attr = TRUE ) # including `.overall=TRUE` expect_error( ard_test_overall <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .missing = TRUE, .overall = TRUE, .attributes = TRUE ), NA ) expect_equal( ard_test_overall, bind_ard( ard_summary(data = mtcars, by = "cyl", variables = "mpg"), ard_tabulate_value(data = mtcars, by = "cyl", variables = "vs", value = vs ~ 1), ard_missing(data = mtcars, by = "cyl", variables = c("mpg", "vs")), ard_summary(data = mtcars, variables = "mpg"), ard_tabulate_value(data = mtcars, variables = "vs", value = vs ~ 1), ard_tabulate(data = mtcars, variables = "cyl"), ard_missing(data = mtcars, variables = c("mpg", "vs")), ard_attributes(mtcars, variables = c("mpg", "vs", "cyl")), .update = TRUE, .order = TRUE ), ignore_attr = TRUE ) }) test_that("ard_stack() .shuffle argument errors", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .shuffle = TRUE ) ) }) test_that("ard_stack() adding total N", { expect_equal( ard_stack( mtcars, .by = am, ard_summary(variables = mpg), .total_n = TRUE ) |> tail(n = 1) |> dplyr::select(-all_ard_groups(), -all_ard_variables("levels")), ard_total_n(mtcars), ignore_attr = TRUE ) }) test_that("ard_stack() works with namespaced functions", { expect_equal( ard_stack( data = mtcars, cards::ard_summary(variables = "mpg") ), ard_stack( data = mtcars, ard_summary(variables = "mpg") ) ) }) test_that("ard_stack() messaging", { withr::local_options(list(width = 150)) expect_snapshot( ard_stack( data = mtcars, ard_summary(variables = "mpg"), .overall = TRUE ) |> head(1L) ) # by argument doesn't include period in front expect_snapshot( error = TRUE, ard_stack(ADSL, by = "ARM", ard_summary(variables = AGE)) ) }) test_that("ard_stack() complex call error", { withr::local_options(list(width = 150)) expect_snapshot( { complex_call <- list() complex_call$ard_summary <- ard_summary ard_stack( data = mtcars, .by = am, complex_call$ard_summary(variables = "mpg"), ) }, error = TRUE ) }) test_that("ard_stack() follows ard structure", { expect_silent( ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1) ) |> 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_summary(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_summary(variables = "mpg", statistic = ~ continuous_summary_fns("N")), .by = c(am, vs), .total_n = TRUE, .overall = TRUE ) |> dplyr::filter(stat_name %in% "N") ) }) test_that("ard_stack() .by_stats argument", { # by stats for 1 variable expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .by_stats = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_summary(data = mtcars, by = "cyl", variables = "mpg"), ard_tabulate_value(data = mtcars, by = "cyl", variables = "vs", value = vs ~ 1), ard_tabulate(data = mtcars, variables = "cyl"), .update = TRUE, .order = TRUE ), ignore_attr = TRUE ) # by stats for 2 variables expect_error( ard_test <- ard_stack( data = mtcars, .by = c("am", "cyl"), ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .by_stats = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_summary(data = mtcars, c("am", "cyl"), variables = "mpg"), ard_tabulate_value(data = mtcars, c("am", "cyl"), variables = "vs", value = vs ~ 1), ard_tabulate(data = mtcars, variables = "am"), ard_tabulate(data = mtcars, variables = "cyl"), .update = TRUE, .order = TRUE ), ignore_attr = TRUE ) # no by stats expect_error( ard_test <- ard_stack( data = mtcars, .by = c("am", "cyl"), ard_summary(variables = "mpg"), ard_tabulate_value(variables = "vs", value = vs ~ 1), .by_stats = FALSE ), NA ) expect_equal( ard_test, bind_ard( ard_summary(data = mtcars, by = c("am", "cyl"), variables = "mpg"), ard_tabulate_value(data = mtcars, by = c("am", "cyl"), variables = "vs", value = vs ~ 1), .update = TRUE, .order = TRUE ), ignore_attr = TRUE ) }) cards/tests/testthat/test-ard_formals.R0000644000176200001440000000051115026332314017735 0ustar liggesuserstest_that("ard_formals() works", { expect_snapshot( ard_formals(fun = mcnemar.test, arg_names = "correct") ) expect_snapshot( ard_formals( fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.90) ) ) }) cards/tests/testthat/test-update_ard.R0000644000176200001440000000523315050667010017563 0ustar liggesuserstest_that("update_ard_fmt_fun()", { expect_equal( ard_summary(ADSL, variables = AGE) |> update_ard_fmt_fun(stat_names = c("mean", "sd"), fmt_fun = 8L) |> apply_fmt_fun() |> dplyr::filter(stat_name %in% c("mean", "sd")) |> dplyr::pull("stat_fmt") |> unlist(), c("75.08661417", "8.24623390") ) expect_snapshot( error = TRUE, ard_summary(ADSL, variables = AGE) |> update_ard_fmt_fun(stat_names = c("mean", "sd"), fmt_fun = -8L) ) }) test_that("update_ard_fmt_fun(filter)", { # apply update to the Placebo level expect_snapshot( ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fun(stat_names = "mean", fmt_fun = 8L, filter = group1_level == "Placebo") |> apply_fmt_fun() ) }) test_that("update_ard_fmt_fun(filter) messaging", { # test error messaging expect_snapshot( error = TRUE, ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fun(stat_names = "mean", fmt_fun = 8L, filter = group99999999_level == "Placebo") ) expect_snapshot( error = TRUE, ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fun(stat_names = "mean", fmt_fun = 8L, filter = c(TRUE, FALSE)) ) }) test_that("update_ard_stat_label()", { expect_equal( ard_summary(ADSL, variables = AGE) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> apply_fmt_fun() |> 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_summary(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_summary(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_summary(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.R0000644000176200001440000000076115026331324016667 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.R0000644000176200001440000000606215050667010020125 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_mvsummary(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_mvsummary( 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_mvsummary( 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_mvsummary(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_mvsummary(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)) ) ) expect_snapshot( error = TRUE, ard_pairwise( ADSL, variable = NOT_A_COLUMN, .f = \(df) ard_mvsummary(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_mvsummary(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_mvsummary(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_mvsummary(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = mtcars ) ) }) cards/tests/testthat/test-ard_missing.R0000644000176200001440000000407615027040570017756 0ustar liggesuserstest_that("ard_missing() works", { expect_error( ard <- ard_missing(ADSL, by = "ARM", variables = "BMIBL"), NA ) expect_snapshot( ard |> dplyr::select(-"fmt_fun") |> 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/_snaps/0000755000176200001440000000000015113466401015634 5ustar liggesuserscards/tests/testthat/_snaps/round5.md0000644000176200001440000000263015051153343017372 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.md0000644000176200001440000002477115051153450020313 0ustar liggesusers# ard_strata() works Code ard_strata(ADSL, .by = ARM, .f = ~ ard_summary(.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_fun, warning, error --- Code ard_strata(ADSL, .strata = ARM, .f = ~ ard_summary(.x, variables = AGE, by = AGEGR1)) Message {cards} data frame: 72 x 12 Output group2 group2_level group1 group1_level variable stat_name stat_label stat 1 ARM Placebo AGEGR1 65-80 AGE N N 42 2 ARM Placebo AGEGR1 65-80 AGE mean Mean 73.595 3 ARM Placebo AGEGR1 65-80 AGE sd SD 4.173 4 ARM Placebo AGEGR1 65-80 AGE median Median 74 5 ARM Placebo AGEGR1 65-80 AGE p25 Q1 70 6 ARM Placebo AGEGR1 65-80 AGE p75 Q3 77 7 ARM Placebo AGEGR1 65-80 AGE min Min 65 8 ARM Placebo AGEGR1 65-80 AGE max Max 80 9 ARM Placebo AGEGR1 <65 AGE N N 14 10 ARM Placebo AGEGR1 <65 AGE mean Mean 61.143 Message i 62 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fun, warning, error # ard_strata computes stats for parameter specific strata Code as.data.frame(tbl) Output group1 group1_level variable variable_level context stat_name stat_label stat 1 PARAMCD PARAM1 AVALC 1 tabulate n n 4 2 PARAMCD PARAM1 AVALC 1 tabulate N N 6 3 PARAMCD PARAM1 AVALC 1 tabulate p % 0.6666667 4 PARAMCD PARAM1 AVALC 2 tabulate n n 2 5 PARAMCD PARAM1 AVALC 2 tabulate N N 6 6 PARAMCD PARAM1 AVALC 2 tabulate p % 0.3333333 7 PARAMCD PARAM2 AVALC 1 tabulate n n 0 8 PARAMCD PARAM2 AVALC 1 tabulate N N 6 9 PARAMCD PARAM2 AVALC 1 tabulate p % 0 10 PARAMCD PARAM2 AVALC 2 tabulate n n 3 11 PARAMCD PARAM2 AVALC 2 tabulate N N 6 12 PARAMCD PARAM2 AVALC 2 tabulate p % 0.5 13 PARAMCD PARAM2 AVALC 3 tabulate n n 2 14 PARAMCD PARAM2 AVALC 3 tabulate N N 6 15 PARAMCD PARAM2 AVALC 3 tabulate p % 0.3333333 16 PARAMCD PARAM2 AVALC 4 tabulate n n 1 17 PARAMCD PARAM2 AVALC 4 tabulate N N 6 18 PARAMCD PARAM2 AVALC 4 tabulate p % 0.1666667 fmt_fun 1 0 2 0 3 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } 4 0 5 0 6 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } 7 0 8 0 9 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } 10 0 11 0 12 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } 13 0 14 0 15 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } 16 0 17 0 18 function (x) , {, res <- ifelse(is.na(x), NA_character_, str_trim(format(round_fun(x * , scale, digits = digits), nsmall = digits))), if (!is.null(width)) {, res <- ifelse(nchar(res) >= width | is.na(res), res, , paste0(strrep(" ", width - nchar(res)), res)), }, res, } warning error 1 NULL NULL 2 NULL NULL 3 NULL NULL 4 NULL NULL 5 NULL NULL 6 NULL NULL 7 NULL NULL 8 NULL NULL 9 NULL NULL 10 NULL NULL 11 NULL NULL 12 NULL NULL 13 NULL NULL 14 NULL NULL 15 NULL NULL 16 NULL NULL 17 NULL NULL 18 NULL NULL cards/tests/testthat/_snaps/filter_ard_hierarchical.md0000644000176200001440000001076615051153340022775 0ustar liggesusers# filter_ard_hierarchical() works Code ard_f Message {cards} data frame: 45 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level stat_name stat_label stat 1 TRTA Placebo n n 86 2 TRTA Placebo N N 254 3 TRTA Placebo p % 0.339 4 TRTA Xanomeli… n n 84 5 TRTA Xanomeli… N N 254 6 TRTA Xanomeli… p % 0.331 7 TRTA Xanomeli… n n 84 8 TRTA Xanomeli… N N 254 9 TRTA Xanomeli… p % 0.331 10 TRTA Placebo ..ard_hierarchical_overall.. TRUE n n 26 Message i 35 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fun, warning, error # filter_ard_hierarchical() error messaging works Code filter_ard_hierarchical(ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), n > 10) Condition Error in `filter_ard_hierarchical()`: ! Filtering is only available for stacked hierarchical ARDs created using `ard_stack_hierarchical()` or `ard_stack_hierarchical_count()`. --- Code filter_ard_hierarchical(ard, 10) Condition Error in `filter_ard_hierarchical()`: ! The `filter` argument must be an expression. --- Code filter_ard_hierarchical(ard, A > 5) Condition Error in `filter_ard_hierarchical()`: ! The expression provided as `filter` includes condition for statistic "A" which is not present in the ARD and does not correspond to any of the `by` variable levels. i Valid filter terms for variable "AETERM" are: "n", "N", "p", "n_1", "n_2", "n_3", "N_1", "N_2", "N_3", "p_1", "p_2", "p_3", "n_overall", "N_overall", "p_overall", and "TRTA". --- Code filter_ard_hierarchical(ard, n > 1, var = "A") Condition Error in `filter_ard_hierarchical()`: ! Error processing `var` argument. ! Can't select columns that don't exist. x Column `A` doesn't exist. i Select among columns "SEX", "RACE", and "AETERM" --- Code filter_ard_hierarchical(ard, n > 1, var = c(SEX, RACE)) Condition Error in `filter_ard_hierarchical()`: ! Only one variable can be selected as `var`. --- Code filter_ard_hierarchical(ard, n > 1, var = RACE) Condition Error in `filter_ard_hierarchical()`: ! No statistics available in the ARD for variable "RACE". In order to filter on "RACE" it must be specified in the `include` argument when the ARD is created. --- Code filter_ard_hierarchical(ard, n > 1, keep_empty = NULL) Condition Error in `filter_ard_hierarchical()`: ! The `keep_empty` argument must be a scalar with class , not NULL. --- Code filter_ard_hierarchical(ard_stat_miss, n_1 > 1) Condition Error in `filter_ard_hierarchical()`: ! The expression provided as `filter` includes condition for statistic "n_1" which is not present in the ARD and does not correspond to any of the `by` variable levels. i Valid filter terms for variable "AETERM" are: "p", "p_1", "p_2", "p_3", and "TRTA". --- Code filter_ard_hierarchical(ard_stat_miss, p_overall > 0.1) Condition Error in `filter_ard_hierarchical()`: ! The expression provided as `filter` includes condition for statistic "p_overall" which is not present in the ARD and does not correspond to any of the `by` variable levels. i Valid filter terms for variable "AETERM" are: "p", "p_1", "p_2", "p_3", and "TRTA". cards/tests/testthat/_snaps/bind_ard.md0000644000176200001440000001242415051153330017716 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_tabulate(ADSL, by = "ARM", variables = "SEX") %>% { dplyr::slice(., sample.int(nrow(.))) }, .order = TRUE)), -c(context, fmt_fun, warning, error)) Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Xanomeline Low Dose SEX M n n 34 2 ARM Xanomeline Low Dose SEX M p % 0.4047619 3 ARM Xanomeline Low Dose SEX F p % 0.5952381 4 ARM Xanomeline Low Dose SEX M N N 84 5 ARM Xanomeline Low Dose SEX F n n 50 6 ARM Xanomeline Low Dose SEX F N N 84 7 ARM Placebo SEX M p % 0.3837209 8 ARM Placebo SEX M n n 33 9 ARM Placebo SEX F n n 53 10 ARM Placebo SEX F N N 86 11 ARM Placebo SEX F p % 0.6162791 12 ARM Placebo SEX M N N 86 13 ARM Xanomeline High Dose SEX M N N 84 14 ARM Xanomeline High Dose SEX M p % 0.5238095 15 ARM Xanomeline High Dose SEX F p % 0.4761905 16 ARM Xanomeline High Dose SEX F N N 84 17 ARM Xanomeline High Dose SEX F n n 40 18 ARM Xanomeline High Dose SEX M n n 44 --- Code dplyr::select(as.data.frame(bind_ard(ard_tabulate(ADSL, by = "ARM", variables = "SEX") %>% { dplyr::slice(., sample.int(nrow(.))) }, .order = FALSE)), -c(context, fmt_fun, warning, error)) Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Placebo SEX F p % 0.6162791 2 ARM Xanomeline Low Dose SEX F N N 84 3 ARM Placebo SEX M n n 33 4 ARM Xanomeline High Dose SEX F n n 40 5 ARM Xanomeline High Dose SEX F p % 0.4761905 6 ARM Placebo SEX F n n 53 7 ARM Xanomeline High Dose SEX M n n 44 8 ARM Xanomeline High Dose SEX M N N 84 9 ARM Placebo SEX M p % 0.3837209 10 ARM Placebo SEX M N N 86 11 ARM Xanomeline Low Dose SEX F p % 0.5952381 12 ARM Placebo SEX F N N 86 13 ARM Xanomeline Low Dose SEX M p % 0.4047619 14 ARM Xanomeline High Dose SEX M p % 0.5238095 15 ARM Xanomeline High Dose SEX F N N 84 16 ARM Xanomeline Low Dose SEX F n n 50 17 ARM Xanomeline Low Dose SEX M N N 84 18 ARM Xanomeline Low Dose SEX M n n 34 # bind_ard(.distinct) Code ard_summary(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_fun 1 AGE summary N N 254 0 2 AGE summary mean Mean 75.087 1 3 AGE summary sd SD 8.246 1 4 AGE summary median Median 77 1 5 AGE summary p25 Q1 70 1 6 AGE summary p75 Q3 81 1 7 AGE summary min Min 51 1 8 AGE summary max Max 89 1 Message i 2 more variables: warning, error cards/tests/testthat/_snaps/ard_formals.md0000644000176200001440000000117715051153306020453 0ustar liggesusers# ard_formals() works Code ard_formals(fun = mcnemar.test, arg_names = "correct") Message {cards} data frame: 1 x 3 Output stat_name stat_label stat 1 correct correct TRUE --- Code ard_formals(fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.9)) Message {cards} data frame: 4 x 3 Output stat_name stat_label stat 1 mu mu 0 2 paired paired FALSE 3 var.equal var.equal FALSE 4 conf.level conf.lev… 0.9 cards/tests/testthat/_snaps/tidy_ard_row_order.md0000644000176200001440000000276615051153347022055 0ustar liggesusers# tidy_ard_row_order() works Code dplyr::select(ard_tabulate(data.frame(x1 = sample(LETTERS[1:5], 30, replace = TRUE), x2 = sample(LETTERS[6:10], 30, replace = TRUE), x3 = sample(LETTERS[11:15], 30, replace = TRUE), zz = 1L, aa = 1L), by = x1:x3, variables = c(zz, aa), statistic = everything() ~ "n"), all_ard_groups(), all_ard_variables()) Message {cards} data frame: 250 x 8 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level 1 x1 A x2 F x3 K zz 1 2 x1 A x2 F x3 K aa 1 3 x1 A x2 F x3 L zz 1 4 x1 A x2 F x3 L aa 1 5 x1 A x2 F x3 M zz 1 6 x1 A x2 F x3 M aa 1 7 x1 A x2 F x3 N zz 1 8 x1 A x2 F x3 N aa 1 9 x1 A x2 F x3 O zz 1 10 x1 A x2 F x3 O aa 1 Message i 240 more rows i Use `print(n = ...)` to see more rows cards/tests/testthat/_snaps/add_calculated_row.md0000644000176200001440000000514715051153306021763 0ustar liggesusers# add_calculated_row(x) Code apply_fmt_fun(add_calculated_row(ard_summary(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 summary N N 32 32 2 mpg summary mean Mean 20.091 20.1 3 mpg summary sd SD 6.027 6.0 4 mpg summary median Median 19.2 19.2 5 mpg summary p25 Q1 15.35 15.4 6 mpg summary p75 Q3 22.8 22.8 7 mpg summary min Min 10.4 10.4 8 mpg summary max Max 33.9 33.9 9 mpg summary range range 23.5 23.5 Message i 3 more variables: fmt_fun, warning, error --- Code apply_fmt_fun(add_calculated_row(ard_summary(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 summary N N 32 32 2 mpg summary mean Mean 20.091 20.1 3 mpg summary sd SD 6.027 6.0 4 mpg summary median Median 19.2 19.2 5 mpg summary p25 Q1 15.35 15.4 6 mpg summary p75 Q3 22.8 22.8 7 mpg summary min Min 10.4 10.4 8 mpg summary max Max 33.9 33.9 9 mpg summary skew skew Right Sk… Right Skew Message i 3 more variables: fmt_fun, warning, error # add_calculated_row(expr) messaging Code add_calculated_row(ard_summary(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_summary(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.md0000644000176200001440000001031015051153342017303 0ustar liggesusers# print.card() works Code ard_summary(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_fun, warning, error --- Code ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") Message {cards} data frame: 27 x 11 Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Placebo AGEGR1 65-80 n n 42 2 ARM Placebo AGEGR1 65-80 N N 86 3 ARM Placebo AGEGR1 65-80 p % 0.488 4 ARM Placebo AGEGR1 <65 n n 14 5 ARM Placebo AGEGR1 <65 N N 86 6 ARM Placebo AGEGR1 <65 p % 0.163 7 ARM Placebo AGEGR1 >80 n n 30 8 ARM Placebo AGEGR1 >80 N N 86 9 ARM Placebo AGEGR1 >80 p % 0.349 10 ARM Xanomeli… AGEGR1 65-80 n n 55 Message i 17 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fun, warning, error --- Code ard_summary(ADSL, variables = "AGE", fmt_fun = AGE ~ list(~ function(x) round(x, 3))) Message {cards} data frame: 8 x 8 Output variable context stat_name stat_label stat fmt_fun 1 AGE summary N N 254 2 AGE summary mean Mean 75.087 3 AGE summary sd SD 8.246 4 AGE summary median Median 77 5 AGE summary p25 Q1 70 6 AGE summary p75 Q3 81 7 AGE summary min Min 51 8 AGE summary max Max 89 Message i 2 more variables: warning, error --- Code dplyr::select(ard_summary(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_fun) Message {cards} data frame: 3 x 7 Output variable context stat_name stat_label stat error 1 x summary min Min 2000-01-… 2 x summary max Max 2000-01-… 3 x summary sd SD 3.028 Message i 1 more variable: warning --- Code bind_ard(ard_attributes(mtcars, variables = mpg), ard_summary(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_fun 1 mpg attribut… label Variable… mpg 2 mpg attribut… class Variable… numeric NULL 3 mpg summary mean Mean 20.091 1 4 mpg summary 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.md0000644000176200001440000001133415051153341022370 0ustar liggesusers# print_ard_conditions() works Code print_ard_conditions(ard_summary(ADSL, variables = AGE)) --- Code print_ard_conditions(ard_summary(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_summary(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_summary(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_summary(ADSL, variables = AGE, statistic = ~ list(err_fn = function( x) stop("'tis an error"))) print_ard_conditions(ard) }) tbl_summary() Message The following errors were returned during `tbl_summary()`: x For variable `AGE` and "err_fn" statistic: 'tis an error # print_ard_conditions(condition_type) Code print_ard_conditions(ard_summary(ADSL, variables = AGE, statistic = ~ list( mean_warning = function(x) { warning("warn1") warning("warn2") mean(x) })), condition_type = "identity") Message The following warnings were returned during `print_ard_conditions()`: Condition Warning: ! For variable `AGE` and "mean_warning" statistic: warn1 Warning: ! For variable `AGE` and "mean_warning" statistic: warn2 --- Code print_ard_conditions(ard_summary(ADSL, variables = AGE, statistic = ~ list( mean = function(x) mean(x), err_fn = function(x) stop("'tis an error"))), condition_type = "identity") Message The following errors were returned during `print_ard_conditions()`: Condition Error in `print_ard_conditions()`: x For variable `AGE` and "err_fn" statistic: 'tis an error # print_ard_conditions() no error when 'error'/'warning' columns not present Code print_ard_conditions(dplyr::select(ard_summary(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.md0000644000176200001440000000120615051153342022010 0ustar liggesusers# rename_ard_columns(columns) messsaging Code rename_ard_columns(ard_tabulate(ADSL, by = ARM, variables = AGEGR1), columns = all_ard_groups()) Condition Error in `rename_ard_columns()`: ! The `column` argument may only select columns using `all_ard_groups("names")` and `all_ard_variables("names")` i Column "group1_level" is not a valid selection. --- Code rename_ard_columns(ard_tabulate(dplyr::rename(ADSL, stat = AGEGR1), by = ARM, variables = stat)) Condition Error in `rename_ard_columns()`: ! New column name(s) "stat" cannot be added, because they are already present. cards/tests/testthat/_snaps/rename_ard_groups.md0000644000176200001440000000216315051153343021653 0ustar liggesusers# rename_ard_groups_shift() Code dplyr::select(rename_ard_groups_shift(ard_summary(ADSL, variables = AGE, by = c( SEX, ARM)), shift = 1L), all_ard_groups()) %>% 1L[] Message {cards} data frame: 1 x 4 Output group2 group2_level group3 group3_level 1 SEX F ARM Placebo # rename_ard_groups_shift() messaging Code dplyr::select(rename_ard_groups_shift(ard_summary(ADSL, variables = AGE, by = c( SEX, ARM)), shift = -1L), all_ard_groups()) %>% 1L[] Message There are now non-standard group column names: "group0" and "group0_level". i Is this the shift you had planned? {cards} data frame: 1 x 4 Output group0 group0_level group1 group1_level 1 SEX F ARM Placebo # rename_ard_groups_reverse() Code dplyr::select(rename_ard_groups_reverse(ard_summary(ADSL, variables = AGE, by = c( SEX, ARM))), all_ard_groups()) %>% 1L[] Message {cards} data frame: 1 x 4 Output group1 group1_level group2 group2_level 1 ARM Placebo SEX F cards/tests/testthat/_snaps/as_card.md0000644000176200001440000000075015051153330017547 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.md0000644000176200001440000001021215051153320020077 0ustar liggesusers# ard_stack() messaging Code head(ard_stack(data = mtcars, ard_summary(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_fun 1 mpg summary N N 32 0 Message i 2 more variables: warning, error --- Code ard_stack(ADSL, by = "ARM", ard_summary(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_summary <- ard_summary ard_stack(data = mtcars, .by = am, complex_call$ard_summary(variables = "mpg"), ) Condition Error in `ard_stack()`: ! `cards::ard_stack()` works with simple calls (`?rlang::call_name()`) and `complex_call$ard_summary(variables = "mpg")` is not simple. # ard_stack(.by) messaging Code dplyr::filter(ard_stack(mtcars2, ard_summary(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_fun, warning, error --- Code dplyr::filter(ard_stack(mtcars3, ard_summary(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_fun, warning, error cards/tests/testthat/_snaps/tidy_as_ard.md0000644000176200001440000001502715051153350020442 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_fun 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_fun 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/apply_fmt_fun.md0000644000176200001440000000543015051153306021021 0ustar liggesusers# apply_fmt_fun() error messaging Code apply_fmt_fun(letters) Condition Error in `apply_fmt_fun()`: ! The `x` argument must be class , not a character vector. --- Code apply_fmt_fun(dplyr::mutate(ard_fmt_checks, fmt_fun = list("xoxo", "xoxo"))) Condition Error in `dplyr::mutate()`: i In argument: `stat_fmt = pmap(...)`. Caused by error in `apply_fmt_fun()`: ! 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_fun` 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_fun(dplyr::mutate(ard_fmt_checks, fmt_fun = list(1L, -1L))) Condition Error in `dplyr::mutate()`: i In argument: `stat_fmt = pmap(...)`. Caused by error in `apply_fmt_fun()`: ! 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_fun` 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_fun()` for details. --- Code as.data.frame(apply_fmt_fun(dplyr::mutate(ard_fmt_checks, stat = lapply(stat, function(x) x * 1000), fmt_fun = list("xx", "xx")))) Output variable context stat_name stat_label stat stat_fmt fmt_fun warning error 1 mpg summary mean Mean 20090.62 20091 xx NULL NULL 2 mpg summary sd SD 6026.948 6027 xx NULL NULL # apply_fmt_fun(replace) Code apply_fmt_fun(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_fun, warning, error --- Code apply_fmt_fun(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_fun, warning, error cards/tests/testthat/_snaps/options.md0000644000176200001440000000066015051153340017647 0ustar liggesusers# options(cards.round_type) messaging Code withr::with_options(list(cards.round_type = "NOT-CORRECT"), ard_tabulate( data.frame(x = c(T, F)), variables = everything(), statistic = ~"p")) Condition Error in `dplyr::mutate()`: i In argument: `fmt_fun = pmap(...)`. Caused by error in `ard_tabulate()`: ! The `cards.round_type` option must be one of "round-half-up" and "round-to-even". cards/tests/testthat/_snaps/get_ard_statistics.md0000644000176200001440000000133215051153340022030 0ustar liggesusers# get_ard_statistics() works Code get_ard_statistics(ard, group1_level %in% "Placebo", variable_level %in% "65-80") Output $n [1] 42 $N [1] 86 $p [1] 0.4883721 --- Code get_ard_statistics(ard, group1_level %in% "Placebo", variable_level %in% "65-80", .attributes = c("warning", "error")) Output $n [1] 42 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" $N [1] 86 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" $p [1] 0.4883721 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" cards/tests/testthat/_snaps/sort_ard_hierarchical.md0000644000176200001440000001544415051153351022477 0ustar liggesusers# sort_ard_hierarchical() works Code print(dplyr::select(ard_s, all_ard_groups(), all_ard_variables()), n = 50) Message {cards} data frame: 234 x 8 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level 1 TRTA Placebo 2 TRTA Placebo 3 TRTA Placebo 4 TRTA Xanomeli… 5 TRTA Xanomeli… 6 TRTA Xanomeli… 7 TRTA Xanomeli… 8 TRTA Xanomeli… 9 TRTA Xanomeli… 10 TRTA Placebo ..ard_hierarchical_overall.. TRUE 11 TRTA Placebo ..ard_hierarchical_overall.. TRUE 12 TRTA Placebo ..ard_hierarchical_overall.. TRUE 13 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 14 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 15 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 16 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 17 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 18 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 19 TRTA Placebo SEX F 20 TRTA Placebo SEX F 21 TRTA Placebo SEX F 22 TRTA Xanomeli… SEX F 23 TRTA Xanomeli… SEX F 24 TRTA Xanomeli… SEX F 25 TRTA Xanomeli… SEX F 26 TRTA Xanomeli… SEX F 27 TRTA Xanomeli… SEX F 28 TRTA Placebo SEX F RACE WHITE 29 TRTA Placebo SEX F RACE WHITE 30 TRTA Placebo SEX F RACE WHITE 31 TRTA Xanomeli… SEX F RACE WHITE 32 TRTA Xanomeli… SEX F RACE WHITE 33 TRTA Xanomeli… SEX F RACE WHITE 34 TRTA Xanomeli… SEX F RACE WHITE 35 TRTA Xanomeli… SEX F RACE WHITE 36 TRTA Xanomeli… SEX F RACE WHITE 37 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 38 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 39 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 40 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 41 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 42 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 43 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 44 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 45 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 46 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 47 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 48 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 49 TRTA Xanomeli… SEX F RACE WHITE AETERM ERYTHEMA 50 TRTA Xanomeli… SEX F RACE WHITE AETERM ERYTHEMA Message i 184 more rows i Use `print(n = ...)` to see more rows # sort_ard_hierarchical() error messaging works Code sort_ard_hierarchical(ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1")) Condition Error in `sort_ard_hierarchical()`: ! Sorting is only available for stacked hierarchical ARDs created using `ard_stack_hierarchical()` or `ard_stack_hierarchical_count()`. --- Code sort_ard_hierarchical(ard, sort = "no_sorting") Condition Error in `sort_ard_hierarchical()`: ! Sorting type must be either "descending" or "alphanumeric" for all variables. --- Code sort_ard_hierarchical(ard) Condition Error in `sort_ard_hierarchical()`: ! If `sort='descending'` for any variables then either "n" or "p" must be present in `x` for each of these specified variables in order to calculate the count sums used for sorting. cards/tests/testthat/_snaps/ard_missing.md0000644000176200001440000000606515051153306020462 0ustar liggesusers# ard_missing() works Code as.data.frame(dplyr::select(ard, -"fmt_fun")) 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.md0000644000176200001440000002215715051153317022616 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 = ADSL) 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(ADSL, 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 = ADSL) 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 = ADSL) 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 = ADSL) 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 = ADSL, 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 = ADSL, 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 = ADSL, overall = TRUE), !group1 %in% "TRTA" & !group2 %in% "TRTA" & !group3 %in% "TRTA" & !variable %in% "TRTA") Message {cards} data frame: 18 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level stat_name stat_label stat 1 AESEV MILD AESOC GENERAL … n n 4 2 AESEV MODERATE AESOC GENERAL … n n 0 3 AESOC GENERAL … n n 4 4 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 5 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 6 AESOC GENERAL … AEDECOD APPLICAT… n n 2 7 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 8 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 9 AESOC GENERAL … AEDECOD APPLICAT… n n 2 10 AESEV MILD AESOC SKIN AND… n n 1 11 AESEV MODERATE AESOC SKIN AND… n n 1 12 AESOC SKIN AND… n n 2 13 AESEV MILD AESOC SKIN AND… AEDECOD ERYTHEMA n n 1 14 AESEV MODERATE AESOC SKIN AND… AEDECOD ERYTHEMA n n 0 15 AESOC SKIN AND… AEDECOD ERYTHEMA n n 1 16 AESEV MILD AESOC SKIN AND… AEDECOD PRURITUS… n n 0 17 AESEV MODERATE AESOC SKIN AND… AEDECOD PRURITUS… n n 1 18 AESOC SKIN AND… AEDECOD PRURITUS… n n 1 Message i 4 more variables: context, fmt_fun, 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 = ADSL, 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 --- Code dplyr::filter(ard_stack_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL, overall = TRUE, over_variables = TRUE), !group1 %in% "TRTA" & !group2 %in% "TRTA" & !group3 %in% "TRTA" & !variable %in% "TRTA") Message {cards} data frame: 21 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level stat_name stat_label stat 1 AESEV MILD ..ard_hierarchical_overall.. TRUE n n 5 2 AESEV MODERATE ..ard_hierarchical_overall.. TRUE n n 1 3 ..ard_hierarchical_overall.. TRUE n n 6 4 AESEV MILD AESOC GENERAL … n n 4 5 AESEV MODERATE AESOC GENERAL … n n 0 6 AESOC GENERAL … n n 4 7 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 8 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 9 AESOC GENERAL … AEDECOD APPLICAT… n n 2 10 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 Message i 11 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fun, warning, error cards/tests/testthat/_snaps/ard_tabulate.md0000644000176200001440000002072515051153327020614 0ustar liggesusers# ard_tabulate() univariate Code class(ard_cat_uni) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_tabulate() univariate & specified denomiator Code class(ard_cat_new_denom) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_tabulate(fmt_fun) argument works Code as.data.frame(dplyr::select(apply_fmt_fun(ard_tabulate(mtcars, variables = "am", fmt_fun = 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_fun(ard_tabulate(mtcars, variables = c( "am", "vs"), fmt_fun = 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_tabulate() with strata and by arguments Code ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1", denominator = dplyr::filter( ADSL, ARM %in% "Placebo")) Condition Error in `ard_tabulate()`: ! The following `by/strata` combinations are missing from the `denominator` data frame: ARM (Xanomeline High Dose) and ARM (Xanomeline Low Dose). # ard_tabulate(stat_label) argument works Code unique(dplyr::select(dplyr::filter(as.data.frame(ard_tabulate(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_tabulate(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_tabulate(data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = AGEGR1 ~ list(c("n", "p") ~ "n (pct)"))), stat_name %in% c("n", "p")), variable, stat_name, stat_label)) Output variable stat_name stat_label 1 AGEGR1 n n (pct) 2 AGEGR1 p n (pct) 7 SEX n n 8 SEX p % # ard_tabulate(denominator='row') works Code as.data.frame(dplyr::select(apply_fmt_fun(ard_with_args), -fmt_fun, -warning, -error)) Output group1 group1_level variable variable_level context stat_name stat_label stat stat_fmt 1 ARM Placebo AGEGR1 65-80 tabulate n n 42 42.00 2 ARM Placebo AGEGR1 65-80 tabulate N N 144 144 3 ARM Placebo AGEGR1 <65 tabulate n n 14 14.00 4 ARM Placebo AGEGR1 <65 tabulate N N 33 33 5 ARM Placebo AGEGR1 >80 tabulate n n 30 30.00 6 ARM Placebo AGEGR1 >80 tabulate N N 77 77 7 ARM Xanomeline High Dose AGEGR1 65-80 tabulate n n 55 55.00 8 ARM Xanomeline High Dose AGEGR1 65-80 tabulate N N 144 144 9 ARM Xanomeline High Dose AGEGR1 <65 tabulate n n 11 11.00 10 ARM Xanomeline High Dose AGEGR1 <65 tabulate N N 33 33 11 ARM Xanomeline High Dose AGEGR1 >80 tabulate n n 18 18.00 12 ARM Xanomeline High Dose AGEGR1 >80 tabulate N N 77 77 13 ARM Xanomeline Low Dose AGEGR1 65-80 tabulate n n 47 47.00 14 ARM Xanomeline Low Dose AGEGR1 65-80 tabulate N N 144 144 15 ARM Xanomeline Low Dose AGEGR1 <65 tabulate n n 8 8.00 16 ARM Xanomeline Low Dose AGEGR1 <65 tabulate N N 33 33 17 ARM Xanomeline Low Dose AGEGR1 >80 tabulate n n 29 29.00 18 ARM Xanomeline Low Dose AGEGR1 >80 tabulate N N 77 77 # ard_tabulate(denominator=) works Code ard_tabulate(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_tabulate()`: ! Specified counts in column "'...ard_N...'" are not unique in the `denominator` argument across the `by` and `strata` columns. --- Code ard_tabulate(ADSL, by = ARM, variables = AGEGR1, denominator = data.frame(ARM = "Placebo", ...ard_N... = 86)) Condition Error in `ard_tabulate()`: ! The following `by/strata` combinations are missing from the `denominator` data frame: ARM (Xanomeline High Dose) and ARM (Xanomeline Low Dose). # ard_tabulate() and all NA columns Code ard_tabulate(dplyr::mutate(ADSL, AGEGR1 = NA_character_), variables = AGEGR1) Condition Error in `ard_tabulate()`: ! Column "AGEGR1" is all missing and cannot by tabulated. i Only columns of class and can be tabulated when all values are missing. # ard_tabulate(by) messages about protected names Code ard_tabulate(mtcars2, by = variable, variables = gear) Condition Error in `ard_tabulate()`: ! The `by` argument cannot include variables named "variable" and "variable_level". --- Code ard_tabulate(mtcars2, by = variable, variables = by) Condition Error in `ard_tabulate()`: ! The `by` argument cannot include variables named "variable" and "variable_level". # ard_tabulate() errors with incomplete factor columns Code ard_tabulate(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), variables = am) Condition Error in `ard_tabulate()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_tabulate(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), variables = am) Condition Error in `ard_tabulate()`: ! Factors with NA levels are not allowed, which are present in column "am". # ard_tabulate() with cumulative counts messaging Code ard_tabulate(ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c( "n", "p", "n_cum", "p_cum"), denominator = NULL) Condition Error in `ard_tabulate()`: ! The `denominator` argument must be one of "column" and "row" when cumulative statistics "n_cum" or "p_cum" are specified, which were requested for variable `AGEGR1`. cards/tests/testthat/_snaps/ard_summary.md0000644000176200001440000001276115051153346020512 0ustar liggesusers# ard_summary() works Code class(ard_test) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_summary(fmt_fun) argument works Code as.data.frame(dplyr::select(apply_fmt_fun(ard_summary(ADSL, variables = "AGE", statistic = list(AGE = continuous_summary_fns(c("N", "mean", "median"))), fmt_fun = 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_fun(ard_summary(ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns("mean"), fmt_fun = 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_fun(ard_summary(ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns(c("mean", "sd")), fmt_fun = ~ 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_summary() messaging Code ard_summary(mtcars, variables = "mpg", statistic = ~ list(mean = "this is a string")) Condition Error in `ard_summary()`: ! Error in the argument `statistic` for variable "mpg". i Value must be a named list of functions. --- Code ard_summary(letters, variables = "mpg") Condition Error in `UseMethod()`: ! no applicable method for 'ard_summary' applied to an object of class "character" --- Code ard_summary(mtcars) Condition Error in `ard_summary()`: ! The `variables` argument cannot be missing. # ard_summary(stat_label) argument works Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_summary(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_summary(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_summary(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_summary() 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_fun 1 DISONSDT summary min Min 1998-06-… 2 DISONSDT summary max Max 2013-09-… 3 DISONSDT summary sd SD 878.558 1 Message i 2 more variables: warning, error # ard_summary() works with non-syntactic names Code as.data.frame(ard_summary(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_fun warning 1 BMI base summary mean lbl Test lbl NULL .Primitive("as.character") NULL 2 Age summary mean lbl Test lbl NULL .Primitive("as.character") NULL error 1 There was an error calculating the mean. 2 There was an error calculating the mean. # ard_summary() errors with incomplete factor columns Code ard_summary(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), by = am, variables = mpg) Condition Error in `ard_summary()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_summary(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), by = am, variables = mpg) Condition Error in `ard_summary()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/eval_capture_conditions.md0000644000176200001440000000473415051153331023065 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.md0000644000176200001440000001002215051153351020257 0ustar liggesusers# update_ard_fmt_fun() Code update_ard_fmt_fun(ard_summary(ADSL, variables = AGE), stat_names = c("mean", "sd"), fmt_fun = -8L) Condition Error in `update_ard_fmt_fun()`: ! The value in `fmt_fun` 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_fun()` for details. # update_ard_fmt_fun(filter) Code apply_fmt_fun(update_ard_fmt_fun(ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fun = 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_fun, warning, error # update_ard_fmt_fun(filter) messaging Code update_ard_fmt_fun(ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fun = 8L, filter = group99999999_level == "Placebo") Condition Error in `update_ard_fmt_fun()`: ! There was an error evaluating the `filter` argument. See below: x object 'group99999999_level' not found --- Code update_ard_fmt_fun(ard_summary(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fun = 8L, filter = c(TRUE, FALSE)) Condition Error in `update_ard_fmt_fun()`: ! 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_summary(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_fun, warning, error # update_ard_stat_label(filter) messaging Code update_ard_stat_label(ard_summary(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_summary(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.md0000644000176200001440000000070315051153331022175 0ustar liggesusers# check_ard_structure() works Code check_ard_structure(structure(dplyr::select(dplyr::mutate(ard_summary(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.md0000644000176200001440000003450215113466401020444 0ustar liggesusers# shuffle/trim works Code ard_simple_shuffled Output variable context stat_name stat_label stat fmt_fun warning error 1 AGE summary N N 254.000000 0 NULL NULL 2 AGE summary mean Mean 75.086614 1 NULL NULL 3 AGE summary sd SD 8.246234 1 NULL NULL 4 AGE summary median Median 77.000000 1 NULL NULL 5 AGE summary p25 Q1 70.000000 1 NULL NULL 6 AGE summary p75 Q3 81.000000 1 NULL NULL 7 AGE summary min Min 51.000000 1 NULL NULL 8 AGE summary max Max 89.000000 1 NULL NULL --- Code ard_shuffled[1:5, ] Output ARM variable variable_level context stat_name stat_label stat 1 Placebo ARM Placebo tabulate n n 86.0000000 2 Placebo ARM Placebo tabulate N N 254.0000000 3 Placebo ARM Placebo tabulate p % 0.3385827 4 Xanomeline High Dose ARM Xanomeline High Dose tabulate n n 84.0000000 5 Xanomeline High Dose ARM Xanomeline High Dose tabulate N N 254.0000000 --- Code ard_shuff_trim[1:5, ] Output ARM variable variable_level context stat_name stat_label stat 1 Placebo ARM Placebo tabulate n n 86.0000000 2 Placebo ARM Placebo tabulate N N 254.0000000 3 Placebo ARM Placebo tabulate p % 0.3385827 4 Xanomeline High Dose ARM Xanomeline High Dose tabulate n n 84.0000000 5 Xanomeline High Dose ARM Xanomeline High Dose tabulate N N 254.0000000 # shuffle_ard notifies user about warnings/errors before dropping Code shuffle_ard(ard_summary(ADSL, variables = AGEGR1)) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Message "warning" column contains messages that will be removed. Output # A tibble: 8 x 5 variable context stat_name stat_label stat 1 AGEGR1 summary N N 254 2 AGEGR1 summary mean Mean 3 AGEGR1 summary sd SD 4 AGEGR1 summary median Median 5 AGEGR1 summary p25 Q1 65-80 6 AGEGR1 summary p75 Q3 >80 7 AGEGR1 summary min Min 65-80 8 AGEGR1 summary max Max >80 # shuffle_ard fills missing group levels if the group is meaningful Code shuffle_ard(dplyr::filter(bind_ard(ard_summary(ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05))), dplyr::row_number() <= 5L)) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Output # A tibble: 4 x 6 ARM variable context stat_name stat_label stat 1 Placebo AGE summary mean Mean 75.2 2 Xanomeline High Dose AGE summary mean Mean 74.4 3 Xanomeline Low Dose AGE summary mean Mean 75.7 4 Overall ARM AGE p p 0.05 --- Code shuffle_ard(dplyr::filter(bind_ard(ard_summary(ADSL, variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05))), dplyr::row_number() <= 5L)) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Output # A tibble: 2 x 6 ARM variable context stat_name stat_label stat 1 AGE summary mean Mean 75.1 2 Overall ARM AGE p p 0.05 --- Code as.data.frame(shuffle_ard(bind_ard(dplyr::slice(ard_tabulate(ADSL, by = ARM, variables = AGEGR1), 1), dplyr::slice(ard_tabulate(ADSL, variables = AGEGR1), 1), dplyr::slice(ard_summary(ADSL, by = SEX, variables = AGE), 1), dplyr::slice(ard_summary(ADSL, variables = AGE), 1)))) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Output ARM SEX variable variable_level context stat_name stat_label stat 1 Placebo AGEGR1 65-80 tabulate n n 42 2 Overall ARM AGEGR1 65-80 tabulate n n 144 3 Overall SEX AGE summary N N 254 4 F AGE summary N N 143 --- Code shuffle_ard(bind_ard(dplyr::slice(ard_tabulate(ADSL, by = c(ARM, SEX), variables = AGEGR1), 1), dplyr::slice(ard_tabulate(ADSL, by = SEX, variables = AGEGR1), 1), dplyr::slice(ard_tabulate(ADSL, variables = AGEGR1), 1))) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Output # A tibble: 3 x 8 ARM SEX variable variable_level context stat_name stat_label stat 1 Placebo F AGEGR1 65-80 tabulate n n 22 2 Overall ARM F AGEGR1 65-80 tabulate n n 78 3 Overall ARM Overall SEX AGEGR1 65-80 tabulate n n 144 --- Code shuffle_ard(bind_ard(ard_summary(adsl_new, variables = "AGE", statistic = ~ continuous_summary_fns("mean")), ard_summary(adsl_new, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns( "mean")))) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Message i "Overall ARM" already exists in the `ARM` column. Using "Overall ARM.1". Output # A tibble: 4 x 6 ARM variable context stat_name stat_label stat 1 Overall ARM.1 AGE summary mean Mean 75.1 2 Overall ARM AGE summary mean Mean 75.2 3 Xanomeline High Dose AGE summary mean Mean 74.4 4 Xanomeline Low Dose AGE summary mean Mean 75.7 # shuffle_ard fills missing group levels if the group is meaningful for cardx output Code as.data.frame(shuffle_ard(ard_cardx)) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Output ARM SEX variable context stat_name stat_label stat 1 Overall ARM AGEGR1 stats_chisq_test statistic X-squared Statistic 5.07944167 2 Overall ARM AGEGR1 stats_chisq_test p.value p-value 0.07888842 3 Overall SEX AGEGR1 stats_chisq_test statistic X-squared Statistic 1.03944200 4 Overall SEX AGEGR1 stats_chisq_test p.value p-value 0.59468644 # shuffle_ard() fills grouping columns with `Overall ` or `Any ` Code dplyr::filter(shuffled_ard, variable == "..ard_total_n..") Output # A tibble: 1 x 8 TRTA AESOC variable variable_level context stat_name stat_label stat 1 Overall TRTA ..ard_to~ total_n N N 170 --- Code dplyr::filter(shuffled_ard, variable == "..ard_hierarchical_overall..") Output # A tibble: 9 x 8 TRTA AESOC variable variable_level context stat_name stat_label stat 1 Overall TR~ Any ~ ..ard_h~ TRUE hierar~ n n 44 2 Overall TR~ Any ~ ..ard_h~ TRUE hierar~ N N 170 3 Overall TR~ Any ~ ..ard_h~ TRUE hierar~ p % 0.259 4 Placebo Any ~ ..ard_h~ TRUE hierar~ n n 17 5 Placebo Any ~ ..ard_h~ TRUE hierar~ N N 86 6 Placebo Any ~ ..ard_h~ TRUE hierar~ p % 0.198 7 Xanomeline~ Any ~ ..ard_h~ TRUE hierar~ n n 27 8 Xanomeline~ Any ~ ..ard_h~ TRUE hierar~ N N 84 9 Xanomeline~ Any ~ ..ard_h~ TRUE hierar~ p % 0.321 # shuffle_ard() fills with multiple `by` columns Code dplyr::filter(shuffled_ard, variable == "..ard_total_n..") Output # A tibble: 1 x 9 TRTA AESOC SEX variable variable_level context stat_name stat_label stat 1 Overal~ ..ard_t~ total_n N N 170 --- Code dplyr::filter(shuffled_ard, variable == "..ard_hierarchical_overall..") Output # A tibble: 15 x 9 TRTA AESOC SEX variable variable_level context stat_name stat_label 1 Overall TRTA Any ~ Over~ ..ard_h~ TRUE hierar~ n n 2 Overall TRTA Any ~ Over~ ..ard_h~ TRUE hierar~ N N 3 Overall TRTA Any ~ Over~ ..ard_h~ TRUE hierar~ p % 4 Placebo Any ~ F ..ard_h~ TRUE hierar~ n n 5 Placebo Any ~ F ..ard_h~ TRUE hierar~ N N 6 Placebo Any ~ F ..ard_h~ TRUE hierar~ p % 7 Placebo Any ~ M ..ard_h~ TRUE hierar~ n n 8 Placebo Any ~ M ..ard_h~ TRUE hierar~ N N 9 Placebo Any ~ M ..ard_h~ TRUE hierar~ p % 10 Xanomeline ~ Any ~ F ..ard_h~ TRUE hierar~ n n 11 Xanomeline ~ Any ~ F ..ard_h~ TRUE hierar~ N N 12 Xanomeline ~ Any ~ F ..ard_h~ TRUE hierar~ p % 13 Xanomeline ~ Any ~ M ..ard_h~ TRUE hierar~ n n 14 Xanomeline ~ Any ~ M ..ard_h~ TRUE hierar~ N N 15 Xanomeline ~ Any ~ M ..ard_h~ TRUE hierar~ p % # i 1 more variable: stat # shuffle_ard() messages about 'Overall ' or 'Any ' Code dplyr::mutate(test_data, dplyr::across(ARM:TRTA, cards:::.derive_overall_labels)) Message i "Overall ARM" already exists in the `ARM` column. Using "Overall ARM.1". Output # A tibble: 5 x 2 ARM TRTA 1 Overall ARM.1 2 Overall ARM 3 Any TRTA 4 BB C 5 C --- Code shuffled_ard <- shuffle_ard(ard) Condition Warning: `shuffle_ard()` was deprecated in cards 0.8.0. i Please use `tfrmt::shuffle_card()` instead. Message i "Overall TRTA" already exists in the `TRTA` column. Using "Overall TRTA.1". i "Any AESOC" already exists in the `AESOC` column. Using"Any AESOC.1". --- Code dplyr::filter(shuffled_ard, variable == "..ard_total_n..") Output # A tibble: 1 x 9 TRTA AESOC SEX variable variable_level context stat_name stat_label stat 1 Overal~ ..ard_t~ total_n N N 170 --- Code dplyr::filter(shuffled_ard, variable == "..ard_hierarchical_overall..") Output # A tibble: 15 x 9 TRTA AESOC SEX variable variable_level context stat_name stat_label 1 Overall TRT~ Any ~ Over~ ..ard_h~ TRUE hierar~ n n 2 Overall TRT~ Any ~ Over~ ..ard_h~ TRUE hierar~ N N 3 Overall TRT~ Any ~ Over~ ..ard_h~ TRUE hierar~ p % 4 Overall TRTA Any ~ F ..ard_h~ TRUE hierar~ n n 5 Overall TRTA Any ~ F ..ard_h~ TRUE hierar~ N N 6 Overall TRTA Any ~ F ..ard_h~ TRUE hierar~ p % 7 Overall TRTA Any ~ M ..ard_h~ TRUE hierar~ n n 8 Overall TRTA Any ~ M ..ard_h~ TRUE hierar~ N N 9 Overall TRTA Any ~ M ..ard_h~ TRUE hierar~ p % 10 Placebo Any ~ F ..ard_h~ TRUE hierar~ n n 11 Placebo Any ~ F ..ard_h~ TRUE hierar~ N N 12 Placebo Any ~ F ..ard_h~ TRUE hierar~ p % 13 Placebo Any ~ M ..ard_h~ TRUE hierar~ n n 14 Placebo Any ~ M ..ard_h~ TRUE hierar~ N N 15 Placebo Any ~ M ..ard_h~ TRUE hierar~ p % # i 1 more variable: stat cards/tests/testthat/_snaps/mock.md0000644000176200001440000001607515051153340017114 0ustar liggesusers# mock_categorical() Code apply_fmt_fun(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_fun, 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_fun(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_fun, 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_fun(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_fun, 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_fun(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_fun, 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_fun 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_fun(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_fun, warning, error cards/tests/testthat/_snaps/ard_hierarchical.md0000644000176200001440000000671115051153313021423 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 = ADSL, id = USUBJID), 1L) Condition Warning: Duplicate rows found in data for the "USUBJID" column. i Percentages/Denominators are not correct. Message {cards} data frame: 1 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable 1 TRTA Placebo AESEV MILD AESOC CARDIAC … AEDECOD variable_level stat_name stat_label stat 1 ATRIAL F… n n 0 Message i 4 more variables: context, fmt_fun, warning, error --- Code head(ard_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL, id = c(USUBJID, SITEID)), 1L) Condition Warning: Duplicate rows found in data for the "USUBJID" and "SITEID" columns. i Percentages/Denominators are not correct. Message {cards} data frame: 1 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable 1 TRTA Placebo AESEV MILD AESOC CARDIAC … AEDECOD variable_level stat_name stat_label stat 1 ATRIAL F… n n 0 Message i 4 more variables: context, fmt_fun, 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/ard_identity.md0000644000176200001440000000027015051153306020632 0ustar liggesusers# ard_identity() messaging Code ard_identity(x = as.list(letters), variable = "AGE") Condition Error in `ard_identity()`: ! The `x` argument must be named. cards/tests/testthat/_snaps/ard_total_n.md0000644000176200001440000000064215051153330020441 0ustar liggesusers# ard_total_n() works Code as.data.frame(ard_total_n(ADSL)) Output variable context stat_name stat_label stat fmt_fun 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.md0000644000176200001440000000347215051153310020626 0ustar liggesusers# ard_pairwise(variable) messaging Code ard_pairwise(ADSL, variable = c(ARM, AGEGR1), .f = function(df) ard_mvsummary( 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_mvsummary(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", ..., "MMSETOT", and "TRTA" # 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_mvsummary(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_mvsummary(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.md0000644000176200001440000000207215051153306021171 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_fun 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_mvsummary.md0000644000176200001440000000203715051153307021045 0ustar liggesusers# ard_mvsummary() messaging Code ard_mvsummary(ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = list( AGE = list(mean = function(x, ...) mean(x)))) Condition Error in `ard_mvsummary()`: ! The following columns do not have `statistic` defined: "BMIBL". # ard_mvsummary() errors with incorrect factor columns Code ard_mvsummary(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_mvsummary()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_mvsummary(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_mvsummary()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/ard_tabulate_value.md0000644000176200001440000000534415051153321022002 0ustar liggesusers# ard_tabulate_value() works Code class(ard_dich) Output [1] "card" "tbl_df" "tbl" "data.frame" --- Code as.data.frame(dplyr::select(ard_dich, -c(fmt_fun, warning, error))) Output variable variable_level context stat_name stat_label stat 1 cyl 4 tabulate_value n n 11 2 cyl 4 tabulate_value N N 32 3 cyl 4 tabulate_value p % 0.34375 4 am TRUE tabulate_value n n 13 5 am TRUE tabulate_value N N 32 6 am TRUE tabulate_value p % 0.40625 7 gear 3 tabulate_value n n 5 8 gear 3 tabulate_value N N 32 9 gear 3 tabulate_value p % 0.15625 # ard_tabulate_value() errors are correct Code ard_tabulate_value(mtcars, variables = c("cyl", "am", "gear"), value = list( cyl = letters)) Condition Error in `ard_tabulate_value()`: ! Error in argument `value` for variable "cyl". i The value must be one of 4, 6, and 8. --- Code ard_tabulate_value(iris, variables = everything(), value = list(Species = "not_a_species")) Condition Error in `ard_tabulate_value()`: ! 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_tabulate_value(mtcars, variables = c("cyl", "am", "gear"), value = list( cyl = 100)) Condition Error in `ard_tabulate_value()`: ! 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_tabulate_value() errors with incomplete factor columns Code ard_tabulate_value(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), variables = c(cyl, vs), by = am, value = list(cyl = 4)) Condition Error in `ard_tabulate_value()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_tabulate_value(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_tabulate_value()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/as_nested_list.md0000644000176200001440000003145215051153330021156 0ustar liggesusers# as_nested_list() works Code as_nested_list(ard_summary(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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" $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] "summary" cards/tests/testthat/_snaps/process_selectors.md0000644000176200001440000000111315051153342021711 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-ard_tabulate_value.R0000644000176200001440000000564015051141622021275 0ustar liggesuserstest_that("ard_tabulate_value() works", { expect_error( ard_dich <- ard_tabulate_value( 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) ) ## line added to fix failing snapshot test on ubuntu-latest (devel) ## TODO: resolve after release of R-devel skip_if_not(package_version(paste(R.version$major, R.version$minor, sep = ".")) <= package_version("4.5.0")) expect_snapshot( ard_dich |> dplyr::select(-c(fmt_fun, warning, error)) |> as.data.frame() ) }) test_that("ard_tabulate_value() errors are correct", { expect_snapshot( ard_tabulate_value( mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = letters) ), error = TRUE ) expect_snapshot( ard_tabulate_value( iris, variables = everything(), value = list(Species = "not_a_species") ), error = TRUE ) expect_snapshot( ard_tabulate_value( mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = 100) ), error = TRUE ) }) test_that("ard_tabulate_value() with grouped data works", { expect_equal( mtcars |> dplyr::group_by(vs) |> ard_tabulate_value(variables = c(cyl, am), value = list(cyl = 4)), ard_tabulate_value( data = mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4) ) ) }) test_that("ard_tabulate_value() follows ard structure", { expect_silent( mtcars |> dplyr::group_by(vs) |> ard_tabulate_value(variables = c(cyl, am), value = list(cyl = 4)) |> check_ard_structure(method = FALSE) ) }) test_that("ard_tabulate_value() 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_tabulate_value( 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_tabulate_value( variables = c(cyl, am), value = list(cyl = 4) ) ) }) cards/tests/testthat/test-tidy_as_ard.R0000644000176200001440000000523415026331152017734 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.R0000644000176200001440000000656115026331344021222 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.R0000644000176200001440000004605015113466401022107 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 ) ) # 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 ), ignore_attr = TRUE ) # check AESOC match expect_equal( ard |> dplyr::filter(is.na(group1)) |> dplyr::select(-all_ard_group_n(1L)), ard_hierarchical( ADAE_small |> dplyr::slice_tail(n = 1L, by = c("USUBJID", "TRTA", "AESOC")), variables = AESOC, id = USUBJID, denominator = ADSL ), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical(variables) messaging removed obs", { # missing rows are removed expect_snapshot( ard <- ADAE_small |> dplyr::mutate(AESOC = ifelse(dplyr::row_number() == 1L, NA, AESOC)) |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = USUBJID, denominator = ADSL ) ) expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = USUBJID, by = TRTA, denominator = ADSL |> 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 ) ) # no id selected expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = starts_with("xxxxx"), denominator = ADSL ) ) }) 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 ) ) # check AEDECOD match ard_match <- ard_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD") ) expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical( ADAE_small |> dplyr::slice_tail(n = 1L, by = c("USUBJID", "TRTA", "AESOC")), variables = AESOC, by = TRTA, id = USUBJID, denominator = ADSL ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = c("AESOC"), include = c("AESOC") ) expect_equal( ard |> dplyr::filter(variable %in% "AESOC") |> dplyr::select(-all_ard_group_n(2L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # ARD with >2 `by` variables works expect_silent(expect_message( ard_stack_hierarchical( cards::ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, TRTEMFL, AESEV), id = USUBJID, denominator = ADSL ) )) }) 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 ) ) # no messaging if `id` values are present in multiple levels of the `by` variables expect_no_warning( suppressMessages( ard_stack_hierarchical( data = ADAE |> dplyr::bind_rows(ADAE |> dplyr::mutate(TRTA = "Total")), variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::bind_rows(ADSL |> dplyr::mutate(TRTA = "Total")), id = USUBJID ) ) ) }) 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 ) ) # check denominator only keeps "by" and "id" variables adsl_updated <- cards::ADSL |> dplyr::mutate( REGION = "Asia", COUNTRY = sample(c("CHN", "JPN", "PAK"), size = dplyr::n(), replace = TRUE) ) expect_equal( cards::ard_stack_hierarchical( adsl_updated, by = "ARM", variable = c("REGION", "COUNTRY"), id = "USUBJID", denominator = adsl_updated ), cards::ard_stack_hierarchical( adsl_updated, by = "ARM", variable = c("REGION", "COUNTRY"), id = "USUBJID", denominator = adsl_updated[c("USUBJID", "ARM")] ), ignore_attr = TRUE, ignore_function_env = TRUE ) }) # 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 ), '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 ), 'Denominator set by.*"TRTA".*column in .*denominator.*data frame.' # styler: off ) # check the rates for AEDECOD are correct ard_match <- ADAE_small |> dplyr::arrange(USUBJID, TRTA, AESOC, AEDECOD, AESEV) |> dplyr::filter( .by = c(USUBJID, TRTA, AESOC, AEDECOD), dplyr::n() == dplyr::row_number() ) |> ard_hierarchical( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL ) |> tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = c("AESOC", "AEDECOD", "AESEV"), include = c("AESOC", "AEDECOD", "AESEV") ) expect_equal( ard |> dplyr::filter(variable == "AEDECOD"), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE, ignore_function_env = TRUE ) # check the rates for AESOC are correct ard_match <- ADAE_small |> dplyr::arrange(USUBJID, TRTA, AESOC, AESEV) |> dplyr::filter( .by = c(USUBJID, TRTA, AESOC), dplyr::n() == dplyr::row_number() ) |> ard_hierarchical( variables = AESOC, by = c(TRTA, AESEV), denominator = ADSL ) |> tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = c("AESOC", "AESEV"), include = c("AESOC", "AESEV") ) expect_equal( ard |> dplyr::filter(variable == "AESOC") |> rename_ard_columns(), ard_match |> sort_ard_hierarchical("alphanumeric") |> rename_ard_columns(), ignore_attr = TRUE, ignore_function_env = TRUE ) }) test_that("ard_stack_hierarchical(variables, include) messaging", { expect_snapshot( error = TRUE, ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), include = AESOC, by = TRTA, denominator = ADSL, id = USUBJID ) ) }) test_that("ard_stack_hierarchical(by, overall) messaging", { expect_snapshot( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), denominator = ADSL, id = USUBJID, overall = TRUE ) ) }) test_that("ard_stack_hierarchical(statistic)", { expect_equal( ard_stack_hierarchical( ADAE, variables = AESOC, denominator = ADSL, id = USUBJID, statistic = everything() ~ "p" ), ard_stack_hierarchical( ADAE, variables = AESOC, denominator = ADSL, id = USUBJID, statistic = everything() ~ c("n", "N", "p") ) |> dplyr::filter(stat_name %in% "p") ) }) test_that("ard_stack_hierarchical with shuffle", { # we expect it to work but with a warning messaged related to the deprecation # of the `shuffle` argument expect_error( ard_shuffled <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), id = USUBJID, denominator = ADSL, shuffle = TRUE ) ) }) # ard_stack_hierarchical_count() ----------------------------------------------- test_that("ard_stack_hierarchical_count(variables)", { # ensure that all nested variables appear in resulting ARD expect_silent( ard <- ard_stack_hierarchical_count( ADAE_small, variables = c(AESOC, AEDECOD) ) ) # check the number of rows is expected expect_equal( nrow(ard), length(unique(ADAE_small$AESOC)) + length(unique(ADAE_small$AEDECOD)) ) # check AEDECOD match ard_match <- ard_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD)) attr(ard_match, "args") <- list( by = NULL, variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD") ) expect_equal( ard |> dplyr::filter(!is.na(group1)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical_count(ADAE_small, variables = AESOC) attr(ard_match, "args") <- list( by = NULL, variables = "AESOC", include = "AESOC" ) expect_equal( ard |> dplyr::filter(is.na(group1)) |> dplyr::select(-all_ard_group_n(1L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(by)", { expect_silent( ard <- ard_stack_hierarchical_count( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA ) ) # check the number of rows is expected expect_equal( nrow(ard), (length(unique(ADAE_small$AESOC)) + length(unique(ADAE_small$AEDECOD))) * length(unique(ADAE_small$TRTA)) ) # check AEDECOD match ard_match <- ard_hierarchical_count( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD") ) expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical_count( ADAE_small, variables = AESOC, by = TRTA ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list( by = "TRTA", variables = "AESOC", include = "AESOC" ) expect_equal( ard |> dplyr::filter(is.na(group2)) |> dplyr::select(-all_ard_group_n(2L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(denominator) messaging", { # when the wrong type is passed to the argument expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = letters ) ) }) test_that("ard_stack_hierarchical_count(denominator) univariate tabulations", { # test that we get the expected univariate by variable tabulations expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL ) |> dplyr::filter(variable == "TRTA") |> dplyr::select(-all_missing_columns()), ard_tabulate(ADSL, variables = TRTA) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) # everything still works when the by variable includes vars not in the denom data frame expect_equal( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL ) |> dplyr::filter(variable == "TRTA") |> dplyr::select(-all_missing_columns()), ard_tabulate(ADSL, variables = TRTA) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) expect_true(nrow(dplyr::filter(ard, variable == "AESEV")) == 0L) }) test_that("ard_stack_hierarchical_count(denominator,total_n)", { # check N is correct when denom is a data frame expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), denominator = ADSL, total_n = TRUE ) |> dplyr::filter(variable == "..ard_total_n..") |> dplyr::select(-all_missing_columns()), ard_total_n(ADSL) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) # check N is correct when denom is an integer expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), denominator = nrow(ADSL), total_n = TRUE ) |> dplyr::filter(variable == "..ard_total_n..") |> dplyr::select(-all_missing_columns()), ard_total_n(ADSL) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(denominator,total_n) messaging", { # requesting total N without a denominator expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), total_n = TRUE ) ) }) test_that("ard_stack_hierarchical_count(overall, denominator) messaging", { # requesting overall without a data frame denominator expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, overall = TRUE ) ) }) test_that("ard_stack_hierarchical_count(overall)", { withr::local_options(list(width = 250)) # requesting overall without a data frame denominator expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, 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::select(-all_missing_columns()), ignore_attr = TRUE ) # when the `by` variable includes columns not in `denominator`, ensure we get two sets of overall (by=AESEV and by=NULL) # IF THIS EVER BREAKS BE VERY CAREFUL WE HAVE ALL 18 ROWS RETURNED!!! expect_snapshot({ ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL, 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, 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::filter(variable %in% "..ard_hierarchical_overall..") |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(overall,over_variables)", { withr::local_options(list(width = 250)) # 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, over_variables = TRUE, overall = TRUE ) |> dplyr::filter(variable == "..ard_hierarchical_overall..") |> dplyr::select(all_ard_groups(), "variable", "stat_name", "stat") |> as.data.frame() ) # both `overall=TRUE` and `over_variables=TRUE` work together with multiple `by` variables present expect_snapshot({ ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL, overall = TRUE, over_variables = TRUE ) |> dplyr::filter( !group1 %in% "TRTA" & !group2 %in% "TRTA" & !group3 %in% "TRTA" & !variable %in% "TRTA" ) }) }) 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, attributes = TRUE ) |> dplyr::filter(context %in% "attributes") |> dplyr::select(-all_missing_columns()), ADAE_small |> ard_attributes(variables = c(TRTA, AESOC, AEDECOD)) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical() by_stats argument", { # include by_stats expect_silent( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL, by_stats = TRUE ) ) expect_equal( ard |> dplyr::filter(variable == "TRTA") |> dplyr::select(-all_ard_groups()), ard_tabulate( data = ADSL, variables = TRTA ), ignore_attr = TRUE ) # no by_stats expect_silent( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL, by_stats = FALSE ) ) expect_equal( ard |> dplyr::filter(variable == "TRTA") |> nrow(), 0 ) }) cards/tests/testthat/test-sort_ard_hierarchical.R0000644000176200001440000002550315050667010021770 0ustar liggesusersskip_on_cran() ADAE_subset <- cards::ADAE |> dplyr::filter(AETERM %in% unique(cards::ADAE$AETERM)[1:5]) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE ) test_that("sort_ard_hierarchical() works", { withr::local_options(width = 200) expect_silent(ard_s <- sort_ard_hierarchical(ard)) expect_snapshot( ard_s |> dplyr::select(all_ard_groups(), all_ard_variables()) |> print(n = 50) ) # works after filtering expect_silent( ard_s <- ard |> filter_ard_hierarchical(n > 20) |> sort_ard_hierarchical() ) }) test_that("sort_ard_hierarchical(sort = 'descending') works", { # descending count (default) expect_silent(ard <- sort_ard_hierarchical(ard)) expect_equal( ard |> dplyr::filter(variable == "SEX") |> dplyr::select(variable_level) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c("F", "M") ) expect_equal( ard |> dplyr::filter(variable == "RACE") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "WHITE", "BLACK OR AFRICAN AMERICAN", "WHITE", "BLACK OR AFRICAN AMERICAN", "AMERICAN INDIAN OR ALASKA NATIVE" ) ) expect_equal( ard |> dplyr::filter(variable == "AETERM") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "APPLICATION SITE PRURITUS", "ERYTHEMA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "APPLICATION SITE PRURITUS", "APPLICATION SITE ERYTHEMA", "ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA" ) ) }) test_that("sort_ard_hierarchical(sort = 'alphanumeric') works", { expect_silent(ard <- sort_ard_hierarchical(ard, sort = "alphanumeric")) expect_equal( ard |> dplyr::filter(variable == "SEX") |> dplyr::select(variable_level) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), sort(c("F", "M")) ) expect_equal( ard |> dplyr::filter(variable == "RACE") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "BLACK OR AFRICAN AMERICAN", "WHITE", "AMERICAN INDIAN OR ALASKA NATIVE", "BLACK OR AFRICAN AMERICAN", "WHITE" ) ) expect_equal( ard |> dplyr::filter(variable == "AETERM") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA" ) ) }) test_that("sort_ard_hierarchical(sort) works with different sorting methods for each variable", { expect_silent( ard <- sort_ard_hierarchical( ard, sort = list(SEX ~ "alphanumeric", RACE = "descending", AETERM = "alphanumeric") ) ) expect_equal( ard |> dplyr::filter(variable == "SEX") |> dplyr::select(variable_level) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), sort(c("F", "M")) ) expect_equal( ard |> dplyr::filter(variable == "RACE") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "WHITE", "BLACK OR AFRICAN AMERICAN", "WHITE", "BLACK OR AFRICAN AMERICAN", "AMERICAN INDIAN OR ALASKA NATIVE" ) ) expect_equal( ard |> dplyr::filter(variable == "AETERM") |> dplyr::select( all_ard_groups("levels"), -"group1_level", all_ard_variables() ) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA" ) ) }) test_that("sort_ard_hierarchical() works when there is no overall row in x", { ard_no_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = FALSE ) # sort = 'descending' expect_silent(ard_no_overall <- sort_ard_hierarchical(ard_no_overall)) expect_equal( ard_no_overall |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical() |> dplyr::select(all_ard_groups(), all_ard_variables()) |> dplyr::filter(variable != "..ard_hierarchical_overall..") ) # sort = 'alphanumeric' expect_silent( ard_no_overall <- sort_ard_hierarchical( ard_no_overall, sort = "alphanumeric" ) ) expect_equal( ard_no_overall |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical("alphanumeric") |> dplyr::select(all_ard_groups(), all_ard_variables()) |> dplyr::filter(variable != "..ard_hierarchical_overall..") ) }) test_that("sort_ard_hierarchical() works with only one variable in x", { ard_single <- ard_stack_hierarchical( data = ADAE_subset, variables = AETERM, by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE ) # sort = 'descending' expect_silent(ard_single <- sort_ard_hierarchical(ard_single)) expect_equal( ard_single |> dplyr::filter(variable == "AETERM") |> dplyr::pull(variable_level) |> unlist() |> unique(), c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE" ) ) # sort = 'alphanumeric' expect_silent( ard_single <- sort_ard_hierarchical(ard_single, sort = "alphanumeric") ) expect_equal( ard_single |> dplyr::filter(variable == "AETERM") |> dplyr::pull(variable_level) |> unlist() |> unique(), sort(unique(ADAE_subset$AETERM)) ) # works with no `by` ard_single <- ard_stack_hierarchical( data = ADAE_subset, variables = AETERM, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE ) expect_silent(ard_single <- sort_ard_hierarchical(ard_single)) }) test_that("sort_ard_hierarchical() works when some variables not included in x", { ard_incl <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, include = c(SEX, AETERM), over_variables = TRUE ) expect_equal( ard_incl |> sort_ard_hierarchical() |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical() |> dplyr::filter(variable != "RACE") |> dplyr::select(all_ard_groups(), all_ard_variables()), ignore_attr = TRUE ) }) test_that("sort_ard_hierarchical() works when sorting using p instead of n", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, statistic = everything() ~ "p" ) expect_silent(ard_p <- sort_ard_hierarchical(ard)) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, statistic = everything() ~ "p" ) }) test_that("sort_ard_hierarchical() works with overall data", { ard_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, over_variables = TRUE, overall = TRUE ) expect_silent(ard_overall <- sort_ard_hierarchical(ard_overall)) expect_equal( ard_overall |> dplyr::filter(variable == "RACE") |> dplyr::select(all_ard_groups("levels"), all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), rep( c( "WHITE", "BLACK OR AFRICAN AMERICAN", "WHITE", "BLACK OR AFRICAN AMERICAN", "AMERICAN INDIAN OR ALASKA NATIVE" ), each = 4 ) ) expect_equal( ard_overall |> dplyr::filter(variable == "AETERM") |> dplyr::select(all_ard_groups("levels"), all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), rep( c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "APPLICATION SITE PRURITUS", "ERYTHEMA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "APPLICATION SITE PRURITUS", "APPLICATION SITE ERYTHEMA", "ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA" ), each = 4 ) ) }) test_that("sort_ard_hierarchical() error messaging works", { # invalid x input expect_snapshot( sort_ard_hierarchical(ard_tabulate( ADSL, by = "ARM", variables = "AGEGR1" )), error = TRUE ) # invalid sort input expect_snapshot( sort_ard_hierarchical(ard, sort = "no_sorting"), error = TRUE ) # no n or p stat in ARD ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID, statistic = everything() ~ "N" ) expect_snapshot( sort_ard_hierarchical(ard), error = TRUE ) }) cards/tests/testthat/test-selectors.R0000644000176200001440000000371615050667010017462 0ustar liggesuserstest_that("selectors work", { ard_testing <- ard_tabulate(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_tabulate( 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_tabulate( mtcars, by = c(am, vs), variables = cyl ) |> dplyr::select(all_ard_group_n(1L)) |> names(), c("group1", "group1_level") ) expect_equal( ard_tabulate( 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_tabulate(mtcars, by = am, variables = cyl), ard_tabulate(mtcars, variables = vs) ) |> dplyr::filter(variable == "vs") |> dplyr::select(all_missing_columns()) |> names(), c("group1", "group1_level", "warning", "error") ) }) cards/tests/testthat/test-eval_capture_conditions.R0000644000176200001440000000414615026331632022361 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.R0000644000176200001440000000273715050667010017223 0ustar liggesuserstest_that("bind_ard() works", { ard <- ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") expect_error( bind_ard(ard, ard, .update = TRUE), NA ) }) test_that("ARD helpers messaging", { ard <- ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") expect_snapshot( bind_ard(ard, ard, .update = letters), error = TRUE ) expect_snapshot( bind_ard(ard, ard, .distinct = FALSE, .update = FALSE), error = TRUE ) }) test_that("bind_ard() .order argument works", { withr::local_options(list(width = 120)) withr::local_seed(1123) expect_snapshot( bind_ard( ard_tabulate(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_fun, warning, error)) ) expect_snapshot( bind_ard( ard_tabulate(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_fun, warning, error)) ) }) test_that("bind_ard(.quiet)", { expect_silent( ard_summary(ADSL, variables = AGE) %>% {bind_ard(., ., .update = TRUE, .quiet = TRUE)} # styler: off ) }) test_that("bind_ard(.distinct)", { expect_snapshot( ard_summary(ADSL, variables = AGE) %>% {bind_ard(., ., .update = FALSE)} # styler: off ) }) cards/tests/testthat/test-as_card.R0000644000176200001440000000100115050667010017034 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_summary(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.R0000644000176200001440000000060615003556604014501 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/MD50000644000176200001440000003424515113515064011667 0ustar liggesusers9f803443537e5d19b00e1b6031d22aeb *DESCRIPTION dfecf4d24c777eceef39f59521eeccba *NAMESPACE e6e1a0e7b3f8502ece18284edc86a826 *NEWS.md 877879dd026f6231a43304294dea8292 *R/add_calculated_row.R b24308065da76eddbad05bec75fb55a4 *R/apply_fmt_fun.R 318f6edad1e2a5bd16fd3f91410276e6 *R/ard_attributes.R 79d9cfea8a8c60c5b9e5f63a2b5ce1df *R/ard_formals.R cd81cbcca292b34479d5db6fdea8f1ae *R/ard_hierarchical.R 6297ff55fdc7295ad324dc1030f4f621 *R/ard_identity.R 6106acf6b0b9935f46f1ae1b14c92197 *R/ard_missing.R 68b9126eecf87a41ce2c23790ec0e9a9 *R/ard_mvsummary.R d6492dee0c081b63cc570fb9cc92014b *R/ard_pairwise.R c96b8f6aafa1d0c80a6576c63de58bd8 *R/ard_stack.R 5030c4d5e7b230da43622b754596ebfc *R/ard_stack_hierarchical.R 5e72bbb9d70df4f18b6ea6ddc97dc11e *R/ard_strata.R 632c9265a0d61a474d80eb4af56d3e8c *R/ard_summary.R d55d62128b604be68102fa27a02d996c *R/ard_tabulate.R 3e43ca074c0f28d6644bc1182ef406a5 *R/ard_tabulate_value.R 85f6da2a0d6f83aa53da931ea05d896d *R/ard_total_n.R a199d8fa98aafe4b74c56c40de7835b6 *R/as_card.R c54c9e720c772634a63a9c06b0baa3e7 *R/as_card_fn.R 9761029741b98a15a2734132a0f2987f *R/as_nested_list.R 16fb60acc062c40a4f7dbcc527522cc1 *R/bind_ard.R fea7b8b56d7865b84d6900d9ad8c0de9 *R/cards-package.R af81b0d048b780784bb4c3a0e1a3e05e *R/check_ard_structure.R ddbfd10503b9f0ddb9a77d43e31f3ec2 *R/data.R bc9f593fc354bc0d3be1c2edf6ff031e *R/default_stat_labels.R 2defc174f5d52f14dfaee40214daa91f *R/deprecated.R 2d5acb5ca6dc132698c560c47553e64f *R/eval_capture_conditions.R e9c922cc4ccda257ba2778f6938d9432 *R/filter_ard_hierarchical.R a30f3e3cd0fd8bc9bd37aa99c7640f48 *R/get_ard_statistics.R e55324acda2f8e50fa9cfcb250f3f9e7 *R/import-standalone-check_pkg_installed.R 3e892426f3b79623da5bef89858f0b96 *R/import-standalone-checks.R f6519dd628409b21401ed7fc41451622 *R/import-standalone-cli_call_env.R 4eeec13cf7ce8379c2461be82d1d3258 *R/import-standalone-forcats.R 36f367ef4c5a6cac6b92c2197d958d2b *R/import-standalone-purrr.R 1b30778606ac6a14870cdde9b5fc3bed *R/import-standalone-stringr.R a9c1973b8d8847309ad41e6ce5e0dfa9 *R/import-standalone-tibble.R 3094d3f7b4d3930634f6a1e1a99d1de1 *R/maximum_variable_value.R c0e138c1d45beac55c27d870d5d84ca5 *R/mock.R 024d291485604eaa9a2ad528add95c01 *R/nest_for_ard.R bbae9da92f1a98f743919d7790e8a439 *R/options.R 0de30e476f60027052c4057a9dd5a6c5 *R/print.R d6bee37353227018eef0b98f49f4aa75 *R/print_ard_conditions.R e0deca2ecb0703f2289cf9cc49f4a910 *R/process_selectors.R 2baa216c9dbb73ff1c9896547862d0e2 *R/reexports.R f12771fe8c296e31ace40c87fe8caf04 *R/rename_ard_columns.R 4a2d364149cfb3343c7182e8348d6149 *R/rename_ard_groups.R fe9c8098b8badbd346d8918faf8cbb79 *R/replace_null_statistic.R dc8ed9d371902cd75fc0ee86078706c5 *R/round5.R 9df83bf002fc4d12153f886faa475a1f *R/selectors.R a04400a4dd5aee0326bb189b765ae964 *R/shuffle_ard.R 4908bdcf50832a36f46cfa48730cbedc *R/sort_ard_hierarchical.R 41c64ca6d16a419af459dc605b42533e *R/summary_functions.R e63b469fe61a84097bde9be7bcfae357 *R/syntax.R 55403a852f8617092946e6ff07596220 *R/tidy_ard_order.R f45a0d6e96b97c6a646a48b07899dbd9 *R/tidy_as_ard.R 6ae2135b39237e00d79db539d57f2363 *R/unlist_ard_columns.R 1e1d4c4593d5fb6ba9cc743197628271 *R/update_ard.R dd0e98485984008664c996464a79f51d *R/utils.R 2aabd2d9d3d4822a69fe608fab0abdd0 *README.md adbeede0995557349a4da07e3357c47e *data/ADAE.rda bbdf1e7a67cc8e9222223f8fbfd88336 *data/ADLB.rda b6a06f70b48f5bcb4309e6da53d53032 *data/ADSL.rda dd7c099f4dc343ace159e43a3a468100 *data/ADTTE.rda 268a4ecdf8f12cba963a36d4174f997d *inst/WORDLIST bc91ccd832fb093540a18104893dc64d *man/adam.Rd d66480e17c547e55235d8485e2d80771 *man/add_calculated_row.Rd 2028fa0f13bd611d457b128a198917e8 *man/alias_as_fmt_fun.Rd 89e0462a9c8f2f51beea658ad7a93c67 *man/apply_fmt_fun.Rd 9ab1c64c223d673c384f7251cd93ae3d *man/ard_attributes.Rd febb82856fee10591f36aa4a3cc11f09 *man/ard_formals.Rd e9f87e16ecc5f228dfb46bba79122e29 *man/ard_hierarchical.Rd 6d33fa313601643d6680b796f73aafaa *man/ard_identity.Rd 182985d9ccacdaf60372d6e02d399b5c *man/ard_missing.Rd f70e10eeeaac2e42c3d3044142fb12e9 *man/ard_mvsummary.Rd 85e64fcb56e6c0fbd28c6bdd218cf2b6 *man/ard_pairwise.Rd eb701de75df65957ddb9d3f4040c88d4 *man/ard_stack.Rd 0a209ac6860407f5b344ac13a102b98d *man/ard_stack_hierarchical.Rd e56168cfa65928441ed7a7be820011e5 *man/ard_strata.Rd 7cf6062ebd0ab77eb90f13a436fa89da *man/ard_summary.Rd f09359533c84444ea272a6c2dacb895d *man/ard_tabulate.Rd 05dd7a919199afef32e7c863b92fe29a *man/ard_tabulate_value.Rd 2c0622322d9663c28262d6c6cb784d92 *man/ard_total_n.Rd f05ce8d73e04155dfb819d26bfcfee43 *man/as_card.Rd 14028f98686dfc2183c8d04b4d668033 *man/as_cards_fn.Rd 7f263a3c2eaa03709d167163fc2f05ac *man/as_nested_list.Rd 911240b4e10882dc75cc742d1e143b46 *man/bind_ard.Rd 3401aadbdfa3bc5cae33c14127b2c4e8 *man/cards-package.Rd 14fc4c13c7fc7f0363bb2182c49dbfb3 *man/cards.options.Rd 19e1092cd7e86769783a5febe30eaadc *man/check_ard_structure.Rd 7cddd89edc980c298fbe3e1fa16ba78d *man/default_stat_labels.Rd 762d016983b32fed1fc1a8f4cf63a2ae *man/deprecated.Rd cfdcf107ac01ce723cdc67d1e4596f90 *man/dot-calculate_stats_as_ard.Rd 07e1e960a81e2807abb7c0808ff523c5 *man/dot-calculate_tabulation_statistics.Rd 1b421b18da078b0dfb2fad151d984dd0 *man/dot-check_dichotomous_value.Rd 063c1dda0ceacc51a743efc263f73834 *man/dot-check_fmt_string.Rd 73cb0c3cca1a2a5c3114ec7ec97e3d4f *man/dot-check_for_missing_combos_in_denom.Rd 001d6bedd82b1b76cbadc01c44c54ef2 *man/dot-check_no_ard_columns.Rd b2815f20857df4a89902c139c53f3a51 *man/dot-check_var_nms.Rd e795ac27c4f5d8ec71a94e55a78493f7 *man/dot-cli_condition_messaging.Rd 250ed70de3fc969010f1cfa647ce9ac1 *man/dot-cli_groups_and_variable.Rd 95079b592478ea572d20bd7367ad2dbe *man/dot-create_list_for_attributes.Rd 9c225f4ad78dad79af45537cf17deaa4 *man/dot-default_fmt_fun.Rd 85c98f785bb4a80a05f2582f10cf3971 *man/dot-derive_overall_labels.Rd 1ca34cb8a6069a522c3bfff9aca3293e *man/dot-detect_msgs.Rd 4ded99e1535fcbbed2e5a925e76c6ef5 *man/dot-eval_ard_calls.Rd 767d70a2630f00cfba5862d87a517932 *man/dot-fill_grps_from_variables.Rd 5a389daac6bce5c2f04596bed3cc5d57 *man/dot-fill_overall_grp_values.Rd 11a20a555d114d6d8cb4b0fa5c99ac6f *man/dot-is_named_list.Rd 6ae1500d71cfdd6f8add1f8dd4c1b0b9 *man/dot-lst_results_as_df.Rd 5b778c671fea9febb85811f039510d1d *man/dot-nesting_rename_ard_columns.Rd 26515508fb9b45e614cd805ac48e1c7b *man/dot-one_row_ard_to_nested_list.Rd 11c6cba7c6b0ff49669c771b6242d85b *man/dot-process_denominator.Rd dd139d7b9f33b8aebbd1fd2d75fef1e1 *man/dot-process_nested_list_as_df.Rd 2121482506bb51565c005088b9a222ce *man/dot-purrr_list_flatten.Rd f537352faef3bf4ad6fae0f89deb7e0e *man/dot-rename_last_group_as_variable.Rd 6fc1edf2d47b2b457607f349b3b4e51e *man/dot-table_as_df.Rd d76575aad6fef352e0b6814032ea2014 *man/dot-trim_ard.Rd b68996f635bafda4ccdda88bead7798c *man/dot-unique_and_sorted.Rd 3ca947d6c5be145945d2ac9f1d3554bd *man/eval_capture_conditions.Rd a1cbaf3f328e8d74e747faacf640c7fc *man/figures/lifecycle-archived.svg 6f521fb1819410630e279d1abf88685a *man/figures/lifecycle-defunct.svg 391f696f961e28914508628a7af31b74 *man/figures/lifecycle-deprecated.svg 691b1eb2aec9e1bec96b79d11ba5e631 *man/figures/lifecycle-experimental.svg 405e252e54a79b33522e9699e4e9051c *man/figures/lifecycle-maturing.svg f41ed996be135fb35afe00641621da61 *man/figures/lifecycle-questioning.svg 306bef67d1c636f209024cf2403846fd *man/figures/lifecycle-soft-deprecated.svg ed42e3fbd7cc30bc6ca8fa9b658e24a8 *man/figures/lifecycle-stable.svg bf2f1ad432ecccee3400afe533404113 *man/figures/lifecycle-superseded.svg acaef05532711e67dc193e34f39409a4 *man/figures/logo.png b4dd475be9134ee2bf996d9f6a8cc41a *man/filter_ard_hierarchical.Rd 3c6d9a7413a230c0e8f45bad9aea1b2e *man/get_ard_statistics.Rd 82a914c2eb0e8c5db130549b65bf758a *man/label_round.Rd a3cee0f822de312fc8b196956b4e085a *man/maximum_variable_value.Rd f39602657dc9f464047018bbe98dd842 *man/mock.Rd 9e0742d9defffc03e4bf4aba299af7b1 *man/nest_for_ard.Rd 04b51a93e15802d5efaf8f68c19567db *man/print.card.Rd b33e09f727f99ff2fc4f9ad31b4e3e76 *man/print_ard_conditions.Rd 12cc12f77d7e6f71d903323fce5079be *man/process_selectors.Rd a9515193a99a4f99c5effa4ee55458c4 *man/reexports.Rd df3862de18ebbf113c2bc2f03115cde9 *man/rename_ard_columns.Rd 412171e46d2eb1918d2ec9e5f07209ca *man/rename_ard_groups.Rd 9d013b05799d226f4347644074f8977f *man/replace_null_statistic.Rd f88da3966dcf9d64fbfe7c85af54fc06 *man/round5.Rd bfefa4fc95afdd404bb13c7af89128b4 *man/selectors.Rd 1fea432dda50de42ea53f3049b80df00 *man/sort_ard_hierarchical.Rd f4502f687672e795e0bef6c02bc1fe23 *man/summary_functions.Rd 2fe75faba14fda4fbe04f8faa29ad8b6 *man/syntax.Rd 4a314a655138a7809be06f5e206571ea *man/tidy_ard_order.Rd c8dc44b5535bb6b25a93ab85d1558a8f *man/tidy_as_ard.Rd 54db6d512fe980bfbf436dcd65927fbb *man/unlist_ard_columns.Rd 876bd4277713cd944997c9099caefa8f *man/update_ard.Rd 1307e15c19aed9c5310cced13ab36cd8 *tests/testthat.R 2b1fbce128c1b2b3aa26ec999d79c0fa *tests/testthat/_snaps/add_calculated_row.md a1d50a6c5b5c92ce6f7223616cb8c522 *tests/testthat/_snaps/apply_fmt_fun.md c5b5d10c0e2bd9db66f8fbbd615f3e31 *tests/testthat/_snaps/ard_attributes.md f442ab3c74a01d326dc50d0b3b6aa658 *tests/testthat/_snaps/ard_formals.md 77cba34e8206884536ca47dbfa8c5914 *tests/testthat/_snaps/ard_hierarchical.md ef97f925d841aad2c294ed168b4c3b06 *tests/testthat/_snaps/ard_identity.md a1e65c0e97efd1952bcadc810f1c4e70 *tests/testthat/_snaps/ard_missing.md 015917e77f8349643faa12eefbd24211 *tests/testthat/_snaps/ard_mvsummary.md 7e1635bf67805d2b29de026f95981290 *tests/testthat/_snaps/ard_pairwise.md e7b8266cf845fcca8b724f993f893a75 *tests/testthat/_snaps/ard_stack.md df627689fd665b1aebdfbf56525c3225 *tests/testthat/_snaps/ard_stack_hierarchical.md 16b70eddd635bca4d321d73d04c5da34 *tests/testthat/_snaps/ard_strata.md b711ba8179ce50fb3a5f78258a8f7879 *tests/testthat/_snaps/ard_summary.md cc79c46290872727665f43b8b7bbb024 *tests/testthat/_snaps/ard_tabulate.md 5e545b2bb1de61987b77269693cef60b *tests/testthat/_snaps/ard_tabulate_value.md 37b5c8b8a8fa1ff1def402c661411d30 *tests/testthat/_snaps/ard_total_n.md 5709cb25ae339ae1d3a1f4d6da72dd44 *tests/testthat/_snaps/as_card.md 785b00cb1446dd1ffbbe44cb6efb5f5a *tests/testthat/_snaps/as_nested_list.md 36edf1f78bdf45fd2b5fcd61fb8fafbe *tests/testthat/_snaps/bind_ard.md 7ed0f8aea9d36920c71bafb10a7adf95 *tests/testthat/_snaps/check_ard_structure.md 91b80b703fe106f2f1ed251a8fc8eb73 *tests/testthat/_snaps/eval_capture_conditions.md d106dbbaf51a4b5e170f7ad12a0a3ead *tests/testthat/_snaps/filter_ard_hierarchical.md d6cd7ea361c3b86d1911515ff52853dc *tests/testthat/_snaps/get_ard_statistics.md e67deceaa32d54418e4769a976b88051 *tests/testthat/_snaps/mock.md 8000acb4bfe56784720a3e1cbbda7cf8 *tests/testthat/_snaps/options.md eec7487e41260a8d4a21ee20962858b0 *tests/testthat/_snaps/print.md 0605dc21eb9ebccb78c3894c18e3b23e *tests/testthat/_snaps/print_ard_conditions.md 44b7e17ae022b511784d5432380cda25 *tests/testthat/_snaps/process_selectors.md 9c910b08583be67190ebb04cad8c11e9 *tests/testthat/_snaps/rename_ard_columns.md d5cc0eeb4b02342ece21552b7a920f0f *tests/testthat/_snaps/rename_ard_groups.md 54d57668aa3341c5209b0bc97944cb4c *tests/testthat/_snaps/round5.md 9cf1ee6adbd238dc801026822485efae *tests/testthat/_snaps/shuffle_ard.md 06d13a6360961cc14e9d77d3ff6fd1ed *tests/testthat/_snaps/sort_ard_hierarchical.md e6e710a09bc8dfb25c9a34c2d1e3f088 *tests/testthat/_snaps/tidy_ard_row_order.md 9dd7f26c59cdb2ad7d30d452e4e75151 *tests/testthat/_snaps/tidy_as_ard.md 514ef48b591ec759d0f2715c9f59c739 *tests/testthat/_snaps/update_ard.md 672b9b1d9a75fa9ed3f3826b4f1d2ae5 *tests/testthat/test-add_calculated_row.R cb18ecf2cffe00832fa2897028250152 *tests/testthat/test-apply_fmt_fun.R d932ac724df2db777bf9952111c8f551 *tests/testthat/test-ard_attributes.R eef6a12aaa2c1c79c9b0f388211e7df3 *tests/testthat/test-ard_formals.R a9bf18172fda4f8dc63a6321150a4bf9 *tests/testthat/test-ard_hierarchical.R 5654450d235efd9161cf0f4e9cf359d9 *tests/testthat/test-ard_identity.R a19e2f639db365750996ba357cf519f8 *tests/testthat/test-ard_missing.R 82310d6d942c6438078aece661789e40 *tests/testthat/test-ard_mvsummary.R ef12fb369b5efb17329e68627df92f80 *tests/testthat/test-ard_pairwise.R 69f3bea8038c0101d72a16d27851f34f *tests/testthat/test-ard_stack.R 7990b1f738ea81a8fcd719958edd56c8 *tests/testthat/test-ard_stack_hierarchical.R 3d28b8e355f5748085a9e0e58121f56a *tests/testthat/test-ard_strata.R 57d9cd7d8aa1fbb810b3351e2e11c785 *tests/testthat/test-ard_summary.R 2e4c808965e1e72bdd5b667acbcc5a5f *tests/testthat/test-ard_tabulate.R add30cdf5b0fcda2b6ccdd74f966a285 *tests/testthat/test-ard_tabulate_value.R b7e46281dd04e3900243bc122cb7a4e3 *tests/testthat/test-ard_total_n.R ca7f6f35bf5ee677c94c39bfcfa456fa *tests/testthat/test-as_card.R 909a8414db5ca7360dcdacb104e686d2 *tests/testthat/test-as_cards_fn.R 50b259f85a6ed21f5b43a823252b1122 *tests/testthat/test-as_nested_list.R 3eed04b4505422b1d9ad0426db591a8f *tests/testthat/test-bind_ard.R 98144a792ae2a6e2fe5162a88c78310c *tests/testthat/test-check_ard_structure.R cbef190a93c26758b17f0e21db825e3c *tests/testthat/test-eval_capture_conditions.R 41cddd9d3695947eeb1b57e59c2122ee *tests/testthat/test-filter_ard_hierarchical.R 56a2316a26bfdfd2a219b98898334381 *tests/testthat/test-get_ard_statistics.R 478c394225830e4dce894a5e784ef312 *tests/testthat/test-label_round.R 2e0b5e8538d65f09133dd6b3ea2597f6 *tests/testthat/test-mock.R 99f13064ddf25f94c0c64163e94871a8 *tests/testthat/test-nest_for_ard.R 254c4860f28e85fd3d361c892b9fdcdc *tests/testthat/test-options.R a6f086a1142df8af8f30a4e24e5ec54a *tests/testthat/test-print.R cb893922daa94fe0abfb7d2cc63ae505 *tests/testthat/test-print_ard_conditions.R b2e0a96f4a987a5b18ad34b434b8edcc *tests/testthat/test-process_selectors.R 79f92409393da9408f003c68702d27ae *tests/testthat/test-rename_ard_columns.R 04e816ffc7ec8380b246176d54ef0bd9 *tests/testthat/test-rename_ard_groups.R 8a4907400f9aa5fe3beabef537d06d38 *tests/testthat/test-replace_null_statistic.R ff7a3a310a49b1e60bdc23682582bff9 *tests/testthat/test-round5.R 2405bd298e2ec4c9d8cc248b6c3ab480 *tests/testthat/test-selectors.R c11f7d8581241650009fbe26be9bd3e1 *tests/testthat/test-shuffle_ard.R 14bf6deae0e83e922ad4e1942c0bd4c5 *tests/testthat/test-sort_ard_hierarchical.R bad7b9a9efac903f8a1deb586af2f6d8 *tests/testthat/test-tidy_ard_column_order.R 82c0c81a8d1917dbda4a0d8e499c9b62 *tests/testthat/test-tidy_ard_row_order.R 3f097b62ac28bc853f744e81b6e91cad *tests/testthat/test-tidy_as_ard.R ac15fb4980dd6d12559b920e3502be19 *tests/testthat/test-unlist_ard_columns.R f4b54c537111effccb1cf43425145f92 *tests/testthat/test-update_ard.R cards/R/0000755000176200001440000000000015113466401011550 5ustar liggesuserscards/R/ard_pairwise.R0000644000176200001440000000655415050667010014355 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_mvsummary( #' df, #' variables = AGE, #' statistic = ~ list(ttest = \(x, data, ...) t.test(x ~ data$ARM)[c("statistic", "p.value")]) #' ) #' }, #' include = "Placebo" # only include comparisons to the "Placebo" group #' ) ard_pairwise <- function(data, variable, .f, include = NULL) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_data_frame(data) process_selectors(data, variable = {{ variable }}) check_scalar(variable) if (!is_empty(include) && (!is_vector(include) || is.list(include))) { cli::cli_abort( "The {.arg include} argument must be a simple vector, not {.obj_type_friendly {include}}.", call = get_cli_abort_call() ) } .f <- as_function(.f, call = get_cli_abort_call()) variable_levels <- .unique_and_sorted(data[[variable]]) if (!is_empty(include)) { if (!all(include %in% variable_levels)) { cli::cli_abort( "The {.arg include} argument must be NULL or one or more of {.val {variable_levels}}.", call = get_cli_abort_call() ) } } include <- include %||% variable_levels # if include not specified, default to all levels # identify all pairwise values in `variable` --------------------------------- mtx_pairs <- variable_levels |> utils::combn(m = 2) lst_pairs <- seq_len(ncol(mtx_pairs)) |> lapply(FUN = \(x) mtx_pairs[, x]) lst_pairs <- lst_pairs[map_lgl(lst_pairs, ~ any(.x %in% include))] # exclude pairs that were not requested # create data subsets including the pairs ------------------------------------ lst_df_subsets <- lapply( lst_pairs, FUN = \(x) { df_subset <- data |> dplyr::filter(.data[[variable]] %in% .env$x) if (is.factor(data[[variable]])) { data[[variable]] <- factor(data[[variable]], ordered = is.ordered(data[[variable]])) } df_subset } ) |> # set names for returned list including the pair levels stats::setNames(map_chr(lst_pairs, ~ as.character(.x) |> shQuote(type = "csh") |> paste(collapse = " vs. "))) # perform analysis ----------------------------------------------------------- lst_ard <- imap( lst_df_subsets, \(df, pairs) { eval_capture_conditions(.f(df)) |> captured_condition_as_error( message = c(glue::glue("The following {{type}} occurred for {pairs}. See message below."), x = "{condition}") ) } ) # return result -------------------------------------------------------------- lst_ard } cards/R/rename_ard_groups.R0000644000176200001440000000676615050667010015405 0ustar liggesusers#' Rename ARD Group Columns #' #' Functions for renaming group columns names in ARDs. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card'. #' @param shift (`integer`)\cr #' an integer specifying how many values to shift the group IDs, #' e.g. `shift=-1` renames `group2` to `group1`. #' #' @return an ARD data frame of class 'card' #' @name rename_ard_groups #' #' @examples #' ard <- ard_summary(ADSL, by = c(SEX, ARM), variables = AGE) #' #' # Example 1 ---------------------------------- #' rename_ard_groups_shift(ard, shift = -1) #' #' # Example 2 ---------------------------------- #' rename_ard_groups_reverse(ard) NULL #' @rdname rename_ard_groups #' @export rename_ard_groups_shift <- function(x, shift = -1) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, "card") check_integerish(shift) # create data frame with old names and new names ----------------------------- df_group_names <- .group_names_as_df(x) |> dplyr::mutate( new_group_id = .data$old_group_id + as.integer(.env$shift), new_group_name = pmap( list(.data$old_group_name, .data$old_group_id, .data$new_group_id), \(old_group_name, old_group_id, new_group_id) { str_replace( old_group_name, pattern = paste0("^group", old_group_id), replacement = paste0("group", new_group_id) ) } ) |> as.character() ) # warn about bad names if (any(df_group_names$new_group_id < 1L)) { cli::cli_inform(c("There are now non-standard group column names: {.val {df_group_names$new_group_name[df_group_names$new_group_id < 1L]}}.", "i" = "Is this the shift you had planned?" )) } # rename columns and return ARD ---------------------------------------------- x |> dplyr::rename(!!!deframe(df_group_names[c("new_group_name", "old_group_name")])) } #' @rdname rename_ard_groups #' @export rename_ard_groups_reverse <- function(x) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, "card") # if no groups, return ARD unaltered ----------------------------------------- if (dplyr::select(x, all_ard_groups()) |> names() |> is_empty()) { return(x) } # create data frame with old names and new names ----------------------------- df_group_names <- .group_names_as_df(x) all_obs_ids <- sort(unique(df_group_names$old_group_id)) df_group_names$new_group_id <- dplyr::recode( df_group_names$old_group_id, !!!set_names(all_obs_ids, rev(all_obs_ids)) ) df_group_names$new_group_name <- pmap( list(df_group_names$old_group_name, df_group_names$old_group_id, df_group_names$new_group_id), \(old_group_name, old_group_id, new_group_id) { str_replace( old_group_name, pattern = paste0("^group", old_group_id), replacement = paste0("group", new_group_id) ) } ) |> as.character() # rename columns and return ARD ---------------------------------------------- x |> dplyr::rename(!!!deframe(df_group_names[c("new_group_name", "old_group_name")])) |> tidy_ard_column_order() } .group_names_as_df <- function(x) { dplyr::tibble( old_group_name = dplyr::select(x, all_ard_groups()) |> names(), old_group_id = str_extract(.data$old_group_name, "^group[0-9]+") |> str_remove("^group") |> as.integer() ) } cards/R/apply_fmt_fun.R0000644000176200001440000001721315050667010014541 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_fun()]. #' #' @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_summary(ADSL, variables = "AGE") |> #' apply_fmt_fun() apply_fmt_fun <- 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_fun, .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_fun(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_fun(1) #' alias_as_fmt_fun("xx.x") alias_as_fmt_fun <- function(x, variable, stat_name) { set_cli_abort_call() if (is.function(x)) { return(x) } if (is_integerish(x) && x >= 0L) { return(label_round(digits = as.integer(x))) } if (is_string(x)) { .check_fmt_string(x, variable, stat_name) scale <- ifelse(endsWith(x, "%"), 100, 1) decimal_n <- ifelse( !grepl("\\.", x), 0L, gsub("%", "", x) |> # remove percent sign if it is there strsplit(split = ".", fixed = TRUE) |> # split string at decimal place unlist() %>% `[`(2) %>% # get the string after the period {ifelse(is.na(.), 0L, nchar(.))} # styler: off ) width <- nchar(x) - endsWith(x, "%") return(label_round(digits = decimal_n, scale = scale, width = width)) } # if the above conditions are not met, return an error ----------------------- if (!missing(variable) && !missing(stat_name)) { error_message <- c("The value in {.arg fmt_fun} 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_fun} for details." ) } else { error_message <- c("The value in {.arg fmt_fun} 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_fun} for details." ) } cli::cli_abort( message = error_message, call = get_cli_abort_call() ) } #' Generate Formatting Function #' #' Returns a function with the requested rounding and scaling schema. #' #' @param digits (`integer`)\cr #' a non-negative integer specifying the number of decimal places #' round statistics to #' @param scale (`numeric`)\cr #' a scalar real number. Before rounding, the input will be scaled by #' this quantity #' @param width (`integer`)\cr #' a non-negative integer specifying the minimum width of the #' returned formatted values #' #' @return a function #' @export #' #' @examples #' label_round(2)(pi) #' label_round(1, scale = 100)(pi) #' label_round(2, width = 5)(pi) label_round <- function(digits = 1, scale = 1, width = NULL) { round_fun <- .get_round_fun() function(x) { # round and scale vector res <- ifelse( is.na(x), NA_character_, format(round_fun(x * scale, digits = digits), nsmall = digits) |> str_trim() ) # if width provided, pad formatted result if (!is.null(width)) { res <- ifelse( nchar(res) >= width | is.na(res), res, paste0(strrep(" ", width - nchar(res)), res) ) } # return final formatted vector res } } .get_round_fun <- function() { switch(getOption("cards.round_type", default = "round-half-up"), "round-half-up" = round5, "round-to-even" = round ) %||% cli::cli_abort( "The {.arg cards.round_type} {.emph option} must be one of {.val {c('round-half-up', 'round-to-even')}}.", call = get_cli_abort_call() ) } #' Check 'xx' Format Structure #' #' @description #' A function that checks a **single** string for consistency. #' String must begin with 'x' and only consist of x's, a single period or none, #' and may end with a percent symbol. #' #' If string is consistent, `TRUE` is returned. Otherwise an error. #' #' @param x (`string`)\cr #' string to check #' @param variable (`character`)\cr the variable whose statistic is to be formatted #' @param stat_name (`character`)\cr the name of the statistic that is to be formatted #' #' @return a logical #' @keywords internal #' #' @examples #' cards:::.check_fmt_string("xx.x") # TRUE #' cards:::.check_fmt_string("xx.x%") # TRUE .check_fmt_string <- function(x, variable, stat_name) { set_cli_abort_call() # perform checks on the string fmt_is_good <- grepl("^x[x.%]+$", x = x) && # string begins with 'x', and consists of only x, period, or percent sum(unlist(gregexpr("\\.", x)) != -1) %in% c(0L, 1L) && # a period appears 0 or 1 times sum(unlist(gregexpr("%", x)) != -1) %in% c(0L, 1L) && # a percent appears 0 or 1 times (sum(unlist(gregexpr("%", x)) != -1) %in% 0L || grepl(pattern = "%$", x = x)) # if there is a % it appears at the end if (isFALSE(fmt_is_good)) { cli::cli_abort( message = "The format {.val {x}} for `fmt_fun` 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/add_calculated_row.R0000644000176200001440000000675715054100452015505 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_fun (`integer`, `function`, `string`)\cr #' a function of an integer or string that can be converted to a function with #' `alias_as_fmt_fun()`. #' @param fmt_fn `r lifecycle::badge("deprecated")` #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_summary(mtcars, variables = mpg) |> #' add_calculated_row(expr = max - min, stat_name = "range") #' #' ard_summary(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_fun = NULL, fmt_fn = deprecated()) { set_cli_abort_call() expr <- enexpr(expr) # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "add_calculated_row(fmt_fn)", with = "add_calculated_row(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_fun = list(.env$fmt_fun %||% 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.R0000644000176200001440000001052215050667010013026 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_fun'` *may* be removed #' from the print. All other columns will be printed, even if more than `n_col` #' columns are present. #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' not used #' #' @return an ARD data frame of class 'card' (invisibly) #' @export #' @keywords internal #' #' @examples #' ard_tabulate(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_fun", "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_fun' col if there are many cols if (ncol(x_print) > n_col) { x_print[["fmt_fun"]] <- 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_fun" %in% names(x_print)) { x_print$fmt_fun <- lapply( x_print$fmt_fun, 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.R0000644000176200001440000000474415050667010014675 0ustar liggesusers#' Standard Order of ARD #' #' @description #' ARD functions for relocating columns and rows to the standard order. #' #' - `tidy_ard_column_order()` relocates columns of the ARD to the standard order. #' #' - `tidy_ard_row_order()` orders rows of ARD according to groups and #' strata (group 1, then group2, etc), while retaining the column order of the input ARD. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param group_order (`string`)\cr #' specifies the ordering of the grouping variables. #' Must be one of `c("ascending", "descending")`. #' Default is `"ascending"`, where grouping variables begin with `"group1"` variables, #' followed by `"group2"` variables, etc. #' #' @return an ARD data frame of class 'card' #' @name tidy_ard_order #' #' @examples #' # order columns #' ard <- #' dplyr::bind_rows( #' ard_summary(mtcars, variables = "mpg"), #' ard_summary(mtcars, variables = "mpg", by = "cyl") #' ) #' #' tidy_ard_column_order(ard) |> #' tidy_ard_row_order() NULL #' @rdname tidy_ard_order #' @export tidy_ard_column_order <- function(x, group_order = c("ascending", "descending")) { set_cli_abort_call() group_order <- arg_match(group_order) # specify the ordering the grouping variables group_cols <- data.frame(colname = dplyr::select(x, all_ard_groups()) |> names()) |> dplyr::arrange( case_switch( group_order == "ascending" ~ as.integer(unlist(str_extract_all(.data$colname, "\\d+"))), group_order == "descending" ~ dplyr::desc(as.integer(unlist(str_extract_all(.data$colname, "\\d+")))) ), .data$colname ) |> dplyr::pull("colname") # selecting the columns in the tidy order dplyr::select( x, all_of(group_cols), all_ard_variables(), any_of(c( "context", "stat_name", "stat_label", "stat", "stat_fmt", "fmt_fun", "warning", "error" )), dplyr::everything() ) } #' @rdname tidy_ard_order #' @export tidy_ard_row_order <- function(x) { set_cli_abort_call() # get columns that dictate ordering cols <- x |> dplyr::select(all_ard_groups(c("names", "levels"))) |> names() if (!is_empty(cols)) { max_group_n <- as.integer(unlist(str_extract_all(cols, "\\d+"))) |> max() cols <- map(seq_len(max_group_n), ~ c(paste0("group", .x), paste0("group", .x, "_level"))) |> unlist() |> intersect(cols) } # perform the ordering x |> dplyr::arrange(across(all_of(cols), .fns = function(x) match(x, unique(x)))) } cards/R/update_ard.R0000644000176200001440000001205115050667010014001 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_fun (`function`)\cr #' a function or alias recognized by `alias_as_fmt_fun()`. #' @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. #' @param fmt_fn `r lifecycle::badge("deprecated")` #' #' @return an ARD data frame of class 'card' #' @name update_ard #' #' @examples #' ard_summary(ADSL, variables = AGE) |> #' update_ard_fmt_fun(stat_names = c("mean", "sd"), fmt_fun = 8L) |> #' update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> #' apply_fmt_fun() #' #' # same as above, but only apply update to the Placebo level #' ard_summary( #' ADSL, #' by = ARM, #' variables = AGE, #' statistic = ~ continuous_summary_fns(c("N", "mean")) #' ) |> #' update_ard_fmt_fun(stat_names = "mean", fmt_fun = 8L, filter = group1_level == "Placebo") |> #' apply_fmt_fun() NULL #' @export #' @rdname update_ard update_ard_fmt_fun <- function(x, variables = everything(), stat_names, fmt_fun, filter = TRUE, fmt_fn = deprecated()) { set_cli_abort_call() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "update_ard_fmt_fun(fmt_fn)", with = "update_ard_fmt_fun(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_fun, 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_fun ------------------------------------------------ x$fmt_fun[idx1 & idx2] <- list(alias_as_fmt_fun(fmt_fun)) # 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_identity.R0000644000176200001440000000254715050667010014361 0ustar liggesusers#' ARD Identity #' #' Function ingests pre-calculated statistics and returns the identical results, #' but in an ARD format. #' #' @param x (named `list`/`data.frame`)\cr #' named list of results or a data frame. #' Names are the statistic names, and the values #' are the statistic values. These comprise the `"stat_name"` and `"stat"` #' columns in the returned ARD. #' @param variable (`string`)\cr #' string of a variable name that is assigned to the `"variable"` column in the #' ARD. #' @param context (`string`)\cr #' string to be added to the `"context"` column. Default is `"identity"`. #' #' @returns a ARD #' @export #' #' @examples #' t.test(formula = AGE ~ 1, data = ADSL)[c("statistic", "parameter", "p.value")] |> #' ard_identity(variable = "AGE", context = "onesample_t_test") ard_identity <- function(x, variable, context = "identity") { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, c("list", "data.frame")) check_named(x) check_string(variable) check_string(context) # build data frame for calculation ------------------------------------------- dplyr::tibble("{variable}" := TRUE) |> ard_summary( variables = all_of(variable), statistic = everything() ~ list(identity = \(xxx) x) ) |> dplyr::mutate( context = .env$context ) } cards/R/ard_strata.R0000644000176200001440000000752715051154343014032 0ustar liggesusers#' Stratified ARD #' #' @description #' General function for calculating ARD results within subgroups. #' #' While the examples below show use with other functions from the cards package, #' this function would primarily be used with the statistical functions in the #' cardx functions. #' #' @param .data (`data.frame`)\cr #' a data frame #' @param .by,.strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by/stratify by for calculation. #' Arguments are similar, but with an important distinction: #' #' `.by`: results are tabulated by **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `.strata`: results are tabulated by **all _observed_ combinations** of the #' columns specified. #' #' These argument *should not* include any columns that appear in the `.f` argument. #' @param .f (`function`, `formula`)\cr #' a function or a formula that can be coerced to a function with #' `rlang::as_function()` (similar to `purrr::map(.f)`) #' @param ... Additional arguments passed on to the `.f` function. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' # Example 1 ---------------------------------- #' ard_strata( #' ADSL, #' .by = ARM, #' .f = ~ ard_summary(.x, variables = AGE) #' ) #' #' # Example 2 ---------------------------------- #' df <- data.frame( #' USUBJID = 1:12, #' PARAMCD = rep(c("PARAM1", "PARAM2"), each = 6), #' AVALC = c( #' "Yes", "No", "Yes", # PARAM1 #' "Yes", "Yes", "No", # PARAM1 #' "Low", "Medium", "High", # PARAM2 #' "Low", "Low", "Medium" # PARAM2 #' ) #' ) #' #' ard_strata( #' df, #' .strata = PARAMCD, #' .f = \(.x) { #' lvls <- #' switch(.x[["PARAMCD"]][1], #' "PARAM1" = c("Yes", "No"), #' "PARAM2" = c("Zero", "Low", "Medium", "High") #' ) #' #' .x |> #' dplyr::mutate(AVALC = factor(AVALC, levels = lvls)) |> #' ard_tabulate(variables = AVALC) #' } #' ) 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, include_by_and_strata = TRUE) # run fn on nested data frames ----------------------------------------------- df_nested_data <- df_nested_data |> dplyr::mutate(ard = map(.data$data, .f, ...)) |> dplyr::select(-"data") # rename grouping variables -------------------------------------------------- # get the number grouping columns in the calculations max_group_n <- map( df_nested_data$ard, ~ dplyr::select(.x, all_ard_groups("names")) |> names() ) |> unlist() |> unique() |> sort() |> str_remove(pattern = "^group") |> as.integer() %>% # if no grouping variables are present, this will return `-Inf` {suppressWarnings(max(..1 = .))} # styler: off if (!is.infinite(max_group_n) && !is_empty(c(.by, .strata))) { new_group_colnames <- c( paste0("group", seq_along(c(.by, .strata)) + max_group_n), paste0("group", seq_along(c(.by, .strata)) + max_group_n, "_level") ) |> sort() names(df_nested_data)[seq_along(new_group_colnames)] <- new_group_colnames } # unnest ard data frame and return final table ------------------------------- df_nested_data |> tidyr::unnest(cols = all_of("ard")) |> as_card() |> tidy_ard_column_order(group_order = "descending") } cards/R/round5.R0000644000176200001440000000146715003556603013121 0ustar liggesusers#' Rounding of Numbers #' #' Rounds the values in its first argument to the specified number of #' decimal places (default 0). Importantly, `round5()` **does not** use Base R's #' "round to even" default. Standard rounding methods are implemented, for example, #' `cards::round5(0.5) = 1`, whereas `base::round(0.5) = 0`. #' #' @details #' Function inspired by `janitor::round_half_up()`. #' #' @param x (`numeric`)\cr #' a numeric vector #' @param digits (`integer`)\cr #' integer indicating the number of decimal places #' #' @return a numeric vector #' @export #' #' @examples #' x <- 0:4 / 2 #' round5(x) |> setNames(x) #' #' # compare results to Base R #' round(x) |> setNames(x) round5 <- function(x, digits = 0) { trunc(abs(x) * 10^digits + 0.5 + sqrt(.Machine$double.eps)) / 10^digits * sign(as.numeric(x)) } cards/R/sort_ard_hierarchical.R0000644000176200001440000002730115113340127016205 0ustar liggesusers#' Sort Stacked Hierarchical ARDs #' #' @description `r lifecycle::badge('experimental')`\cr #' #' This function is used to sort stacked hierarchical ARDs. #' #' For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the #' combination of all their variable levels, but excluding any `by` variables. #' #' @param x (`card`)\cr #' a stacked hierarchical ARD of class `'card'` created using [ard_stack_hierarchical()] or #' [`ard_stack_hierarchical_count()`]. #' @param sort ([`formula-list-selector`][syntax], `string`)\cr #' a named list, a list of formulas, a single formula where the list element is a named list of functions #' (or the RHS of a formula), or a single string specifying the types of sorting to perform at each hierarchy variable #' level. If the sort method for any variable is not specified then the method will default to `"descending"`. If a #' single unnamed string is supplied it is applied to all variables. For each variable, the value specified must #' be one of: #' - `"alphanumeric"` - at the specified hierarchy level of the ARD, groups are ordered alphanumerically #' (i.e. A to Z) by `variable_level` text. #' - `"descending"` - within each variable group of the ARD at the specified hierarchy level, count sums are #' calculated for each group and groups are sorted in descending order by sum. When `sort` is `"descending"` for a #' given variable and `n` is included in `statistic` for the variable then `n` is used to calculate variable group #' sums, otherwise `p` is used. If neither `n` nor `p` are present in `x` for the variable, an error will occur. #' #' Defaults to `everything() ~ "descending"`. #' #' @return an ARD data frame of class 'card' #' @seealso [filter_ard_hierarchical()] #' @name sort_ard_hierarchical #' #' @note #' If overall data is present in `x` (i.e. the ARD was created with `ard_stack_hierarchical(overall=TRUE)`), the #' overall data will be sorted last within each variable group (i.e. after any other rows with the same combination of #' variable levels). #' #' @examplesIf (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) #' ard_stack_hierarchical( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL, #' id = USUBJID #' ) |> #' sort_ard_hierarchical(AESOC ~ "alphanumeric") #' #' ard_stack_hierarchical_count( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL #' ) |> #' sort_ard_hierarchical(sort = list(AESOC ~ "alphanumeric", AEDECOD ~ "descending")) NULL #' @rdname sort_ard_hierarchical #' @export sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") { set_cli_abort_call() # check and process inputs --------------------------------------------------------------------- check_not_missing(x) check_not_missing(sort) check_class(x, "card") if (!"args" %in% names(attributes(x))) { cli::cli_abort( paste( "Sorting is only available for stacked hierarchical ARDs created using", "{.fun ard_stack_hierarchical} or {.fun ard_stack_hierarchical_count}." ), call = get_cli_abort_call() ) } if (all(x$variable %in% "..ard_hierarchical_overall..")) { return(x) } ard_args <- attributes(x)$args # for calculations by highest severity, innermost variable is extracted from `by` if (length(ard_args$by) > 1) { ard_args$variables <- c(ard_args$variables, dplyr::last(ard_args$by)) ard_args$include <- c(ard_args$include, dplyr::last(ard_args$by)) ard_args$by <- ard_args$by[-length(ard_args$by)] } # get and check sorting method(s) if (is.character(sort)) { sort <- stats::as.formula(paste0("everything() ~ '", sort, "'")) } process_formula_selectors( as.list(ard_args$variables) |> data.frame() |> stats::setNames(ard_args$variables), sort = sort ) fill_formula_selectors( as.list(ard_args$variables) |> data.frame() |> stats::setNames(ard_args$variables), sort = everything() ~ "descending" ) check_list_elements( x = sort, predicate = \(x) x %in% c("descending", "alphanumeric"), error_msg = "Sorting type must be either {.val descending} or {.val alphanumeric} for all variables." ) by <- ard_args$by cols <- ard_args$variables |> stats::setNames( x |> dplyr::select(all_ard_group_n(seq_along(ard_args$variables) + length(by), types = "names"), "variable") |> names() ) # attributes and total n not sorted - appended to bottom of sorted ARD has_attr <- "attributes" %in% x$context | "total_n" %in% x$context if (has_attr) { x_attr <- x |> dplyr::filter(.data$context %in% c("attributes", "total_n")) x <- x |> dplyr::filter(!.data$context %in% c("attributes", "total_n")) } # header row info not sorted - appended to top of sorted ARD has_hdr <- !is_empty(by) | "..ard_hierarchical_overall.." %in% x$variable if (has_hdr) { x_header <- x |> dplyr::filter(.data$variable %in% c(by, "..ard_hierarchical_overall..")) |> # header statistic rows above "..ard_hierarchical_overall.." rows dplyr::arrange(dplyr::desc(.data$variable)) x <- x |> dplyr::filter(!.data$variable %in% c(by, "..ard_hierarchical_overall..")) } # reformat ARD for sorting --------------------------------------------------------------------- x_sort <- x |> # for sorting, assign indices to each row in original order dplyr::mutate(idx = dplyr::row_number()) # reformat current variable columns for sorting x_sort <- x_sort |> .ard_reformat_sort(by, cols) for (i in seq_along(cols)) { sort_i <- sort[[cols[i]]] # current sorting type cur_var <- names(cols)[i] # current grouping variable x_sort <- x_sort |> # group by current and all previous grouping columns dplyr::group_by(dplyr::pick( any_of(cards::all_ard_group_n(seq_len(i) + length(by))), any_of(c(cur_var, paste0(cur_var, "_level"))) )) if (sort_i == "descending") { # descending sort x_sort <- x_sort |> # calculate sums for each group at the current level, then get group indices .append_hierarchy_sums(ard_args, cols, i) } else { # alphanumeric sort x_sort <- x_sort |> # sort grouping variables in alphanumeric order dplyr::arrange(.by_group = TRUE) |> # append group indices dplyr::mutate(!!paste0("sort_group_", i) := dplyr::cur_group_id()) } } idx_sorted <- x_sort |> dplyr::ungroup() |> # sort according to determined orders at each hierarchy level dplyr::arrange(dplyr::pick(starts_with("sort_group_"))) |> # pull ordered row indices dplyr::pull("idx") # sort ARD x <- x[idx_sorted, ] # if present, keep header info at top of ARD if (has_hdr) x <- dplyr::bind_rows(x_header, x) # if present, keep attributes at bottom of ARD if (has_attr) x <- dplyr::bind_rows(x, x_attr) x } # this function reformats a hierarchical ARD for sorting .ard_reformat_sort <- function(x, by, cols) { for (i in seq_along(cols)) { # get current grouping variables cur_var <- names(cols)[i] cur_var_lvl <- paste0(cur_var, "_level") # outer hierarchy variables - process summary rows if (!cur_var %in% "variable") { x[x$variable %in% cols[i], ] <- x[x$variable %in% cols[i], ] |> dplyr::mutate( # move variable/level names to correct grouping variable columns !!cur_var := .data$variable, !!cur_var_lvl := as.list(.data$variable_level), # mark rows as overall summary data variable = "..overall..", variable_level = as.list(NA_character_) ) } # overall=TRUE - process summary rows (no `by` variable) if (!is_empty(by) & !cur_var %in% "variable" & any(x[[paste0("group", i)]] %in% cols[i])) { next_var_gp <- paste0("group", i + length(by) + 1) %in% names(x) x[x[[paste0("group", i)]] %in% cols[i], ] <- x[x[[paste0("group", i)]] %in% cols[i], ] |> dplyr::mutate( # shift variable/level names one to the right !!paste0("group", i + length(by) + 1) := if (next_var_gp) .data[[cur_var]] else NULL, !!paste0("group", i + length(by) + 1, "_level") := if (next_var_gp) as.list(.data[[cur_var_lvl]]) else NULL, !!cur_var := .data[[paste0("group", i)]], !!cur_var_lvl := as.list(.data[[paste0("group", i, "_level")]]) ) } # previous hierarchy variables - process summary rows if (any(is.na(x[[cur_var]]))) { x[is.na(x[[cur_var]]), ] <- x[is.na(x[[cur_var]]), ] |> dplyr::mutate( # mark summary rows from previous variables as "empty" for the current # to sort them prior to non-summary rows in the same section !!cur_var := dplyr::case_when( .data$variable %in% "..overall.." ~ "..empty..", .default = NA ), !!cur_var_lvl := as.list(NA) ) } x <- x |> dplyr::rowwise() |> # unlist cur_var_lvl column dplyr::mutate(dplyr::across(all_of(cur_var_lvl), ~ as.character(unlist(.x)))) |> dplyr::ungroup() } x } # this function calculates and appends group sums/ordering for the current hierarchy level (across `by` variables) .append_hierarchy_sums <- function(x, ard_args, cols, i) { cur_var <- names(cols)[i] # get current grouping variable next_var <- names(cols)[i + 1] # get next grouping variable # all variables in x have n or p stat present (not required if filtered out first) n_stat <- is_empty(setdiff( intersect(ard_args$include, x$variable), x |> dplyr::filter(.data$stat_name == "n") |> dplyr::pull("variable") )) if (!n_stat) { p_stat <- is_empty(setdiff( intersect(ard_args$include, x$variable), x |> dplyr::filter(.data$stat_name == "p") |> dplyr::pull("variable") )) if (!p_stat) { # p statistic is also not available cli::cli_abort( paste( "If {.code sort='descending'} for any variables then either {.val n} or {.val p} must be present in {.arg x}", "for each of these specified variables in order to calculate the count sums used for sorting." ), call = get_cli_abort_call() ) } } sort_stat <- if (n_stat) "n" else "p" # statistic used to calculate group sums # calculate group sums sum_i <- paste0("sum_group_", i) # sum column label x_sums <- x |> dplyr::filter( .data$stat_name == sort_stat, # select statistic to sum if (!is_empty(ard_args$by)) .data$group1 %in% ard_args$by else TRUE, if (length(c(ard_args$by, ard_args$variables)) > 1) { if (ard_args$variable[i] %in% ard_args$include & !cur_var %in% "variable") { # if current variable is in include, sum *only* summary rows for the current variable .data$variable %in% "..overall.." & if (!next_var %in% "variable") .data[[next_var]] %in% "..empty.." else TRUE } else { # otherwise, sum all *innermost* rows for the current variable TRUE } } else { TRUE } ) |> # get sum in each group dplyr::summarize(!!sum_i := sum(unlist(.data$stat[.data$stat_name == sort_stat]))) |> dplyr::ungroup() sort_cols <- append(dplyr::group_vars(x), sum_i, after = length(dplyr::group_vars(x)) - 1) # sorting columns x_sums <- x_sums |> # sort group sums in descending order, grouping variables in alphanumeric order dplyr::arrange(across(all_of(sort_cols), \(x) if (is.numeric(x)) dplyr::desc(x) else x)) |> # record order of groups dplyr::mutate(!!paste0("sort_group_", i) := dplyr::row_number()) # append corresponding group order index to each row x |> dplyr::left_join(x_sums, by = dplyr::group_vars(x)) } cards/R/check_ard_structure.R0000644000176200001440000000525715050667010015726 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_summary(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_fun", "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_fun", "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.R0000644000176200001440000000473715050667010015472 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_summary( #' 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.R0000644000176200001440000000505615050667010013703 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") #' #' ard |> dplyr::select(all_ard_groups()) #' ard |> dplyr::select(all_ard_variables()) NULL #' @export #' @rdname selectors all_ard_groups <- function(types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) if (setequal(types, c("names", "levels"))) { return(dplyr::matches("^group[0-9]+$|^group[0-9]+_level$")) } if (setequal(types, "names")) { return(dplyr::matches("^group[0-9]+$$")) } if (setequal(types, "levels")) { return(dplyr::matches("^group[0-9]+_level$")) } } #' @export #' @rdname selectors all_ard_variables <- function(types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) if (setequal(types, c("names", "levels"))) { return(dplyr::any_of(c("variable", "variable_level"))) } if (setequal(types, "names")) { return(dplyr::any_of("variable")) } if (setequal(types, "levels")) { return(dplyr::any_of("variable_level")) } } #' @export #' @rdname selectors all_ard_group_n <- function(n, types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) group_cols <- character(0L) if ("names" %in% types) group_cols <- c(group_cols, paste0("group", n)) # styler: off if ("levels" %in% types) group_cols <- c(group_cols, paste0("group", n, "_level")) # styler: off check_integerish(n) any_of(sort(group_cols)) } #' @export #' @rdname selectors all_missing_columns <- function() { where(\(x) case_switch(is.list(x) ~ all_empty(x), .default = all_na(x))) } all_na <- function(x) all(is.na(x)) all_empty <- function(x) all(map_lgl(x, is_empty)) cards/R/ard_summary.R0000644000176200001440000003272315113466401014225 0ustar liggesusers#' Univariate ARD Statistics #' #' Compute Analysis Results Data (ARD) for simple continuous summary statistics. #' #' @param data (`data.frame`)\cr #' a data frame #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to include in summaries. #' @param by,strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by/stratify by for summary statistic #' calculation. Arguments are similar, but with an important distinction: #' #' `by`: results are calculated for **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `strata`: results are calculated for **all _observed_ combinations** of the #' columns specified. #' #' Arguments may be used in conjunction with one another. #' @param statistic ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, #' or a single formula where the list element is a named list of functions #' (or the RHS of a formula), #' e.g. `list(mpg = list(mean = \(x) mean(x)))`. #' #' The value assigned to each variable must also be a named list, where the names #' are used to reference a function and the element is the function object. #' Typically, this function will return a scalar statistic, but a function that #' returns a named list of results is also acceptable, e.g. #' `list(conf.low = -1, conf.high = 1)`. However, when errors occur, the messaging #' will be less clear in this setting. #' @param fmt_fun ([`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")`. #' @param fmt_fn `r lifecycle::badge("deprecated")` #' @inheritParams rlang::args_dots_used #' #' @return an ARD data frame of class 'card' #' @name ard_summary #' #' @examples #' ard_summary(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_summary( #' variables = "AGE", #' statistic = #' ~ list(conf.int = \(x) t.test(x)[["conf.int"]] |> #' as.list() |> #' setNames(c("conf.low", "conf.high"))) #' ) NULL #' @rdname ard_summary #' @export ard_summary <- function(data, ...) { check_not_missing(data) UseMethod("ard_summary") } #' @rdname ard_summary #' @export ard_summary.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ continuous_summary_fns(), fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_summary(fmt_fn)", with = "ard_summary(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_fun = fmt_fun, stat_label = stat_label ) fill_formula_selectors( data[variables], statistic = formals(asNamespace("cards")[["ard_summary.data.frame"]])[["stat_label"]] |> eval(), stat_label = formals(asNamespace("cards")[["ard_summary.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_fun ------------------------------------------------ df_results <- .process_nested_list_as_df( x = df_results, arg = fmt_fun, new_column = "fmt_fun" ) |> .default_fmt_fun() # 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 = "summary") |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' Check Protected Column Names #' #' Checks that column names in a passed data frame are not protected, that is, #' they do not begin with `"...ard_"` and end with `"..."`. #' #' @param x (`data.frame`)\cr #' a data frame #' @param exceptions (`string`)\cr #' character string of column names to exclude from checks #' #' @return returns invisible if check is successful, throws an error message if not. #' @keywords internal #' #' @examples #' data <- data.frame("ard_x" = 1) #' #' cards:::.check_no_ard_columns(data) .check_no_ard_columns <- function(x, exceptions = "...ard_dummy_for_counting...") { colnames <- names(x) ard_colnames <- colnames[startsWith(colnames, "...ard_") & endsWith(colnames, "...")] |> setdiff(exceptions) if (!is_empty(ard_colnames)) { "Columns beginning with {.val '...ard_'} and ending with {.val '...'} are not allowed." |> cli::cli_abort(call = get_cli_abort_call()) } } #' Calculate Continuous Statistics #' #' Calculate statistics and return in an ARD format #' #' @param df_nested (`data.frame`)\cr #' a nested data frame #' @param variables (`character`)\cr #' character vector of variables #' @param statistic (named `list`)\cr #' named list of statistical functions #' #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' data_nested <- ADSL |> #' nest_for_ard( #' by = "ARM", #' strata = NULL, #' key = "...ard_nested_data..." #' ) #' #' cards:::.calculate_stats_as_ard( #' df_nested = data_nested, #' variables = "AGE", #' statistic = list(mean = "mean"), #' by = "ARM", #' strata = NULL, #' data = ADSL #' ) .calculate_stats_as_ard <- function(df_nested, variables, statistic, by, strata, data, new_col_name = "...ard_all_stats...") { df_nested[[new_col_name]] <- map( df_nested[["...ard_nested_data..."]], function(nested_data) { map( variables, function(variable) { map2( statistic[[variable]], names(statistic[[variable]]), function(fun, fun_name) { .lst_results_as_df( x = # calculate results, and place in tibble eval_capture_conditions( getOption( "cards.calculate_stats_as_ard.eval_fun", default = expr(do.call(fun, args = list(stats::na.omit(nested_data[[variable]])))) ) ), variable = variable, fun_name = fun_name, fun = fun ) } ) |> unname() } ) |> dplyr::bind_rows() } ) df_nested } #' Prepare Results as Data Frame #' #' Function takes the results from [eval_capture_conditions()], which is a #' named list, e.g. `list(result=, warning=, error=)`, and converts it to a data #' frame. #' #' @param x (named `list`)\cr #' the result from [eval_capture_conditions()] #' @param variable (`string`)\cr #' variable name of the results #' @param fun_name (`string`)\cr #' name of function called to get results in `x` #' #' @return a data frame #' @keywords internal #' #' @examples #' msgs <- eval_capture_conditions({ #' warning("Warning 1") #' warning("Warning 2") #' letters[1:2] #' }) #' #' cards:::.lst_results_as_df(msgs, "result", "mean") .lst_results_as_df <- function(x, variable, fun_name, fun) { # unnesting results if needed if (.is_named_list(x$result, allow_df = TRUE)) { if (is.data.frame(x$result)) x$result <- unclass(x$result) df_ard <- dplyr::tibble( stat_name = names(x$result), result = unname(x$result), warning = list(x$warning), error = list(x$error) ) } # if result is not a nested list, return a single row tibble else { df_ard <- map(x, list) |> dplyr::as_tibble() |> dplyr::mutate( stat_name = # if the function is a "cards_fn" AND the result is missing, use the provided placeholder stat names case_switch( is_empty(.env$x$result) && is_cards_fn(.env$fun) ~ list(get_cards_fn_stat_names(.env$fun)), .default = .env$fun_name ) ) |> tidyr::unnest("stat_name") } df_ard |> dplyr::mutate(variable = .env$variable) |> dplyr::rename(stat = "result") } #' Convert Nested Lists to Column #' #' Some arguments, such as `stat_label`, are passed as nested lists. This #' function properly unnests these lists and adds them to the results data frame. #' #' @param x (`data.frame`)\cr #' result data frame #' @param arg (`list`)\cr #' the nested list #' @param new_column (`string`)\cr #' new column name #' @param unlist (`logical`)\cr #' whether to fully unlist final results #' #' @return a data frame #' @keywords internal #' #' @examples #' ard <- ard_tabulate(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 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") |> #' dplyr::mutate(fmt_fun = NA) #' #' cards:::.default_fmt_fun(ard) .default_fmt_fun <- function(x) { x |> dplyr::mutate( fmt_fun = pmap( list(.data$stat_name, .data$stat, .data$fmt_fun), function(stat_name, stat, fmt_fun) { if (!is_empty(fmt_fun)) { return(fmt_fun) } if (stat_name %in% c("p", "p_miss", "p_nonmiss")) { return(label_round(digits = 1, scale = 100)) } if (is.integer(stat)) { return(0L) } if (is.numeric(stat)) { return(1L) } return(as.character) } ) ) } cards/R/deprecated.R0000644000176200001440000000655215113466401014003 0ustar liggesusers#' Deprecated functions #' #' @description #' `r lifecycle::badge('deprecated')`\cr #' Some functions have been deprecated and are no longer being actively #' supported. #' #' **Renamed functions** #' - `ard_categorical()` to `ard_tabulate()` #' - `ard_continuous()` to `ard_summary()` #' - `ard_complex()` to `ard_mvsummary()` #' - `apply_fmt_fn()` to `apply_fmt_fun()` #' - `alias_as_fmt_fn()` to `alias_as_fmt_fun()` #' - `update_ard_fmt_fn()` to `update_ard_fmt_fun()` #' #' **Deprecated functions** #' - `shuffle_ard()` #' #' @name deprecated NULL # "soft" deprecation for 6 months: (Sys.Date() - lubridate::dmonths(6)) |> as.Date() # v0.6.1 2025-07-03 # v0.6.0 2025-04-11 # v0.5.1 2025-03-01 # "warn" deprecation for 12 months: (Sys.Date() - lubridate::dmonths(12)) |> as.Date() # v0.5.0 2025-02-17 # "stop" deprecation for 18 months: (Sys.Date() - lubridate::dmonths(18)) |> as.Date() # v0.7.0 ----------------------------------------------------------------------- # These were dropped from the documentation in v0.7.0. But were not officially deprecated #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_continuous <- function(data, ...) { check_not_missing(data) UseMethod("ard_continuous") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_categorical <- function(data, ...) { check_not_missing(data) UseMethod("ard_categorical") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_complex <- function(data, ...) { check_not_missing(data) UseMethod("ard_complex") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_dichotomous <- function(data, ...) { check_not_missing(data) UseMethod("ard_dichotomous") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_continuous.data.frame <- function(data, ...) { ard_summary(data = data, ...) |> dplyr::mutate(context = "continuous") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_categorical.data.frame <- function(data, ...) { ard_tabulate(data = data, ...) |> dplyr::mutate(context = "categorical") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_complex.data.frame <- function(data, ...) { ard_mvsummary(data = data, ...) |> dplyr::mutate(context = "complex") } #' @param data,... `r lifecycle::badge('deprecated')` #' @rdname deprecated #' @export ard_dichotomous.data.frame <- function(data, ...) { ard_tabulate_value(data = data, ...) |> dplyr::mutate(context = "dichotomous") } # v0.6.1 ----------------------------------------------------------------------- #' @rdname deprecated #' @export apply_fmt_fn <- function(...) { lifecycle::deprecate_soft( when = "0.6.1", what = "cards::apply_fmt_fn()", with = "apply_fmt_fun()" ) apply_fmt_fun(...) } #' @rdname deprecated #' @export alias_as_fmt_fn <- function(...) { lifecycle::deprecate_soft( when = "0.6.1", what = "cards::alias_as_fmt_fn()", with = "alias_as_fmt_fun()" ) alias_as_fmt_fun(...) } #' @rdname deprecated #' @export update_ard_fmt_fn <- function(...) { lifecycle::deprecate_soft( when = "0.6.1", what = "cards::update_ard_fmt_fn()", with = "update_ard_fmt_fun()" ) alias_as_fmt_fun(...) } cards/R/options.R0000644000176200001440000000204115027040570013362 0ustar liggesusers#' Options in \{cards\} #' #' @name cards.options #' @description #' See below for options available in the \{cards\} package #' #' @section cards.round_type: #' There are two types of rounding types in the \{cards\} package that are implemented #' in `label_round()`, `alias_as_fmt_fun()`, and `apply_fmt_fun()` functions. #' #' - `'round-half-up'` (_default_): rounding method where values exactly halfway #' between two numbers are rounded to the larger in magnitude number. #' Rounding is implemented via [`round5()`]. #' - `'round-to-even'`: base R's default IEC 60559 rounding standard. #' See [`round()`] for details. #' #' To change the default rounding to use IEC 60559, this option must be set **both** #' when the ARDs are created and when `apply_fmt_fun()` is run. This ensures that #' any _default_ formatting functions created with `label_round()` utilize the #' specified rounding method and the method is used what aliases are converted #' into functions (which occurs in `apply_fmt_fun()` when it calls `alias_as_fmt_fun()`). NULL cards/R/maximum_variable_value.R0000644000176200001440000000141215050667010016406 0ustar liggesusers#' 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. #' #' @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() } ) } cards/R/import-standalone-forcats.R0000644000176200001440000000460715012507704017001 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-forcats.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "forcats") # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-forcats.R # last-updated: 2025-05-03 # license: https://unlicense.org # imports: # --- # # This file provides a minimal shim to provide a forcats-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # 2025-05-03 # - `add fct_relevel()` fix for non-factor inputs # 2025-02-24 # - `add fct_relevel()` function. # # nocov start # styler: off fct_infreq <- function(f, ordered = NA) { # reorder by frequency factor( f, levels = table(f) |> sort(decreasing = TRUE) |> names(), ordered = ifelse(is.na(ordered), is.ordered(f), ordered) ) } fct_inorder <- function(f, ordered = NA) { factor( f, levels = stats::na.omit(unique(f)) |> union(levels(f)), ordered = ifelse(is.na(ordered), is.ordered(f), ordered) ) } fct_rev <- function(f) { if (!inherits(f, "factor")) f <- factor(f) factor( f, levels = rev(levels(f)), ordered = is.ordered(f) ) } fct_expand <- function(f, ..., after = Inf) { if (!inherits(f, "factor")) f <- factor(f) old_levels <- levels(f) new_levels <- old_levels |> append(values = setdiff(c(...), old_levels), after = after) factor(f, levels = new_levels) } fct_na_value_to_level <- function(f, level = NA) { if (!inherits(f, "factor")) f <- factor(f) # make NA an explicit level f <- addNA(f, ifany = FALSE) # replace NA level with the string passed in `level` argument if (!is.na(level)) levels(f)[is.na(levels(f))] <- level f } fct_relevel <- function(f, ..., after = 0L) { if (!inherits(f, "factor")) f <- as.factor(f) old_levels <- levels(f) # Handle re-leveling function or specified levels first_levels <- if (rlang::dots_n(...) == 1L && (is.function(..1) || rlang::is_formula(..1))) { fun <- rlang::as_function(..1) fun(old_levels) } else { rlang::chr(...) } # Reorder levels new_levels <- append(setdiff(old_levels, first_levels), first_levels, after = after) new_factor <- factor(f, levels = new_levels) return(new_factor) } # nocov end # styler: on cards/R/get_ard_statistics.R0000644000176200001440000000440015050667010015547 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_tabulate(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_tabulate(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/ard_tabulate.R0000644000176200001440000006054315113466401014332 0ustar liggesusers#' Tabulate ARD #' #' Compute Analysis Results Data (ARD) for categorical summary statistics. #' #' @param data (`data.frame`)\cr #' a data frame #' @param by,strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to use for grouping or stratifying the table output. #' Arguments are similar, but with an important distinction: #' #' `by`: results are tabulated by **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `strata`: results are tabulated by **all _observed_ combinations** of the #' columns specified. #' #' Arguments may be used in conjunction with one another. #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to include in summaries. Default is `everything()`. #' @param denominator (`string`, `data.frame`, `integer`)\cr #' Specify this argument to change the denominator, #' e.g. the `"N"` statistic. Default is `'column'`. See below for details. #' @param statistic ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, #' or a single formula where the list element one or more of `c("n", "N", "p", "n_cum", "p_cum")` #' (on the RHS of a formula). #' @param stat_label ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, or a single formula where #' the list element is either a named list or a list of formulas defining the #' statistic labels, e.g. `everything() ~ list(n = "n", p = "pct")` or #' `everything() ~ list(n ~ "n", p ~ "pct")`. #' @inheritParams ard_summary #' #' @section Denominators: #' By default, the `ard_tabulate()` 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 calculation for the #' proportion is `p = n/N`. #' #' However, it is sometimes necessary to provide a different `"N"` to use #' as the denominator in this calculation. For example, in a calculation #' of the rates of various observed adverse events, you may need to update the #' denominator to the number of enrolled subjects. #' #' In such cases, use the `denominator` argument to specify a new definition #' of `"N"`, and subsequently `"p"`. #' The argument expects one of the following inputs: #' - a string: one of `"column"`, `"row"`, or `"cell"`. #' - `"column"`, the default, returns percentages where the sum is equal to #' one within the variable after the data frame has been subset with `by`/`strata`. #' - `"row"` gives 'row' percentages where `by`/`strata` columns are the 'top' #' of a cross table, and the variables are the rows. This is well-defined #' for a single `by` or `strata` variable, and care must be taken when there #' are more to ensure the the results are as you expect. #' - `"cell"` gives percentages where the denominator is the number of non-missing #' rows in the source data frame. #' - a data frame. Any columns in the data frame that overlap with the `by`/`strata` #' columns will be used to calculate the new `"N"`. #' - an integer. This single integer will be used as the new `"N"` #' - a structured data frame. The data frame will include columns from `by`/`strata`. #' The last column must be named `"...ard_N..."`. The integers in this column will #' be used as the updated `"N"` in the calculations. #' #' When the `p` statistic is returned, the proportion is returned---bounded by `[0, 1]`. #' The default function to format the statistic scales the proportion by 100 #' and the percentage is returned which matches the default statistic label of `'%'`. #' To get the formatted values, pass the ARD to `apply_fmt_fun()`. #' #' #' @return an ARD data frame of class 'card' #' @name ard_tabulate #' #' @examples #' ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") #' #' ADSL |> #' dplyr::group_by(ARM) |> #' ard_tabulate( #' variables = "AGEGR1", #' statistic = everything() ~ "n" #' ) NULL #' @rdname ard_tabulate #' @export ard_tabulate <- function(data, ...) { check_not_missing(data) UseMethod("ard_tabulate") } #' @rdname ard_tabulate #' @export ard_tabulate.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ c("n", "p", "N"), denominator = "column", fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_tabulate(fmt_fn)", with = "ard_tabulate(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_fun = fmt_fun ) fill_formula_selectors( data[variables], statistic = formals(asNamespace("cards")[["ard_tabulate.data.frame"]])[["statistic"]] |> eval() ) check_list_elements( x = statistic, predicate = \(x) is.character(x) && all(x %in% c("n", "p", "N", "n_cum", "p_cum")), error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {c('n', 'p', 'N', 'n_cum', 'p_cum')}}" ) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # return note about column names that result in errors ----------------------- if (any(by %in% c("variable", "variable_level"))) { cli::cli_abort( "The {.arg by} argument cannot include variables named {.val {c('variable', 'variable_level')}}.", call = get_cli_abort_call() ) } # check factor levels -------------------------------------------------------- check_no_na_factor_levels(data[c(variables, by, strata)]) check_factor_has_levels(data[c(variables, by, strata)]) # calculating summary stats -------------------------------------------------- # calculate tabulation statistics df_result_tabulation <- .calculate_tabulation_statistics( data, variables = variables, by = by, strata = strata, denominator = denominator, statistic = lapply(statistic, \(x) list(tabulation = x)) ) # final processing of fmt_fun ------------------------------------------------ df_result_final <- df_result_tabulation |> .process_nested_list_as_df( arg = fmt_fun, new_column = "fmt_fun" ) |> .default_fmt_fun() # 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 = "tabulate") |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' Calculate Tabulation Statistics #' #' Function takes the summary instructions from the #' `statistic = list(variable_name = list(tabulation=c("n", "N", "p")))` #' argument, and returns the tabulations in an ARD structure. #' #' @inheritParams ard_tabulate #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' cards:::.calculate_tabulation_statistics( #' ADSL, #' variables = "ARM", #' by = NULL, #' strata = NULL, #' denominator = "cell", #' statistic = list(ARM = list(tabulation = c("N"))) #' ) .calculate_tabulation_statistics <- function(data, variables, by, strata, denominator, statistic) { # extract the "tabulation" statistics. statistics_tabulation <- lapply(statistic, function(x) x["tabulation"] |> compact()) |> compact() if (is_empty(statistics_tabulation)) { return(dplyr::tibble()) } # first process the denominator lst_denominator <- .process_denominator( data = data, variables = imap( statistics_tabulation, function(x, variable) { if (any(c("N", "p", "p_cum") %in% x[["tabulation"]])) { TRUE } else { NULL } } ) |> compact() |> names(), denominator = denominator, by = by, strata = strata ) # perform other counts df_result_tabulation <- imap( statistics_tabulation, function(tab_stats, variable) { df_result_tabulation <- .table_as_df(data, variable = variable, by = by, strata = strata, count_column = "...ard_n...") if (!is_empty(lst_denominator[[variable]])) { df_result_tabulation <- if (is_empty(intersect(names(df_result_tabulation), names(lst_denominator[[variable]])))) { dplyr::cross_join( df_result_tabulation, lst_denominator[[variable]] ) } else { suppressMessages(dplyr::left_join( df_result_tabulation, lst_denominator[[variable]] )) } } if (any(c("p", "p_cum") %in% tab_stats[["tabulation"]])) { df_result_tabulation <- df_result_tabulation |> dplyr::mutate( ...ard_p... = .data$...ard_n... / .data$...ard_N... ) } df_result_tabulation <- .add_cum_count_stats( df_result_tabulation, variable = variable, by = by, strata = strata, denominator = denominator, tab_stats = tab_stats ) df_result_tabulation |> .nesting_rename_ard_columns(variable = variable, by = by, strata = strata) |> dplyr::mutate( across(any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")), as.list), across(c(matches("^group[0-9]+_level$"), any_of("variable_level")), as.list) ) |> tidyr::pivot_longer( cols = any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")), names_to = "stat_name", values_to = "stat" ) |> dplyr::mutate( stat_name = gsub(pattern = "^...ard_", replacement = "", x = .data$stat_name) %>% gsub(pattern = "...$", replacement = "", x = .) ) |> dplyr::filter(.data$stat_name %in% tab_stats[["tabulation"]]) } ) |> dplyr::bind_rows() df_result_tabulation |> dplyr::mutate( warning = list(NULL), error = list(NULL) ) } .check_whether_na_counts <- function(data) { walk( names(data), function(x) { if (all(is.na(data[[x]])) && !inherits(data[[x]], c("logical", "factor"))) { cli::cli_abort( c("Column {.val {x}} is all missing and cannot by tabulated.", i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing." ), call = get_cli_abort_call() ) } } ) } .add_cum_count_stats <- function(x, variable, by, strata, denominator, tab_stats) { # if no cumulative stats were requested, return the object if (!any(c("p_cum", "n_cum") %in% tab_stats[["tabulation"]])) { return(x) } # to return cumulative stats, the denominator must be 'column' or 'row' if (!is_string(denominator) || !denominator %in% c("column", "row")) { cli::cli_abort( "The {.arg denominator} argument must be one of {.val {c(\"column\", \"row\")}} when cumulative statistics {.val n_cum} or {.val p_cum} are specified, which were requested for variable {.var {variable}}.", call = get_cli_abort_call() ) } # calculate the cumulative statistics if (denominator %in% "column") { x <- x |> dplyr::mutate( .by = any_of(c(by, strata)), ...ard_n_cum... = switch("n_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_n...) ), ...ard_p_cum... = switch("p_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_p...) ) ) } else if (denominator %in% "row") { x <- x |> dplyr::mutate( .by = any_of(variable), ...ard_n_cum... = switch("n_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_n...) ), ...ard_p_cum... = switch("p_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_p...) ) ) } x } #' Results from `table()` as Data Frame #' #' Takes the results from [table()] and returns them as a data frame. #' After the [table()] results are made into a data frame, all the variables #' are made into character columns, and the function also restores the #' column types to their original classes. For `strata` columns, #' only observed combinations are returned. #' #' @param data (`data.frame`)\cr #' a data frame #' @param variable (`string`)\cr #' a string indicating a column in data #' @param by (`character`)\cr #' a character vector indicating columns in data #' @param strata (`character`)\cr #' a character vector indicating columns in data #' @param useNA (`string`)\cr #' one of `"no"` and `"always"`. Will be passed to `table(useNA)`. #' #' @keywords internal #' @return data frame #' #' @examples #' cards:::.table_as_df(ADSL, variable = "ARM", by = "AGEGR1", strata = NULL) .table_as_df <- function(data, variable = NULL, by = NULL, strata = NULL, useNA = c("no", "always"), count_column = "...ard_n...") { useNA <- match.arg(useNA) # tabulate results and save in data frame ...ard_tab_vars... <- c(by, strata, variable) df_table <- data[...ard_tab_vars...] |> dplyr::mutate(across(where(is.logical), ~ factor(., levels = c("FALSE", "TRUE")))) |> with(inject(table(!!!syms(...ard_tab_vars...), useNA = !!useNA))) |> dplyr::as_tibble(n = count_column) # construct a matching data frame with the variables in their original type/class df_original_types <- lapply( c(by, strata, variable), function(x) .unique_and_sorted(data[[x]], useNA = useNA) ) |> stats::setNames(c(by, strata, variable)) %>% {tidyr::expand_grid(!!!.)} |> # styler: off arrange_using_order(rev(...ard_tab_vars...)) # if all columns match, then replace the coerced character cols with their original type/class all_cols_equal <- every( c(by, strata, variable), ~ all( df_table[[.x]] == as.character(df_original_types[[.x]]) | (is.na(df_table[[.x]]) & is.na(df_original_types[[.x]])) ) ) if (isTRUE(all_cols_equal)) { df_table <- dplyr::bind_cols(df_original_types, df_table[count_column], .name_repair = "minimal") } # I hope this message is never triggered! else { cli::cli_inform(c( "If you see this message, the order of the sorted variables in the tabulaton is unexpected, which could cause downstream issues.", "*" = "Please post a reproducible example to {.url https://github.com/insightsengineering/cards/issues/new}, so we can address in the next release.", "i" = "You can create a minimal reproducible example with {.fun reprex::reprex}." )) } # if strata is present, remove unobserved rows if (!is_empty(strata)) { # if we were not able to maintain the original type, convert strata to character if (!isTRUE(all_cols_equal)) { df_original_strata <- dplyr::distinct(data[strata]) |> apply(MARGIN = 2, FUN = as.character) } else { df_original_strata <- dplyr::distinct(data[strata]) } df_table <- dplyr::left_join( df_original_strata |> dplyr::arrange(across(all_of(strata))), df_table, by = strata ) |> dplyr::select(all_of(names(df_table))) } df_table } # like `dplyr::arrange()`, but uses base R's `order()` to keep consistency in some edge cases arrange_using_order <- function(data, columns) { inject(data[with(data, order(!!!syms(columns))), ]) } #' Process `denominator` Argument #' #' Function takes the `ard_tabulate(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_tabulate #' #' @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()) } } #' Case Switch #' #' A pipe-friendly version of a series of `if ()`, `if else ()`, and `else` statements. #' #' @param ... `formula`\cr #' LHS is the predicate condition, and RHS is the returned value when RHS is `TRUE` #' @param .default the default value when no conditions in `...` are met. #' #' @returns an object #' @noRd 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_nested_list.R0000644000176200001440000000661515050667010014702 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_summary(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_fun(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_summary(mtcars, variables = mpg) |> #' dplyr::filter(dplyr::row_number() %in% 1L) |> #' apply_fmt_fun() |> #' 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.R0000644000176200001440000003001615113466401014155 0ustar liggesusers#' Shuffle ARD #' #' @description `r lifecycle::badge('deprecated')`\cr #' #' 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 #' @rdname deprecated #' @export #' #' @examples #' bind_ard( #' ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), #' ard_tabulate(ADSL, variables = "ARM") #' ) |> #' shuffle_ard() shuffle_ard <- function(x, trim = TRUE) { lifecycle::deprecate_warn( when = "0.8.0", what = "cards::shuffle_ard()", with = "tfrmt::shuffle_card()", always = TRUE ) set_cli_abort_call() check_class(x = x, cls = "card") check_scalar_logical(trim) ard_attributes <- attributes(x) ard_args <- ard_attributes$args # make sure columns are in order & add index for retaining order dat_cards <- x |> tidy_ard_column_order() |> tidy_ard_row_order() |> dplyr::mutate(..cards_idx.. = dplyr::row_number()) # fill stat label if missing dat_cards <- dat_cards |> dplyr::mutate(dplyr::across(any_of("stat_label"), ~ dplyr::coalesce(.x, stat_name))) # split up the data into data/variable info & cards info vars_ard <- dat_cards |> dplyr::select(all_ard_groups(), all_ard_variables()) |> names() vars_protected <- setdiff(names(dat_cards), vars_ard) dat_cards_grps <- dat_cards |> dplyr::select(-all_of(vars_protected), "..cards_idx..") dat_cards_stats <- dat_cards |> dplyr::select(all_of(vars_protected)) # process the data/variable info dat_cards_grps_processed <- dat_cards_grps |> .check_var_nms(vars_protected = names(dat_cards_stats)) |> rename_ard_columns(columns = all_ard_groups("names"), fill = "..cards_overall..") |> # coerce everything to character dplyr::mutate( dplyr::across( -"..cards_idx..", ~ lapply(., \(x) if (!is.null(x)) as.character(x) else NA_character_) ) ) # join together again dat_cards_out <- dplyr::left_join( dat_cards_grps_processed, dat_cards_stats, by = "..cards_idx.." ) dat_cards_out <- dat_cards_out |> # unlist the list-columns unlist_ard_columns() |> .fill_grps_from_variables() |> .fill_overall_grp_values(vars_protected) |> dplyr::arrange(.data$..cards_idx..) |> dplyr::select(-"..cards_idx..") output <- dat_cards_out if (trim) { output <- dat_cards_out |> .trim_ard() } # re-attach the args attribute attr(output, "args") <- ard_args output } #' 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), #' ard_tabulate(ADSL, variables = "ARM") #' ) |> #' shuffle_ard(trim = FALSE) #' #' ard |> cards:::.trim_ard() .trim_ard <- function(x) { check_data_frame(x) # detect any warning/error messages and notify user .detect_msgs(x, "warning", "error") # flatten ard table for easier viewing --------------------------------------- x |> dplyr::select(-c("fmt_fun", "warning", "error")) } #' Detect Columns with Non-Null Contents #' #' Function looks for non-null contents in requested columns and notifies user #' before removal. Specifically used for detecting messages. #' #' @param x (`data.frame`)\cr #' a data frame #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' columns to search within #' @keywords internal #' #' @examples #' ard <- ard_summary( #' ADSL, #' by = ARM, #' variables = AGE, #' statistic = ~ list( #' mean = \(x) mean(x), #' mean_warning = \(x) { #' warning("warn1") #' warning("warn2") #' mean(x) #' }, #' err_fn = \(x) stop("'tis an error") #' ) #' ) #' #' cards:::.detect_msgs(ard, "warning", "error") .detect_msgs <- function(x, ...) { dots <- rlang::dots_list(...) lapply(dots, function(var) { if (any(!map_lgl(x[[var]], is.null))) { cli::cli_inform("{.val {var}} column contains messages that will be removed.") } }) } #' Check Variable Names #' #' Checks variable names in a data frame against protected names and modifies #' them if needed #' #' @param x (`data.frame`)\cr #' a data frame #' @param vars_protected (`character`)\cr #' a character vector of protected names #' #' @return a data frame #' @keywords internal #' #' @examples #' data <- data.frame(a = "x", b = "y", c = "z", ..cards_idx.. = 1) #' #' cards:::.check_var_nms(data, vars_protected = c("x", "z")) .check_var_nms <- function(x, vars_protected) { # get all represented variable names from original data var_nms <- x |> dplyr::select(-ends_with("_level"), -"..cards_idx..") |> unlist(use.names = FALSE) |> unique() # create uniqueness across all variables from original data & cards-specific # variables var_nms_new <- make.unique(c(vars_protected, var_nms)) |> utils::tail(n = length(var_nms)) |> set_names(var_nms) # subset to only the ones needing recoding var_nms_new <- var_nms_new[imap( var_nms_new, function(x, y) { if (is.na(x)) FALSE else !x == y } ) |> unlist(use.names = FALSE)] # perform recodes if needed if (length(var_nms_new) > 0) { x |> dplyr::mutate(dplyr::across( -c(ends_with("_level"), "..cards_idx.."), ~ dplyr::recode(.x, !!!var_nms_new) )) } else { x } } #' Back Fill Group Variables #' #' This function back fills the values of group variables using #' variable/variable_levels. The back filling will occur if the value of the #' `variable` column matches the name of a grouping variable, and the grouping #' variable's value is `NA`. #' #' @param x (`data.frame`)\cr #' a data frame #' #' @return data frame #' @keywords internal #' #' @examples #' data <- data.frame( #' variable = c(rep("A", 3), rep("B", 2)), #' variable_level = 1:5, #' A = rep(NA, 5), #' B = rep(NA, 5) #' ) #' #' cards:::.fill_grps_from_variables(data) .fill_grps_from_variables <- function(x) { # within each variable, check if there is a match against one of the grouping cols # if the corresponding value in that grouping col is missing, backfill with the variable level x %>% dplyr::mutate(variable = fct_inorder(.data$variable)) |> dplyr::group_by(.data$variable) |> dplyr::group_split() |> map(function(dat) { grp_match <- names(dat)[names(dat) == unique(dat$variable)] if (length(grp_match) > 0 && "variable_level" %in% names(dat)) { dat |> dplyr::mutate(!!grp_match := ifelse(is.na(.data[[grp_match]]), .data$variable_level, .data[[grp_match]] )) } else { dat } }) |> dplyr::bind_rows() |> dplyr::mutate(variable = as.character(.data$variable)) } #' Fill Overall Group Variables #' #' This function fills the missing values of grouping variables with #' `"Overall "` or `"Any "`where relevant. #' Specifically, it will modify grouping values from rows with likely overall #' calculations present (e.g. non-missing variable/variable_level, 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. #' `"Any"` will be used if it is likely to be a hierarchical calculation. #' #' @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 "..cards_overall.." where it is likely to be an overall calculation for (g in grp_vars) { # rows with missing group x_missing_by <- x |> dplyr::filter(is.na(.data[[g]])) # rows with non-missing group x_nonmissing_by <- x |> dplyr::filter(!is.na(.data[[g]]) & !.data[[g]] == "..cards_overall..") if (nrow(x_missing_by) > 0 && nrow(x_nonmissing_by) > 0) { x_missing_by_replaced <- x_missing_by |> dplyr::rows_update( x_nonmissing_by |> dplyr::mutate(!!g := ifelse(!is.na(.data[[g]]), "..cards_overall..", .data[[g]])) |> dplyr::select(-any_of(c(setdiff(names(x), c(g, id_vars))))) |> dplyr::distinct(), by = id_vars, unmatched = "ignore" ) x <- dplyr::rows_update(x, x_missing_by_replaced, by = "..cards_idx..") } } # replace NA group values with "..cards_overall.." or "..hierarchical_overall.." # where it is likely to be a group or subgroup calculation for (i in seq_along(grp_vars)) { g_var <- grp_vars[i] x <- x |> dplyr::mutate( !!g_var := dplyr::case_when( # only assign "..cards_overall.." for the first grouping variable is.na(.data[[g_var]]) & .data$variable == "..ard_total_n.." & i == 1 ~ "..cards_overall..", is.na(.data[[g_var]]) & .data$variable == "..ard_hierarchical_overall.." ~ "..hierarchical_overall..", TRUE ~ .data[[g_var]] ) ) } # replace `"..cards_overall.."` group values with "Overall " and # `"..hierarchical_overall.."` with `"Any "` output <- x |> dplyr::mutate( dplyr::across( tidyselect::all_of( grp_vars ), .derive_overall_labels ) ) output } #' Derive overall labels #' #' Transform the `"..cards_overall.."` and `"..hierarchical_overall.."` labels #' into `"Overall "` and `"Any "` respectively. #' Also it ensures the labels are unique (in case they already exist) with #' `make.unique()` which appends a sequence number. #' #' @param x (character) content of target (current) column #' @param cur_col (character) name of current column #' #' @returns a character vector #' #' @keywords internal #' #' @examples #' data <- dplyr::tibble( #' ARM = c("..cards_overall..", "Overall ARM", NA, "BB", NA), #' TRTA = c(NA, NA, "..hierarchical_overall..", "C", "C") #' ) #' #' data |> #' dplyr::mutate( #' dplyr::across( #' ARM:TRTA, #' cards:::.derive_overall_labels #' ) #' ) .derive_overall_labels <- function(x, cur_col = dplyr::cur_column()) { glue_overall <- glue::glue("Overall {cur_col}") glue_any <- glue::glue("Any {cur_col}") overall_val <- c(unique(x), glue_overall) |> make.unique() |> dplyr::last() any_val <- c(unique(x), glue_any) |> make.unique() |> dplyr::last() if (overall_val != glue_overall) { cli::cli_alert_info( "{.val {glue_overall}} already exists in the {.code {cur_col}} column. \\ Using {.val {overall_val}}." ) } if (any_val != glue_any) { cli::cli_alert_info( "{.val {glue_any}} already exists in the {.code {cur_col}} column. Using\\ {.val {any_val}}." ) } output <- dplyr::case_when( x == "..cards_overall.." ~ overall_val, x == "..hierarchical_overall.." ~ any_val, TRUE ~ x ) output } cards/R/bind_ard.R0000644000176200001440000001013415050667010013433 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 `TRUE`. 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_tabulate(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.R0000644000176200001440000000124115003556603013267 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.R0000644000176200001440000001523415051153174014346 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`. #' @param include_by_and_strata (`logical`)\cr #' When `TRUE`, the `by` and `strata` variables are included in the nested #' data frames. #' #' @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, include_by_and_strata = FALSE) { 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) { data <- dplyr::filter(data, !!!lst_filter_exprs[[i]]) # remove by and strata columns, unless requested to stay if (!include_by_and_strata) { data <- dplyr::select(data, -all_of(.env$by), -all_of(.env$strata)) } data } ) } # put variable levels in list to preserve types when stacked ----------------- if (isTRUE(list_columns)) { df_return <- df_return |> dplyr::mutate(across(.cols = -any_of(key), .fns = as.list)) } # rename by and strata columns to group## and group##_level ------------------ if (isTRUE(rename_columns)) { df_return <- df_return |> .nesting_rename_ard_columns(by = by, strata = strata) } # returning final nested tibble ---------------------------------------------- df_return |> dplyr::as_tibble() } #' Rename ARD Columns #' #' If `variable` is provided, adds the standard `variable` column to `x`. If `by`/`strata` are #' provided, adds the standard `group##` column(s) to `x` and renames the provided columns to #' `group##_level` in `x`, where `##` is determined by the column's position in `c(by, strata)`. #' #' @param x (`data.frame`)\cr #' a data frame #' @param variable (`character`)\cr #' name of `variable` column in `x`. Default is `NULL`. #' @param by (`character`)\cr #' character vector of names of `by` columns in `x`. Default is `NULL`. #' @param strata (`character`)\cr #' character vector of names of `strata` columns in `x`. Default is `NULL`. #' #' @return a tibble #' @keywords internal #' #' @examples #' ard <- nest_for_ard( #' data = #' ADAE |> #' dplyr::left_join(ADSL[c("USUBJID", "ARM")], by = "USUBJID") |> #' dplyr::filter(AOCCSFL %in% "Y"), #' by = "ARM", #' strata = "AESOC", #' rename_columns = FALSE #' ) #' #' cards:::.nesting_rename_ard_columns(ard, by = "ARM", strata = "AESOC") .nesting_rename_ard_columns <- function(x, variable = NULL, by = NULL, strata = NULL) { if (!is_empty(variable)) { x <- x |> dplyr::rename(variable_level = !!sym(variable)) |> dplyr::mutate(variable = .env$variable, .before = 0L) } if (!is_empty(by) || !is_empty(strata)) { x <- x |> dplyr::mutate(!!!(as.list(c(by, strata)) |> stats::setNames(paste0("group", seq_along(c(strata, by))))), .before = 0L) |> dplyr::rename(!!!(as.list(c(by, strata)) |> stats::setNames(paste0("group", seq_along(c(strata, by)), "_level")))) } tidy_ard_column_order(x) } cards/R/ard_formals.R0000644000176200001440000000364615026320414014171 0ustar liggesusers#' Argument Values ARD #' #' Place default and passed argument values to a function into an ARD structure. #' #' @param fun (`function`)\cr #' a [function] passed to `formals(fun)` #' @param arg_names (`character`)\cr #' character vector of argument names to return #' @param passed_args (named `list`)\cr #' a named list of user-passed arguments. Default is `list()`, which returns #' all default values from a function #' @param envir (`environment`)\cr #' an environment passed to `formals(envir)` #' #' @return an partial ARD data frame of class 'card' #' @export #' #' @examples #' # Example 1 ---------------------------------- #' # add the `mcnemar.test(correct)` argument to an ARD structure #' ard_formals(fun = mcnemar.test, arg_names = "correct") #' #' # Example 2 ---------------------------------- #' # S3 Methods need special handling to access the underlying method #' ard_formals( #' fun = asNamespace("stats")[["t.test.default"]], #' arg_names = c("mu", "paired", "var.equal", "conf.level"), #' passed_args = list(conf.level = 0.90) #' ) ard_formals <- function(fun, arg_names, passed_args = list(), envir = parent.frame()) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_not_missing(fun) check_not_missing(arg_names) check_class(passed_args, "list") check_class(fun, "function") check_class(arg_names, "character") check_class(envir, "environment") # prepare named list of arguments -------------------------------------------- lst_args <- formals(fun = fun, envir = envir)[arg_names] |> utils::modifyList(val = passed_args[intersect(arg_names, names(passed_args))], keep.null = TRUE) # put formals list in ARD structure ------------------------------------------ enframe(lst_args[arg_names], "stat_name", "stat") |> dplyr::mutate(stat_label = .data$stat_name, .after = "stat_name") |> as_card() } cards/R/ard_missing.R0000644000176200001440000000735115050667010014177 0ustar liggesusers#' Missing ARD Statistics #' #' Compute Analysis Results Data (ARD) for statistics related to data missingness. #' #' @inheritParams ard_summary #' @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_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_missing(fmt_fn)", with = "ard_missing(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_summary( data = data, variables = all_of(variables), by = {{ by }}, statistic = lapply(statistic, \(x) missing_summary_fns(x)), fmt_fun = fmt_fun, 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.R0000644000176200001440000002621415003556603015443 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.R0000644000176200001440000000421715050667010013224 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_summary(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_summary(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_summary(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_summary(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_summary(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_summary(statistic = ~list(N = \(x) length(x))) #' ard_summary(statistic = everything() ~ list(N = \(x) length(x))) #' ``` #' #' 5. **Combination Selectors** #' #' Selectors can be combined using the `c()` function. #' #' ```r #' ard_summary(statistic = c(everything(), -age) ~ list(N = \(x) length(x))) #' ``` NULL cards/R/print_ard_conditions.R0000644000176200001440000001424315050667010016111 0ustar liggesusers#' Print ARD Condition Messages #' #' Function parses the errors and warnings observed while calculating the #' statistics requested in the ARD and prints them to the console as messages. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param condition_type (`string`)\cr #' indicates how warnings and errors are returned. #' Default is `"inform"` where all are returned as messages. #' When `"identity"`, errors are returned as errors and warnings as warnings. #' #' @return returns invisible if check is successful, throws all condition messages if not. #' @export #' #' @examples #' # passing a character variable for numeric summary #' ard_summary(ADSL, variables = AGEGR1) |> #' print_ard_conditions() print_ard_conditions <- function(x, condition_type = c("inform", "identity")) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, cls = "card") condition_type <- rlang::arg_match(condition_type, call = get_cli_abort_call()) # print condition messages --------------------------------------------------- # styler: off if ("error" %in% names(x)) .cli_condition_messaging(x, msg_type = "error", condition_type = condition_type) if ("warning" %in% names(x)) .cli_condition_messaging(x, msg_type = "warning", condition_type = condition_type) # styler: on invisible() } #' Print Condition Messages Saved in an ARD #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param msg_type (`string`)\cr #' message type. Options are `"warning"` and `"error"`. #' #' @return returns invisible if check is successful, throws warning/error messages if not. #' @keywords internal #' #' @examples #' ard <- ard_summary( #' ADSL, #' by = ARM, #' variables = AGE #' ) #' #' cards:::.cli_condition_messaging(ard, msg_type = "error") .cli_condition_messaging <- function(x, msg_type, condition_type) { set_cli_abort_call() # filter the ARD for the rows with messages to print ard_condition <- x |> dplyr::filter(!map_lgl(.data[[msg_type]], is.null)) # if no messages, quit the function early if (nrow(ard_condition) == 0L) { return(invisible()) } # choose the function for color prints for warnings/errors cli_color_fun <- switch(msg_type, "warning" = cli::col_yellow, "error" = cli::col_red ) # create a data frame that is one row per message to print # also formats the text that will be printed ard_msg <- ard_condition |> dplyr::group_by(dplyr::pick(all_ard_groups(), all_ard_variables(), all_of(msg_type))) |> dplyr::group_map( function(.x, .y) { dplyr::tibble( # this column is the messaging for which groups/variable the message appears in cli_variable_msg = dplyr::select(.y, all_ard_variables("names")) |> dplyr::mutate(across(where(is.list), unlist)) |> dplyr::slice(1L) |> as.list() |> .cli_groups_and_variable() |> list(), cli_group_msg = dplyr::select(.y, all_ard_groups()) |> dplyr::mutate(across(where(is.list), unlist)) |> dplyr::slice(1L) |> as.list() |> .cli_groups_and_variable() |> list(), # character vector of all the stat_names the message applies to all_stat_names = list(.x$stat_name), # grabs the condition message and colors it with the cli color function cond_msg = unlist(.y[[msg_type]]) |> lapply(cli_color_fun) ) } ) |> dplyr::bind_rows() # and finally, print the messages cli::cli_inform( "The following {cli_color_fun(paste0(msg_type, 's'))} were returned during {.fun {error_call(get_cli_abort_call()) |> rlang::call_name()}}:" ) # set cli message function # styler: off if (condition_type == "inform") cli_msg_fn <- cli::cli_inform else if (condition_type == "identity" && msg_type == "warning") cli_msg_fn <- cli::cli_warn else if (condition_type == "identity" && msg_type == "error") { cli_msg_fn <- \(message, ...) cli::cli_abort(message = message, ..., call = get_cli_abort_call()) } # styler: on for (i in seq_len(nrow(ard_msg))) { cli_msg_fn( paste( glue::glue( "For variable {ard_msg$cli_variable_msg[[i]]} ", "{switch(!is.null(ard_msg$cli_group_msg[[i]]), paste0('(', ard_msg$cli_group_msg[[i]], ')')) %||% ''} ", "and {{.val {{ard_msg$all_stat_names[[i]]}}}} statistic{{?s}}" ), "{ard_msg$cond_msg[[i]]}", sep = ": " ) |> stats::setNames(switch(msg_type, "warning" = "!", "error" = "x" )) ) } invisible() } #' Locate Condition Messages in an ARD #' #' Prints a string of all `group##`/`group##_level` column values and #' `variable` column values where condition messages occur, formatted #' using glue syntax. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return a string #' @keywords internal #' #' @examples #' ard <- ard_summary( #' 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.R0000644000176200001440000005533715003557072016611 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-checks.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "checks") # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-checks.R # last-updated: 2025-04-27 # 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 # 2025-04-27 Added `check_named()` # 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) } #' Check is Named #' #' @inheritParams check_numeric #' @keywords internal #' @noRd check_named <- function(x, allow_empty = FALSE, message = "The {.arg {arg_name}} argument must be named.", arg_name = rlang::caller_arg(x), call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty and allowed, return input invisibly if (allow_empty && rlang::is_empty(x)) { return(invisible(x)) } # check input is named if (!rlang::is_named(x)) { cli::cli_abort(message = message, call = call, .envir = envir) } invisible(x) } # nocov end # styler: on cards/R/ard_hierarchical.R0000644000176200001440000002036415050667010015143 0ustar liggesusers#' Hierarchical ARD Statistics #' #' @description #' _Functions `ard_hierarchical()` and `ard_hierarchical_count()` are primarily helper #' functions for [`ard_stack_hierarchical()`] and [`ard_stack_hierarchical_count()`], #' meaning that it will be rare a user needs to call #' `ard_hierarchical()`/`ard_hierarchical_count()` directly._ #' #' Performs hierarchical or nested tabulations, e.g. tabulates AE terms #' nested within AE system organ class. #' - `ard_hierarchical()` includes summaries for the last variable listed #' in the `variables` argument, nested within the other variables included. #' - `ard_hierarchical_count()` includes summaries for _all_ variables #' listed in the `variables` argument each summary nested within the preceding #' variables, e.g. `variables=c(AESOC, AEDECOD)` summarizes `AEDECOD` nested #' in `AESOC`, and also summarizes the counts of `AESOC`. #' #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables to perform the nested/hierarchical tabulations within. #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables to perform tabulations by. All combinations of the variables #' specified here appear in results. Default is `dplyr::group_vars(data)`. #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' an optional argument used to assert there are no duplicates within #' the `c(id, variables)` columns. #' @param denominator (`data.frame`, `integer`)\cr #' used to define the denominator and enhance the output. #' The argument is required for `ard_hierarchical()` and optional #' for `ard_hierarchical_count()`. #' - the univariate tabulations of the `by` variables are calculated with `denominator`, #' when a data frame is passed, e.g. tabulation of the treatment assignment #' counts that may appear in the header of a table. #' - the `denominator` argument must be specified when `id` is used to #' calculate the event rates. #' @inheritParams ard_tabulate #' #' @return an ARD data frame of class 'card' #' @name ard_hierarchical #' #' @examples #' ard_hierarchical( #' data = ADAE |> #' dplyr::slice_tail(n = 1L, by = c(USUBJID, TRTA, AESOC, AEDECOD)), #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' id = USUBJID, #' denominator = ADSL #' ) #' #' 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_fun = NULL, stat_label = everything() ~ default_stat_labels(), id = NULL, fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_hierarchical(fmt_fn)", with = "ard_hierarchical(fmt_fun)" ) fmt_fun <- fmt_fn } # 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, by, 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_tabulate( data = data, variables = "...ard_dummy_for_counting...", by = all_of(by), strata = all_of(variables), statistic = statistic, denominator = denominator, fmt_fun = fmt_fun, stat_label = stat_label ) # renaming columns ----------------------------------------------------------- df_result <- .rename_last_group_as_variable( df_result, by = by, variables = variables ) # return ard ----------------------------------------------------------------- df_result |> dplyr::mutate(context = "hierarchical") } #' @rdname ard_hierarchical #' @export ard_hierarchical_count.data.frame <- function(data, variables, by = dplyr::group_vars(data), fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_hierarchical_count(fmt_fn)", with = "ard_hierarchical_count(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_tabulate( data = data, variables = "...ard_dummy_for_counting...", by = all_of(by), strata = all_of(variables), statistic = everything() ~ "n", fmt_fun = fmt_fun, stat_label = stat_label ) |> .rename_last_group_as_variable(by = by, variables = variables) |> dplyr::mutate(context = "hierarchical_count") |> as_card() } #' Rename Last Group to Variable #' #' In the `ard_hierarchical*()` functions, the last grouping variable is #' renamed to `variable` and `variable_level` before being returned. #' #' @param df_result (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' data <- data.frame(x = 1, y = 2, group1 = 3, group2 = 4) #' #' cards:::.rename_last_group_as_variable(data, by = "ARM", variables = "AESOC") .rename_last_group_as_variable <- function(df_result, by, variables) { df_result |> dplyr::select(-all_ard_variables()) |> dplyr::rename( variable = all_ard_group_n(n = length(c(by, variables)), types = "names"), variable_level = all_ard_group_n( n = length(c(by, variables)), types = "levels" ) ) } cards/R/import-standalone-tibble.R0000644000176200001440000000230315003556603016572 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.R0000644000176200001440000002130415113466401012624 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_fun() #' #' 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_fun(variables = c("AGE", "BMIBL"), stat_names = "sd", fmt_fun = \(x) "xx.xx") |> #' apply_fmt_fun() 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_fun = 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_fun = 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_fun = 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/ard_tabulate_value.R0000644000176200001440000001157115050667010015522 0ustar liggesusers#' Tabulate Value ARD #' #' Tabulate an Analysis Results Data (ARD) for dichotomous or a specified value. #' #' @inheritParams ard_tabulate #' @param value (named `list`)\cr #' named list of 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_tabulate_value #' #' @inheritSection ard_tabulate Denominators #' #' @examples #' ard_tabulate_value(mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4)) #' #' mtcars |> #' dplyr::group_by(vs) |> #' ard_tabulate_value( #' variables = c(cyl, am), #' value = list(cyl = 4), #' statistic = ~"p" #' ) NULL #' @rdname ard_tabulate_value #' @export ard_tabulate_value <- function(data, ...) { check_not_missing(data) UseMethod("ard_tabulate_value") } #' @rdname ard_tabulate_value #' @export ard_tabulate_value.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_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_tabulate_value(fmt_fn)", with = "ard_tabulate_value(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_tabulate_value.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_tabulate( data = data, variables = all_of(variables), by = {{ by }}, strata = {{ strata }}, statistic = statistic, denominator = denominator, fmt_fun = fmt_fun, 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 = "tabulate_value") } #' Perform Value Checks #' #' Check the validity of the values passed in `ard_tabulate_value(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/eval_capture_conditions.R0000644000176200001440000001204415003556603016601 0ustar liggesusers#' Evaluate and Capture Conditions #' #' @description #' #' **`eval_capture_conditions()`** #' #' Evaluates an expression while also capturing error and warning conditions. #' Function always returns a named list `list(result=, warning=, error=)`. #' If there are no errors or warnings, those elements will be `NULL`. #' If there is an error, the result element will be `NULL`. #' #' Messages are neither saved nor printed to the console. #' #' Evaluation is done via [`rlang::eval_tidy()`]. If errors and warnings are produced #' using the `{cli}` package, the messages are processed with `cli::ansi_strip()` #' to remove styling from the message. #' #' **`captured_condition_as_message()`/`captured_condition_as_error()`** #' #' These functions take the result from `eval_capture_conditions()` and return #' errors or warnings as either messages (via `cli::cli_inform()`) or #' errors (via `cli::cli_abort()`). These functions handle cases where the #' condition messages may include curly brackets, which would typically cause #' issues when processed with the `cli::cli_*()` functions. #' #' Functions return the `"result"` from `eval_capture_conditions()`. #' #' @inheritParams rlang::eval_tidy #' @inheritParams cli::cli_abort #' @param x (`captured_condition`)\cr #' a captured condition created by `eval_capture_conditions()`. #' @param type (`string`)\cr #' the type of condition to return. Must be one of `'error'` or `'warning'`. #' @param message (`character`)\cr #' message passed to `cli::cli_inform()` or `cli::cli_abort()`. The condition #' being printed is saved in an object named `condition`, which should be #' included in this message surrounded by curly brackets. #' @param call (`environment`)\cr #' Execution environment of currently running function. Default is #' `get_cli_abort_call()`. #' @return a named list #' @name eval_capture_conditions #' #' @examples #' # function executes without error or warning #' eval_capture_conditions(letters[1:2]) #' #' # an error is thrown #' res <- eval_capture_conditions(stop("Example Error!")) #' res #' captured_condition_as_message(res) #' #' # if more than one warning is returned, all are saved #' eval_capture_conditions({ #' warning("Warning 1") #' warning("Warning 2") #' letters[1:2] #' }) #' #' # messages are not printed to the console #' eval_capture_conditions({ #' message("A message!") #' letters[1:2] #' }) NULL #' @rdname eval_capture_conditions #' @export eval_capture_conditions <- function(expr, data = NULL, env = caller_env()) { # IF WE EVER NEED TO REWORK/DEBUG REVIEW THE ADVANCED R CONDITIONS CHAPTER # https://adv-r.hadley.nz/conditions.html#conditions # initialize empty list to return lst_result <- list(result = NULL, warning = NULL, error = NULL) # tryCatch() saves error messages # withCallingHandlers() saves the warnings # invokeRestart() suppresses the printing of warnings when code is resumed tryCatch( withCallingHandlers( expr = { lst_result[["result"]] <- suppressMessages(eval_tidy({{ expr }}, data = data, env = env)) }, warning = function(w) { lst_result[["warning"]] <<- # using `c()` to capture all warnings c(lst_result[["warning"]], conditionMessage(w) |> cli::ansi_strip()) invokeRestart("muffleWarning") } ), error = function(e) { lst_result[["error"]] <<- conditionMessage(e) |> cli::ansi_strip() } ) # return named list of results lst_result %>% structure(., class = c("captured_condition", class(.))) } #' @rdname eval_capture_conditions #' @export captured_condition_as_message <- function(x, message = c("The following {type} occured:", "x" = "{condition}" ), type = c("error", "warning"), envir = rlang::current_env()) { check_class(x, "captured_condition") type <- rlang::arg_match(type) # if error/warning is empty, return x invisibly if (is_empty(x[[type]])) return(x[["result"]]) # styler: off condition <- x[[type]] cli::cli_inform(message = message, .envir = envir) x[["result"]] } #' @rdname eval_capture_conditions #' @export captured_condition_as_error <- function(x, message = c("The following {type} occured:", "x" = "{condition}" ), type = c("error", "warning"), call = get_cli_abort_call(), envir = rlang::current_env()) { check_class(x, "captured_condition") type <- rlang::arg_match(type) # if error/warning is empty, return x invisibly if (is_empty(x[[type]])) return(x[["result"]]) # styler: off condition <- x[[type]] cli::cli_abort(message = message, call = call, .envir = envir) } cards/R/unlist_ard_columns.R0000644000176200001440000000450315050667010015600 0ustar liggesusers#' Unlist ARD Columns #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' or any data frame #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to unlist. Default is #' `c(where(is.list), -any_of(c("warning", "error", "fmt_fun")))`. #' @param fill (scalar)\cr #' scalar to fill NULL values with before unlisting (if they are present). #' Default is `NA`. #' @param fct_as_chr (scalar `logical`)\cr #' When `TRUE`, factor elements will be converted to character before unlisting. #' When the column being unlisted contains mixed types of classes, the #' factor elements are often converted to the underlying integer value instead #' of retaining the label. Default is `TRUE`. #' #' #' @returns a data frame #' @export #' #' @examples #' ADSL |> #' ard_tabulate(by = ARM, variables = AGEGR1) |> #' apply_fmt_fun() |> #' unlist_ard_columns() #' #' ADSL |> #' ard_summary(by = ARM, variables = AGE) |> #' apply_fmt_fun() |> #' unlist_ard_columns() unlist_ard_columns <- function(x, columns = c(where(is.list), -any_of(c("warning", "error", "fmt_fun"))), fill = NA, fct_as_chr = TRUE) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_data_frame(x) process_selectors(x, columns = {{ columns }}) check_scalar(fill) check_scalar_logical(fct_as_chr) # first replace any NULL values with the fill value -------------------------- if (isTRUE(fct_as_chr)) { x <- x |> dplyr::mutate( across( all_of(columns), ~ map(., \(value) { if (inherits(value, "factor")) value <- as.character(value) # styler: off value %||% .env$fill }) ) ) } else { x <- x |> dplyr::mutate( across(all_of(columns), ~ map(., \(value) value %||% .env$fill)) ) } # unlist the columns --------------------------------------------------------- for (var in columns) { var_unlisted <- unlist(x[[var]]) if (length(var_unlisted) != length(x[[var]])) { cli::cli_inform("Cannot unlist column {.val {var}}.") next } x[[var]] <- var_unlisted } # return unlisted object ----------------------------------------------------- x } cards/R/utils.R0000644000176200001440000000436715003556603013047 0ustar liggesusers#' ARD-flavor of unique() #' #' Essentially a wrapper for `unique(x) |> sort()` with `NA` levels removed. #' For factors, all levels are returned even if they are unobserved. #' Similarly, logical vectors always return `c(TRUE, FALSE)`, even if #' both levels are not observed. #' #' @param x (`any`)\cr #' a vector #' #' @return a vector #' @keywords internal #' #' @examples #' cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters)) #' #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE)) #' #' cards:::.unique_and_sorted(c(5, 5:1)) .unique_and_sorted <- function(x, useNA = c("no", "always")) { # styler: off useNA <- match.arg(useNA) # if a factor return a factor that includes the same levels (including unobserved levels) if (inherits(x, "factor")) { return( factor( if (useNA == "no") levels(x) else c(levels(x), NA_character_), levels = levels(x) ) ) } if (inherits(x, "logical")) { if (useNA == "no") return(c(FALSE, TRUE)) else return(c(FALSE, TRUE, NA)) } # otherwise, return a simple unique and sort of the vector if (useNA == "no") return(unique(x) |> sort()) else return(unique(x) |> sort() |> c(NA)) # styler: on } #' Named List Predicate #' #' A predicate function to check whether input is a named list and _not_ a data frame. #' #' @param x (`any`)\cr #' object to check #' #' @return a logical #' @keywords internal #' #' @examples #' cards:::.is_named_list(list(a = 1:3)) .is_named_list <- function(x, allow_df = FALSE) { if (isFALSE(allow_df)) { return(is.list(x) && is_named(x) && !is.data.frame(x)) } if (isTRUE(allow_df)) { return(is.list(x) && is_named(x)) } } #' A list_flatten()-like Function #' #' Function operates similarly to `purrr::list_flatten(x, name_spec = "{inner}")`. #' #' @param x (named `list`)\cr #' a named list #' #' @return a named list #' @keywords internal #' #' @examples #' x <- list(a = 1, b = list(b1 = 2, b2 = 3), c = list(c1 = 4, c2 = list(c2a = 5))) #' #' cards:::.purrr_list_flatten(x) .purrr_list_flatten <- function(x) { ret <- list() for (i in seq_along(x)) { if (.is_named_list(x[[i]])) { ret <- append(ret, values = x[[i]]) } else { ret <- append(ret, values = x[i]) } } ret } cards/R/replace_null_statistic.R0000644000176200001440000000331115050667010016424 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_summary( #' 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.R0000644000176200001440000001613015113340127021303 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-check_pkg_installed.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "check_pkg_installed") # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-check_pkg_installed.R # last-updated: 2025-10-03 # license: https://unlicense.org # dependencies: standalone-cli_call_env.R # imports: [rlang, dplyr, tidyr] # --- # # This file provides functions to check package installation. # # ## Changelog # 2025-02-03 # - `get_pkg_dependencies()` was updated to use base r equivalents for `str_extract()` and `str_remove_all()`. # # 2025-10-03 # - `skip_if_pkg_not_installed()` was added. # 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`. #' #' - `skip_if_pkg_not_installed()` checks whether packages are installed (with the minimum required version) #' and skips tests if any are not installed. #' #' @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, call = call ) } #' @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 ) } #' @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("Imports", "Depends", "Suggests", "Enhances", "LinkingTo")) ) |> tidyr::pivot_longer(cols = dplyr::everything(), names_to = NULL, values_to = "pkg") |> tidyr::separate_longer_delim(dplyr::everything(), delim = ",") |> dplyr::mutate( pkg = trimws( x = gsub(x = .data$pkg, pattern = "\\s+", replacement = " "), which = "both", whitespace = "[ \t\r\n]" ) ) } .empty_pkg_deps_df <- function() { dplyr::tibble(pkg = 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 res <- get_pkg_dependencies(ref, lib.loc = lib.loc) |> dplyr::filter(grepl(paste0(paste0(.env$pkg, "(\\s|$)"), collapse = "|"), .data$pkg)) # supplement df with pkgs that may not be proper deps of the reference package (these pkgs don't have min versions) pkg_add <- which(sapply(pkg, \(x) !grepl(x, paste0(res$pkg, collapse = "|")))) |> names() res |> dplyr::full_join(dplyr::tibble(pkg = pkg_add), by = "pkg") } skip_if_pkg_not_installed <- function(pkg, ref = utils::packageName()) { pkg_deps <- get_min_version_required(pkg, ref = ref) for (p in pkg_deps$pkg) { pkg_installed <- rlang::is_installed(p) if (!pkg_installed) { # skip if any required package is not installed testthat::skip(message = paste( "Required package", shQuote(p, type = "sh"), "is not installed" )) } } invisible() } # nocov end # styler: on cards/R/import-standalone-stringr.R0000644000176200001440000001075715003556603017035 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.R0000644000176200001440000001663615113466401013642 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 `r lifecycle::badge("deprecated")` support for `.shuffle = TRUE` #' has been removed. #' @param .total_n (`logical`)\cr #' logical indicating whether to include of `ard_total_n()` in the returned ARD. #' @param .by_stats (`logical`)\cr #' logical indicating whether to include overall stats of the `by` variables in the returned ARD. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_stack( #' data = ADSL, #' ard_tabulate(variables = "AGEGR1"), #' ard_summary(variables = "AGE"), #' .by = "ARM", #' .overall = TRUE, #' .attributes = TRUE #' ) #' #' ard_stack( #' data = ADSL, #' ard_tabulate(variables = "AGEGR1"), #' ard_summary(variables = "AGE"), #' .by = "ARM" #' ) #' ard_stack <- function(data, ..., .by = NULL, .overall = FALSE, .missing = FALSE, .attributes = FALSE, .total_n = FALSE, .shuffle = FALSE, .by_stats = TRUE) { 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) check_scalar_logical(.by_stats) 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) && isTRUE(.by_stats)) { ard_full <- bind_ard( ard_list, ard_tabulate( 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) # append attributes ---------------------------------------------------------- attr(ard_full, "args") <- list( by = .by ) # shuffle -------------------------------------------------------------------- if (isTRUE(.shuffle)) { lifecycle::deprecate_stop( when = "0.7.0", what = "cards::ard_stack(.shuffle)" ) } # 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_tabulate(variables = "AGEGR1"), #' ard_summary(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_stack_hierarchical.R0000644000176200001440000004220715113466401016331 0ustar liggesusers#' Stacked Hierarchical ARD Statistics #' #' @description #' Use these functions to calculate multiple summaries of nested or hierarchical data #' in a single call. #' #' - `ard_stack_hierarchical()`: Calculates *rates* of events (e.g. adverse events) #' utilizing the `denominator` and `id` arguments to identify the rows in `data` #' to include in each rate calculation. #' #' - `ard_stack_hierarchical_count()`: Calculates *counts* of events utilizing #' all rows for each tabulation. #' #' @section Subsetting Data for Rate Calculations: #' #' To calculate event rates, the `ard_stack_hierarchical()` function identifies #' rows to include in the calculation. #' First, the primary data frame is sorted by the columns identified in #' the `id`, `by`, and `variables` arguments. #' #' As the function cycles over the variables specified in the `variables` argument, #' the data frame is grouped by `id`, `intersect(by, names(denominator))`, and `variables` #' utilizing the last row within each of the groups. #' #' For example, if the call is #' `ard_stack_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), id = USUBJID)`, #' then we'd first subset ADAE to be one row within the grouping `c(USUBJID, AESOC, AEDECOD)` #' to calculate the event rates in `'AEDECOD'`. We'd then repeat and #' subset ADAE to be one row within the grouping `c(USUBJID, AESOC)` #' to calculate the event rates in `'AESOC'`. #' #' @section Overall Argument: #' When we set `overall=TRUE`, we wish to re-run our calculations removing the #' stratifying columns. For example, if we ran the code below, we results would #' include results with the code chunk being re-run with `by=NULL`. #' #' ```r #' ard_stack_hierarchical( #' data = ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL, #' id = USUBJID, #' 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, #' id = USUBJID, #' 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 `r lifecycle::badge("deprecated")` support for `.shuffle = TRUE` #' has been removed. #' @param by_stats (`logical`)\cr #' logical indicating whether to include overall stats of the `by` variables in the returned ARD. #' #' @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, #' id = USUBJID #' ) #' #' ard_stack_hierarchical_count( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL #' ) 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, by_stats = TRUE ) { 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, by_stats = by_stats ) } #' @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, by_stats = TRUE ) { 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, by_stats = by_stats ) } 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, by_stats = 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_scalar_logical(by_stats) # 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, ] } } # keep only `id` and `by` variables in `denominator` if (is.data.frame(denominator)) { denominator <- denominator[, intersect(c(id, by), names(denominator)), drop = FALSE] } # 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(by_stats) && is.data.frame(denominator) && !is_empty(intersect(by, names(denominator))) ) { lst_results <- lst_results |> append( ard_tabulate( 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, by_stats = 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() # append attributes used for sorting/filtering ------------------------------- attr(result, "args") <- list( by = by, variables = variables, include = include ) # sort ARD alphanumerically -------------------------------------------------- result <- result |> sort_ard_hierarchical(sort = "alphanumeric") # shuffle if requested ------------------------------------------------------- if (isTRUE(shuffle)) { lifecycle::deprecate_stop( when = "0.7.0", what = "cards::ard_stack_hierarchical(shuffle)" ) } # return final result -------------------------------------------------------- result |> as_card() } # this function calculates either the counts or the rates of the events .run_hierarchical_fun <- function( data, variables, by, denominator, id, statistic ) { if (is_empty(id)) { ard_hierarchical_count( data = data, variables = all_of(variables), by = all_of(by) ) } else { ard_hierarchical( data = data |> dplyr::slice_tail( n = 1L, by = all_of(c(id, intersect(by, names(denominator)), variables)) ), variables = all_of(variables), by = all_of(by), denominator = denominator, id = all_of(id), statistic = statistic ) } } cards/R/ard_attributes.R0000644000176200001440000000665215113466401014720 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_fun = ifelse(.data$stat_name %in% "label", list(as.character), list(NULL)), warning = list(NULL), error = list(NULL) ) |> cards::tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' @rdname ard_attributes #' @export ard_attributes.default <- function(data, ...) { set_cli_abort_call() cli::cli_abort("There is no method for objects of class {.cls {class(data)}}.", call = get_cli_abort_call()) } cards/R/import-standalone-cli_call_env.R0000644000176200001440000000331615066623153017754 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-cli_call_env.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "cli_call_env") # ---------------------------------------------------------------------- # # --- # 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.R0000644000176200001440000000115015003556603015673 0ustar liggesusers#' Defaults for Statistical Arguments #' #' Returns a named list of statistics labels #' #' @return named list #' @export #' #' @examples #' # stat labels #' default_stat_labels() default_stat_labels <- function() { list( mean = "Mean", sd = "SD", var = "Variance", median = "Median", p25 = "Q1", p75 = "Q3", min = "Min", max = "Max", n = "n", N = "N", p = "%", n_cum = "Cumulative n", p_cum = "Cumulative %", N_obs = "Vector Length", N_miss = "N Missing", N_nonmiss = "N Non-missing", p_miss = "% Missing", p_nonmiss = "% Non-missing" ) } cards/R/ard_mvsummary.R0000644000176200001440000001152715050667010014566 0ustar liggesusers#' Multivariate ARD Summaries #' #' Function is similar to [ard_summary()], but allows for more complex, multivariate #' summaries. While `ard_summary(statistic)` only allows for a univariable #' function, `ard_mvsummary(statistic)` can handle more complex data summaries. #' #' @inheritParams ard_summary #' @param statistic ([`formula-list-selector`][syntax])\cr #' The form of the statistics argument is identical to `ard_summary(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_mvsummary #' #' @examples #' # example how to mimic behavior of `ard_summary()` #' ard_mvsummary( #' 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_mvsummary( #' variables = "AGE", #' statistic = list(AGE = list(means = grand_mean)) #' ) NULL #' @rdname ard_mvsummary #' @export ard_mvsummary <- function(data, ...) { check_not_missing(data) UseMethod("ard_mvsummary") } #' @rdname ard_mvsummary #' @export ard_mvsummary.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic, fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ...) { set_cli_abort_call() check_dots_used() # deprecated args ------------------------------------------------------------ if (lifecycle::is_present(fmt_fn)) { lifecycle::deprecate_soft( when = "0.6.1", what = "ard_summary(fmt_fn)", with = "ard_summary(fmt_fun)" ) fmt_fun <- fmt_fn } # 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_summary()` # 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_summary( data = data, variables = all_of(variables), by = {{ by }}, strata = {{ strata }}, statistic = statistic, fmt_fun = fmt_fun, stat_label = stat_label ) |> dplyr::mutate(context = "mvsummary") } cards/R/data.R0000644000176200001440000000040215034313244012576 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" #' @rdname adam "ADLB" cards/R/filter_ard_hierarchical.R0000644000176200001440000004370215046416237016521 0ustar liggesusers#' Filter Stacked Hierarchical ARDs #' #' @description `r lifecycle::badge('experimental')`\cr #' #' This function is used to filter stacked hierarchical ARDs. #' #' For the purposes of this function, we define a "variable group" as a combination of ARD rows #' grouped by the combination of all their variable levels, but excluding any `by` variables. #' #' @param x (`card`)\cr #' a stacked hierarchical ARD of class `'card'` created using [`ard_stack_hierarchical()`] or #' [`ard_stack_hierarchical_count()`]. #' @param filter (`expression`)\cr #' an expression that is used to filter variable groups of the hierarchical ARD. See the #' Details section below. #' @param var ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' hierarchy variable from `x` to perform filtering on. If `NULL`, the last hierarchy variable #' from `x` (`dplyr::last(attributes(x)$args$variables)`) will be used. #' @param keep_empty (scalar `logical`)\cr #' Logical argument indicating whether to retain summary rows corresponding to hierarchy #' sections that have had all rows filtered out. Default is `FALSE`. #' @param quiet (`logical`)\cr #' logical indicating whether to suppress any messaging. Default is `FALSE`. #' #' @details #' The `filter` argument can be used to filter out variable groups of a hierarchical #' ARD which do not meet the requirements provided as an expression. #' Variable groups can be filtered on the values of any of the possible #' statistics (`n`, `p`, and `N`) provided they are included at least once #' in the ARD, as well as the values of any `by` variables. #' #' Additionally, filters can be applied on individual levels of the `by` variable via the #' `n_XX`, `N_XX`, and `p_XX` statistics, where each `XX` represents the index of the `by` #' variable level to select the statistic from. For example, `filter = n_1 > 5` will check #' whether `n` values for the first level of `by` are greater than 5 in each row group. #' #' Overall statistics for each row group can be used in filters via the `n_overall`, `N_overall`, #' and `p_overall` statistics. If the ARD is created with parameter `overall=TRUE`, then these #' overall statistics will be extracted directly from the ARD, otherwise the statistics will be #' derived where possible. If `overall=FALSE`, then `n_overall` can only be derived if the `n` #' statistic is present in the ARD for the filter variable, `N_overall` if the `N` statistic is #' present for the filter variable, and `p_overall` if both the `n` and `N` statistics are #' present for the filter variable. #' #' By default, filters will be applied at the level of the innermost hierarchy variable, i.e. #' the last variable supplied to `variables`. If filters should instead be applied at the level #' of one of the outer hierarchy variables, the `var` parameter can be used to select a different #' variable to filter on. When `var` is set to a different (outer) variable and a level of the #' variable does not meet the filtering criteria then the section corresponding to that variable #' level and all sub-sections within that section will be removed. #' #' To illustrate how the function works, consider the typical example below #' where the AE summaries are provided by treatment group. #' #' ```r #' ADAE |> #' dplyr::filter(AESOC == "GASTROINTESTINAL DISORDERS", #' AEDECOD %in% c("VOMITING", "DIARRHOEA")) |> #' ard_stack_hierarchical( #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL, #' id = USUBJID #' ) #' ``` #' #' |**SOC** / AE | Placebo | Xanomeline High Dose | Xanomeline Low Dose | #' |:------------------------------|----------:|----------------------:|---------------------:| #' |__GASTROINTESTINAL DISORDERS__ | 11 (13%) | 10 (12%) | 8 (9.5%) | #' |DIARRHOEA | 9 (10%) | 4 (4.8%) | 5 (6.0%) | #' |VOMITING | 3 (3.5%) | 7 (8.3%) | 3 (3.6%) | #' #' Filters are applied to the summary statistics of the innermost variable in the hierarchy by #' default---`AEDECOD` in this case. If we wanted to filter based on SOC rates instead of AE #' rates we could specify `var = AESOC` instead. #' If any of the summary statistics meet the filter requirement for any of the treatment groups, #' the entire row is retained. #' For example, if `filter = n >= 9` were passed, the criteria would be met for DIARRHOEA #' as the Placebo group observed 9 AEs and as a result the summary statistics for the other #' treatment groups would be retained as well. #' Conversely, no treatment groups' summary statistics satisfy the filter requirement #' for VOMITING so all rows associated with this AE would be removed. #' #' In addition to filtering on individual statistic values, filters can be applied #' across the treatment groups (i.e. across all `by` variable values) by using #' aggregate functions such as `sum()` and `mean()`. For simplicity, it is suggested to use #' the `XX_overall` statistics in place of `sum(XX)` in equivalent scenarios. For example, #' `n_overall` is equivalent to `sum(n)`. #' A value of `filter = sum(n) >= 18` (or `filter = n_overall >= 18`) retains AEs where the sum of #' the number of AEs across the treatment groups is greater than or equal to 18. #' #' If `filter = n_overall >= 18` and `var = AESOC` then all rows corresponding to an SOC with an #' overall rate less than 18 - including all AEs within that SOC - will be removed. #' #' If `ard_stack_hierarchical(overall=TRUE)` was run, the overall column is __not__ considered in #' any filtering except for `XX_overall` statistics, if specified. #' #' If `ard_stack_hierarchical(over_variables=TRUE)` was run, any overall statistics are kept regardless #' of filtering. #' #' Some examples of possible filters: #' - `filter = n > 5`: keep AEs where one of the treatment groups observed more than 5 AEs #' - `filter = n == 2 & p < 0.05`: keep AEs where one of the treatment groups observed exactly 2 #' AEs _and_ one of the treatment groups observed a proportion less than 5% #' - `filter = n_overall >= 4`: keep AEs where there were 4 or more AEs observed across the treatment groups #' - `filter = mean(n) > 4 | n > 3`: keep AEs where the mean number of AEs is 4 or more across the #' treatment groups _or_ one of the treatment groups observed more than 3 AEs #' - `filter = n_2 > 2`: keep AEs where the `"Xanomeline High Dose"` treatment group (second `by` variable #' level) observed more than 2 AEs #' #' @return an ARD data frame of class 'card' #' @seealso [sort_ard_hierarchical()] #' @name filter_ard_hierarchical #' #' @examplesIf (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) #' # create a base AE ARD #' ard <- ard_stack_hierarchical( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL, #' id = USUBJID, #' overall = TRUE #' ) #' #' # Example 1 ---------------------------------- #' # Keep AEs from TRTA groups where more than 3 AEs are observed across the group #' filter_ard_hierarchical(ard, sum(n) > 3) #' #' # Example 2 ---------------------------------- #' # Keep AEs where at least one level in the TRTA group has more than 3 AEs observed #' filter_ard_hierarchical(ard, n > 3) #' #' # Example 3 ---------------------------------- #' # Keep AEs that have an overall prevalence of greater than 5% #' filter_ard_hierarchical(ard, sum(n) / sum(N) > 0.05) #' #' # Example 4 ---------------------------------- #' # Keep AEs that have a difference in prevalence of greater than 3% between reference group with #' # `TRTA = "Xanomeline High Dose"` and comparison group with `TRTA = "Xanomeline Low Dose"` #' filter_ard_hierarchical(ard, abs(p_2 - p_3) > 0.03) #' #' # Example 5 ---------------------------------- #' # Keep AEs from SOCs that have an overall prevalence of greater than 20% #' filter_ard_hierarchical(ard, p_overall > 0.20, var = AESOC) NULL #' @rdname filter_ard_hierarchical #' @export filter_ard_hierarchical <- function(x, filter, var = NULL, keep_empty = FALSE, quiet = FALSE) { set_cli_abort_call() # check and process inputs --------------------------------------------------------------------- check_not_missing(x) check_not_missing(filter) check_scalar_logical(keep_empty) check_scalar_logical(quiet) check_class(x, "card") if (!"args" %in% names(attributes(x))) { cli::cli_abort( paste( "Filtering is only available for stacked hierarchical ARDs created using", "{.fun ard_stack_hierarchical} or {.fun ard_stack_hierarchical_count}." ), call = get_cli_abort_call() ) } ard_args <- attributes(x)$args by <- ard_args$by # get and check name of filtering variable process_selectors( as.list(ard_args$variables) |> data.frame() |> stats::setNames(ard_args$variables), var = {{ var }} ) if (is_empty(var)) var <- dplyr::last(ard_args$variables) check_scalar(var, message = "Only one variable can be selected as {.arg var}.") if (!var %in% ard_args$include) { cli::cli_abort( paste( "No statistics available in the ARD for variable {.val {var}}. In order to filter on {.val {var}}", "it must be specified in the {.arg include} argument when the ARD is created." ), call = get_cli_abort_call() ) } which_var <- which(ard_args$variables == var) # check filter input is valid filter <- enquo(filter) if (!quo_is_call(filter)) { cli::cli_abort( "The {.arg filter} argument must be an expression.", call = get_cli_abort_call() ) } # attributes and total n not filtered - appended to bottom of filtered ARD has_attr <- "attributes" %in% x$context | "total_n" %in% x$context if (has_attr) { x_attr <- x |> dplyr::filter(.data$context %in% c("attributes", "total_n")) x <- x |> dplyr::filter(!.data$context %in% c("attributes", "total_n")) } # remove "overall" data from `x` if (is_empty(by)) { x_overall <- x } else { is_overall <- apply(x, 1, function(x) !isTRUE(any(x %in% by))) x_overall <- x[is_overall, ] x <- x[!is_overall, ] } no_overall <- nrow(x_overall) == 0 # check that any column-wise/overall statistics in filter are valid filter_vars <- all.vars(filter) by_cols <- if (!is_empty(by)) c("group1", "group1_level") else NULL valid_filter_vars <- unique(x$stat_name[x$variable == var]) if (!is_empty(by)) { by_lvls <- unique(stats::na.omit(unlist(x[["group1_level"]]))) overall_stats <- if (!no_overall) { unique(x_overall$stat_name) } else if (no_overall && !all(c("n", "N") %in% valid_filter_vars)) { setdiff(valid_filter_vars, "p") } else { valid_filter_vars } overall_stat_vars <- if (!is_empty(overall_stats)) paste(overall_stats, "overall", sep = "_") else NULL col_stat_vars <- paste(rep(valid_filter_vars, each = length(by_lvls)), seq_along(by_lvls), sep = "_") valid_filter_vars <- c(valid_filter_vars, col_stat_vars, overall_stat_vars, by) if (any(col_stat_vars %in% filter_vars) && !quiet) { by_ids <- cli::cli_vec( paste(paste("xx", seq_along(by_lvls), sep = "_"), paste0('"', by_lvls, '"'), sep = " = ") ) cli::cli_inform("When applying filters on specific levels of {.arg by} variable {.val {by}} {by_ids}.") } } if (!all(filter_vars %in% valid_filter_vars)) { var_miss <- setdiff(filter_vars, valid_filter_vars) cli::cli_abort( c( paste( "The expression provided as {.arg filter} includes condition{?s} for statistic{?s}", "{.val {var_miss}} which {?is/are} not present in the ARD and {?does/do} not", "correspond to any of the {.var by} variable levels." ), i = "Valid filter terms for variable {.val {var}} are: {.val {valid_filter_vars}}." ), call = get_cli_abort_call() ) } # reshape ARD so each stat is in its own column ------------------------------------------------ x_f <- x |> dplyr::mutate(idx = dplyr::row_number()) |> dplyr::select( all_ard_groups(), all_ard_variables(), "stat_name", "stat", "idx" ) |> tidyr::pivot_wider( id_cols = c(all_ard_groups(), all_ard_variables()), names_from = "stat_name", values_from = "stat", values_fn = unlist, unused_fn = list ) # apply filter --------------------------------------------------------------------------------- f_idx <- x_f |> dplyr::group_by(across(c( all_ard_groups(), all_ard_variables(), -all_of(by_cols) ))) |> dplyr::group_map(\(.df, .g) { # only filter rows for variable `var` if (.g$variable == var) { .df_all <- .df # allow filtering on values from a specific column if (!is_empty(by)) { # use `by` variable name as `group1_level` column name names(.df_all)[names(.df_all) == by_cols[c(FALSE, TRUE)]] <- by # process any column-wise or overall filters present if (any(c(col_stat_vars, overall_stat_vars) %in% filter_vars)) { # if specified, add column-wise statistics to filter on .df_col_stats <- if (any(col_stat_vars %in% filter_vars)) { .df_all |> dplyr::mutate(id_num = dplyr::row_number()) |> tidyr::pivot_wider( id_cols = c(all_ard_groups(), all_ard_variables()), names_from = "id_num", values_from = any_of(c("n", "N", "p")) ) } else { dplyr::tibble(group1 = by) } # add overall stats - derive values if overall=FALSE if (!no_overall) { .df_overall <- .g |> as_card() |> cards::rename_ard_groups_shift() .df_overall <- dplyr::left_join(.df_overall, x_overall, by = names(.df_overall)) } if ("n_overall" %in% filter_vars) { .df_col_stats$n_overall <- if (!no_overall) .df_overall$stat[.df_overall$stat_name == "n"][[1]] else sum(.df[["n"]]) } if ("N_overall" %in% filter_vars) { .df_col_stats$N_overall <- if (!no_overall) .df_overall$stat[.df_overall$stat_name == "N"][[1]] else sum(.df[["N"]]) } if ("p_overall" %in% filter_vars) { .df_col_stats$p_overall <- if (!no_overall) { .df_overall$stat[.df_overall$stat_name == "p"][[1]] } else { sum(.df[["n"]]) / sum(.df[["N"]]) } } .df_all <- dplyr::bind_rows(.df_all, .df_col_stats) } } # apply filter .df[["idx"]][any(eval_tidy(filter, data = .df_all), na.rm = TRUE)] } else { .df[["idx"]] } }) |> unlist() |> sort() x <- x[f_idx, ] # remove inner variable rows if `var` is an outer variable that does not meet the filter criteria if (which_var < length(ard_args$variables)) { var_gp_nm <- paste0("group", length(by) + which_var) # get `var` group variable name # get all combos of variables kept after filtering # keep only unique combos up to `var` group variable var_keep <- x |> dplyr::filter(.data$variable == var) |> dplyr::mutate( !!var_gp_nm := .data$variable, !!paste0(var_gp_nm, "_level") := .data$variable_level ) var_keep <- dplyr::distinct(var_keep[(1 + length(by) * 2):((length(by) + which_var) * 2)]) # track row indices x <- x |> dplyr::mutate(idx = dplyr::row_number()) # get row indices to exclude - all rows within `var` sections that have been removed f_idx_inner <- dplyr::anti_join( x[x[[var_gp_nm]] == var & !is.na(x[[var_gp_nm]]), ], var_keep, by = names(var_keep) ) |> dplyr::pull("idx") # filter out inner rows x <- x |> dplyr::filter(!.data$idx %in% f_idx_inner) |> dplyr::select(-"idx") } # remove summary rows from empty sections if requested if (!keep_empty && var != ard_args$variables[1] && length(ard_args$include) > 1) { cols <- ard_args$variables |> stats::setNames( x |> dplyr::select(all_ard_group_n(seq_along(ard_args$variables) + length(by), types = "names"), "variable") |> names() ) outer_cols <- utils::head(cols, -1) # if all inner rows filtered out, remove all summary rows - only overall/header rows left if (!dplyr::last(ard_args$variables) %in% x$variable) { # if no inner rows remain, remove all summary rows x <- x |> dplyr::filter(!.data$variable %in% outer_cols) } else { x_sum <- x |> dplyr::mutate(idx = dplyr::row_number()) |> # reformat current variable columns for filtering .ard_reformat_sort(by, cols) # check if each hierarchy section (from innermost to outermost) is empty and if so remove its summary row for (i in rev(seq_along(outer_cols))) { # get group keys of all non-empty sections x_gps <- x_sum |> # group by current and all previous grouping columns dplyr::group_by(dplyr::pick( any_of(cards::all_ard_group_n((1:i) + length(by))), any_of(cards::all_ard_variables()) )) |> dplyr::group_keys() |> dplyr::filter(!.data$variable %in% "..overall..") |> dplyr::select(any_of(cards::all_ard_group_n((1:i) + length(by)))) |> dplyr::distinct() # get indices of rows to remove (summary rows from empty sections) idx_rm <- x_sum |> dplyr::filter(.data[[names(cols)[i]]] %in% cols[i]) |> dplyr::anti_join(x_gps, by = names(x_gps)) |> dplyr::pull("idx") # remove summary rows from empty sections x_sum <- x_sum |> dplyr::filter(!.data$idx %in% idx_rm) } # filter out all empty summary rows idx_keep <- sort(x_sum$idx) x <- x[idx_keep, ] } } # if present, keep attributes at bottom of ARD if (has_attr) x <- dplyr::bind_rows(x, x_attr) as_card(x) } cards/R/cards-package.R0000644000176200001440000000050015027040570014352 0ustar liggesusers#' @keywords internal #' @import rlang #' @importFrom dplyr across #' @importFrom lifecycle deprecated "_PACKAGE" ## usethis namespace: start ## usethis namespace: end NULL utils::globalVariables(c(".", "!<-", "parse_expr<-")) release_bullets <- function() { c("Install package and re-build `pkgdown/index.Rmd`") } cards/R/tidy_as_ard.R0000644000176200001440000001057515050667010014164 0ustar liggesusers#' Build ARD from Tidier #' #' @description #' `r lifecycle::badge("questioning")`\cr #' *Function is questioning because we think a better solution may be `ard_summary()` + `ard_formals()`.* #' #' Function converts a model's one-row tidy data frame into an ARD structure. #' The tidied data frame must have been constructed with #' [eval_capture_conditions()]. #' #' This function is primarily for developers and few consistency checks have #' been included. #' #' @param lst_tidy (named `list`)\cr #' list of tidied results constructed with [eval_capture_conditions()], #' e.g. `eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())`. #' @param tidy_result_names (`character`)\cr #' character vector of column names expected by the #' tidier method. This is used to construct blank results in the event of an error. #' @param fun_args_to_record (`character`)\cr #' character vector of function argument names that are added to the ARD. #' @param formals (`pairlist`)\cr #' the results from `formals()`, e.g. `formals(fisher.test)`. #' This is used to get the default argument values from unspecified arguments. #' @param passed_args (named `list`)\cr #' named list of additional arguments passed to the modeling function. #' @param lst_ard_columns (named `list`)\cr #' named list of values that will be added to the ARD data frame. #' #' @return an ARD data frame of class 'card' #' @export #' @keywords internal #' #' @examples #' # example how one may create a fisher.test() ARD function #' my_ard_fishertest <- function(data, by, variable, ...) { #' # perform fisher test and format results ----------------------------------- #' lst_tidy_fisher <- #' eval_capture_conditions( #' # this manipulation is similar to `fisher.test(...) |> broom::tidy()` #' stats::fisher.test(x = data[[variable]], y = data[[by]], ...)[c("p.value", "method")] |> #' as.data.frame() #' ) #' #' # build ARD ------------------------------------------------------------------ #' tidy_as_ard( #' lst_tidy = lst_tidy_fisher, #' tidy_result_names = c("p.value", "method"), #' fun_args_to_record = #' c( #' "workspace", "hybrid", "hybridPars", "control", "or", #' "conf.int", "conf.level", "simulate.p.value", "B" #' ), #' formals = formals(stats::fisher.test), #' passed_args = dots_list(...), #' lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest") #' ) #' } #' #' my_ard_fishertest(mtcars, by = "am", variable = "vs") tidy_as_ard <- function(lst_tidy, tidy_result_names, fun_args_to_record = character(0L), formals = list(), passed_args = list(), lst_ard_columns) { set_cli_abort_call() # used argument values ------------------------------------------------------- lst_used_fun_args <- tryCatch( utils::modifyList( x = # missing() is TRUE if the arg is not specified, # not actually missing (ie it can still have its default value) if (missing(formals)) formals else formals[fun_args_to_record], val = passed_args, keep.null = TRUE ), error = function(e) list() ) # if there are results, put them in the ARD format --------------------------- if (!is.null(lst_tidy[["result"]])) { # combine results and function argument lst_all_results <- c(unclass(lst_tidy[["result"]]), lst_used_fun_args) } # if there was an error calculating results, tidy up what we can ------------- else { # combine empty results and function arguments lst_all_results <- utils::modifyList( x = rep_len( x = list(NULL), length.out = length(c(tidy_result_names, fun_args_to_record)) ) |> stats::setNames(nm = c(tidy_result_names, fun_args_to_record)), val = lst_used_fun_args, keep.null = TRUE ) } # add results to tibble ------------------------------------------------------ dplyr::tibble( stat_name = names(lst_all_results), stat = lst_all_results, fmt_fun = lapply(.data$stat, function(x) { switch(is.numeric(x), 1L ) }), warning = lst_tidy["warning"], error = lst_tidy["error"], !!!lst_ard_columns, ) |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } cards/R/reexports.R0000644000176200001440000000145415003556603013734 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/import-standalone-purrr.R0000644000176200001440000001305415003556603016510 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: r-lib/rlang # file: standalone-purrr.R # last-updated: 2023-02-23 # license: https://unlicense.org # imports: rlang # --- # # This file provides a minimal shim to provide a purrr-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # # 2023-02-23: # * Added `list_c()` # # 2022-06-07: # * `transpose()` is now more consistent with purrr when inner names # are not congruent (#1346). # # 2021-12-15: # * `transpose()` now supports empty lists. # # 2021-05-21: # * Fixed "object `x` not found" error in `imap()` (@mgirlich) # # 2020-04-14: # * Removed `pluck*()` functions # * Removed `*_cpl()` functions # * Used `as_function()` to allow use of `~` # * Used `.` prefix for helpers # # nocov start map <- function(.x, .f, ...) { .f <- as_function(.f, env = global_env()) lapply(.x, .f, ...) } walk <- function(.x, .f, ...) { map(.x, .f, ...) invisible(.x) } map_lgl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, logical(1), ...) } map_int <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, integer(1), ...) } map_dbl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, double(1), ...) } map_chr <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, character(1), ...) } .rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { .f <- as_function(.f, env = global_env()) out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) names(out) <- names(.x) out } map2 <- function(.x, .y, .f, ...) { .f <- as_function(.f, env = global_env()) out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) if (length(out) == length(.x)) { set_names(out, names(.x)) } else { set_names(out, NULL) } } map2_lgl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "logical") } map2_int <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "integer") } map2_dbl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "double") } map2_chr <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "character") } imap <- function(.x, .f, ...) { map2(.x, names(.x) %||% seq_along(.x), .f, ...) } pmap <- function(.l, .f, ...) { .f <- as.function(.f) args <- .rlang_purrr_args_recycle(.l) do.call("mapply", c( FUN = list(quote(.f)), args, MoreArgs = quote(list(...)), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } .rlang_purrr_args_recycle <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) args } keep <- function(.x, .f, ...) { .x[.rlang_purrr_probe(.x, .f, ...)] } discard <- function(.x, .p, ...) { sel <- .rlang_purrr_probe(.x, .p, ...) .x[is.na(sel) | !sel] } map_if <- function(.x, .p, .f, ...) { matches <- .rlang_purrr_probe(.x, .p) .x[matches] <- map(.x[matches], .f, ...) .x } .rlang_purrr_probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { .p <- as_function(.p, env = global_env()) map_lgl(.x, .p, ...) } } compact <- function(.x) { Filter(length, .x) } transpose <- function(.l) { if (!length(.l)) { return(.l) } inner_names <- names(.l[[1]]) if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) .l <- map(.l, function(x) { if (is.null(names(x))) { set_names(x, inner_names) } else { x } }) } # This way missing fields are subsetted as `NULL` instead of causing # an error .l <- map(.l, as.list) map(fields, function(i) { map(.l, .subset2, i) }) } every <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (!rlang::is_true(.p(.x[[i]], ...))) { return(FALSE) } } TRUE } some <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (rlang::is_true(.p(.x[[i]], ...))) { return(TRUE) } } FALSE } negate <- function(.p) { .p <- as_function(.p, env = global_env()) function(...) !.p(...) } reduce <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init) } reduce_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE) } accumulate <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init, accumulate = TRUE) } accumulate_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) } detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(.x[[i]]) } } NULL } detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(i) } } 0L } .rlang_purrr_index <- function(x, right = FALSE) { idx <- seq_along(x) if (right) { idx <- rev(idx) } idx } list_c <- function(x) { inject(c(!!!x)) } # nocov end cards/R/rename_ard_columns.R0000644000176200001440000001112115050667010015523 0ustar liggesusers#' Rename ARD Variables #' #' Rename the grouping and variable columns to their original column names. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to rename, e.g. selecting columns `c('group1', 'group2', 'variable')` #' will rename `'group1_level'` to the name of the variable found in `'group1'`. #' When, for example, the `'group1_level'` does not exist, the values of the #' new column are filled with the values in the `fill` argument. #' Default is `c(all_ard_groups("names"), all_ard_variables("names"))`. #' @param fill (scalar/glue)\cr #' a scalar to fill column values when the variable does not have levels. #' If a character is passed, then it is processed with `glue::glue()` #' where the `colname` element is available to inject into the string, #' e.g. `'Overall {colname}'` may resolve to `'Overall AGE'` for an AGE column. #' Default is `'{colname}'`. #' @param unlist `r lifecycle::badge("deprecated")` #' #' @return data frame #' @export #' #' @examples #' # Example 1 ---------------------------------- #' ADSL |> #' ard_tabulate(by = ARM, variables = AGEGR1) |> #' apply_fmt_fun() |> #' rename_ard_columns() |> #' unlist_ard_columns() #' #' # Example 2 ---------------------------------- #' ADSL |> #' ard_summary(by = ARM, variables = AGE) |> #' apply_fmt_fun() |> #' rename_ard_columns(fill = "Overall {colname}") |> #' unlist_ard_columns() rename_ard_columns <- function(x, columns = c(all_ard_groups("names"), all_ard_variables("names")), fill = "{colname}", unlist = NULL) { # check inputs --------------------------------------------------------------- if (!missing(unlist)) { lifecycle::deprecate_warn( when = "0.6.0", what = "cards::rename_ard_columns(unlist)", with = "unlist_ard_columns()", details = "Argument has been ignored." ) } set_cli_abort_call() check_not_missing(x) check_class(x, "card") process_selectors(x, columns = {{ columns }}) check_scalar(fill) if (!is_empty(setdiff(columns, dplyr::select(x, all_ard_groups("names"), all_ard_variables("names")) |> names()))) { bad_columns <- setdiff(columns, dplyr::select(x, all_ard_groups("names"), all_ard_variables("names")) |> names()) cli::cli_abort( c("The {.arg column} argument may only select columns using {.code all_ard_groups(\"names\")} and {.code all_ard_variables(\"names\")}", "i" = "{cli::qty(bad_columns)} Column{?s} {.val {bad_columns}} {?is/are} not a valid selection." ), call = get_cli_abort_call() ) } # separate selected names from levels column_names <- x |> dplyr::select( intersect( c(all_ard_groups("names"), all_ard_variables("names")), all_of(columns) ) ) |> names() all_new_names <- x[column_names] |> unlist() |> unique() |> discard(is.na) |> unname() if (any(all_new_names %in% names(x))) { protected_names <- all_new_names[all_new_names %in% names(x)] cli::cli_abort( "New column name(s) {.val {protected_names}} cannot be added, because they are already present.", call = get_cli_abort_call() ) } x |> dplyr::mutate(...ard_row_order... = dplyr::row_number()) |> dplyr::group_by(dplyr::pick(all_of(column_names))) |> dplyr::group_map( \(df, df_group) { lst_group <- as.list(df_group) |> discard(is.na) names_group <- names(lst_group) # cycle over all columns for (v in names_group) { # if level column does not exist, adding it if (!paste0(v, "_level") %in% names(df)) { df[[paste0(v, "_level")]] <- list(NULL) } fill_glued <- case_switch( is.character(fill) ~ glue::glue_data(.x = lst_group[v] |> set_names("colname"), fill) |> as.character(), .default = fill ) # replace null values df[[lst_group[[v]]]] <- df[[paste0(v, "_level")]] |> map(~ .x %||% fill_glued) df[[paste0(v, "_level")]] <- NULL } df |> dplyr::select(-any_of(c(columns, paste0(columns, "_level")))) } ) |> dplyr::bind_rows() |> dplyr::arrange(!!sym("...ard_row_order...")) |> dplyr::relocate(all_of(all_new_names), .before = 1L) |> dplyr::select(-"...ard_row_order...") |> dplyr::mutate( # replace NULL values with NA, then unlist across(all_of(all_new_names), ~ map(., \(value) value %||% NA) |> unlist()) ) } cards/R/as_card_fn.R0000644000176200001440000000431015050667010013747 0ustar liggesusers#' As card function #' #' Add attributes to a function that specify the expected results. #' It is used when `ard_summary()` or `ard_mvsummary()` 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_summary( #' 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_summary( #' 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_summary( #' 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.R0000644000176200001440000000206315050667010014161 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_tabulate #' @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_tabulate_value( variables = "..ard_total_n..", statistic = list(..ard_total_n.. = "N"), value = list(..ard_total_n.. = TRUE) ) |> dplyr::mutate(context = "total_n") |> dplyr::select(-all_ard_variables("levels")) } cards/data/0000755000176200001440000000000015053142564012264 5ustar liggesuserscards/data/ADTTE.rda0000644000176200001440000001263415053134244013617 0ustar liggesusersBZh91AY&SY;ãG9{–ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿßÿ¿ÿÿÿÿþÿÿÿÿàßaèàî1ËžyšÁ ÕUàÀ; ,,൧6l&Ê¡@vR$¤©(ŒðÏu[ÝPJªyM&220FhSÔýLš0 M?I¨Ðò'©ê<¦ƒhɦ¦˜›Sh b=G©£j<†§¦F‰™MŠz4M‘¢f&ši¦Œ#jbz™ŠyO#PiˆI¨$™¨C#ÔɦM¦†š@h4 €žªI%OSÒah4 €D¨ Œ)6Ò†ÒzhžDõ=OPz€Ú††jf‘    ÔhD‚4*¢hhSÒl ö“Qê©êz€É§¤hÐhЇ¨=@0ýâƒÆ~dQå`sº®?¦–˜^Å^ÒŠ ³!-H™h°`öº™ªD“h—FÔ‚éBEŠ,µ.Pe±,€$ʺ‘2 *•Ð§L¨tÑ"f "H!"P(˜I´C¤Ée °‚@„EB(€I!+§N¹sœ'&9™¸ç%͹sŠmÉ@(i0…´ÊH„R ¤BM¦f“ ÌÈ™)¦¤2FI”(Ô©JL(ŠH4D™2Tª¥SJJh͘§$:"˜ ˜QA*dPE" ‚£®\Ä‘a¿Kã’{du†²€ä·D>øš0ßlúFY6¨>«. 6<“Ûèò$¯Œ(råaÈÅó"¸št`ü‰1ñÍÁ6u¡Æ!F$™S=.2wåSÜáåòé'†jËCt?¹ ŽXïÄ:*üp}Ôùâgð3±¥™D7Íó³øçíE/7VÚpbÃhs‹rí#px>³2JHeìL1´â…)‡vw;ýͨ’÷¤B3ÖÛûR:QâzczÖ"—˜d>Zw™¯äfɲdi‡’ïæÊÿt!¦Uyfž¥ÈææÁˆh#³äa²Üg<‘BÇ餋n4È”Ú˾]á52%9ã°óÁ,ÎÎÈì2q…ÇN;ÔØ•cñ@Ú[H›¡µ?ÀØs´ú'ÁLdÜÌüZ¶Vça£5ÂÍ{†ªÐܨñI—u£/ ùçßt‚|ÐÃ@V~ºãúBî ô2v9>$SŽþÏÙÎhø÷Yx°PãÅ“ãJ!:JhŒ„’k®ºé ¯¦çºmHw8÷;.’1$cIàGô»]ŒGw9(´¥N÷Ÿuìþ+®ëÞy¨Ú·=)‡hL—`­Oa…+:T“ Jµ«áä,–3,e{SI±³’õm¶¢–;P•#««oq±Lƒ[³2—Yu[|ŸÈÆ­KKËŠÔÖÌN­MzÖµ,®o–˪czÉ#ô¶>-È(L¿¢(¡¡S*§6þÊ6´ìöí ½4 *Ô2¤LÒŠ†!­¥B ’×Æqt;3¹Ê¸MÎhÁ۽ь¥;qÚg îçf”¸­7‚)d^@ (@ã&÷õƒÎîÆïÌ9!½ÝåÜ¿†wÆ1Íøœ*u/ËPE+£r´ï ½9 ŽYÕÁܸ~t’Ì|*–ã’ª‚|‚lx}wN(DrÉëéë×¥¸å¾ÞÌŹÔÇ“{§†¬þßLµÀß^¡$½øSbQA’IƒÔü¾Å«h>ª ÁKQwB?úÍ„°±d´JƒuDXåS—B"zPº@UX¨(õÛ{›Ám¥j²ËKjªMVÔZÕRÚ²[FÚʪ¢Ûm½™¯‡ãdG¶Åh¤©B ‰ " œkiP"F ôg×ò~àÞN=< ãd¤é<®Ü)QÛ Áçé jET —;™Î¢œFë’¸rõ+—z7är¶¥†ßÓZz<ûÂ~Rx“5;²Žþ4‰ó‘Ö¦aYPRì"³ ý‚£’¡:YuLï+€B¯ÙâD·Ì~4çl›4‡P‡R=&»ž"H²¹ÆN§*Yˆì—;cvDÑ—³ŒBØTÊö9ðºÚ¶%nÅA´ø̉ŒSg7$Áßâ¡„‡ l"d­Õ÷|›»êÃWW€l刲Hn&·„½N\—tã*ˆ âÆŽHùÐ4jgË2·_Ðâ¦5Öò횸{íý5á8eáó¶ì]ïC=>—£ï?–•uXÞoÕ|ÙàïÜIÄ­”Çü¹Ú!}WÝÇ«EÚAeŠUéØ“22ËèôÒ¼~8lG’ÙÈ^³w{ó7zžÿî4/…ßjÊøz÷šrflÒCe­’õÎ í0Õ§z”•…ô‘¹Ýó“ÉpÛ:öó½äóç®W0Ì<-[:ÙÛ6à¿«¯{²d§åø-ù¶ËÏÖØ@ˆÈE%J$¥dLÈ’1BBchçH^(•ßª)k€uo¹©¦L²Še“I±U# ’0„bIÇ=UÛz^NÓx³qVÕ­Í9ÔÌðT9â0ݶ‚p”Õ-™Rp¬ã’jjE1irøñËm››èÚL|ÄÎgšÊm$„’ƒ#E²RE¼›ZÅUY6ªÁ*(H„"B&7d˜àÕPÔ*(nx.t®"¸ïû×x´QmŠÞ³mZÄ¡¦$ˆé‡{wGÌe®9‡ÿrE8P;ãG9cards/data/ADAE.rda0000644000176200001440000006426515053134244013457 0ustar liggesusersBZh91AY&SYl†?IbŸÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ÷ÿÿÿÿÿ¿ÿÿÿÿà¯^îóèœø}áß;==ð>>ìz@ØÉЉóoms(Àä SPŽm›" t:ÀJëœc.šå €ðl )PÂÕhjžñ){‹€`ºPî4Ÿnƒ…Þƒqƒ8î&úr ¨P—‹íª¢U³_cs@ßf_/R"E °££›("2Æ&̘††€˜ ÓM(›4(Ñ4$RPQ5R@Ya"ŠLhX£@÷³¶IBµÝÝ=ôm‚ƒÀèÃCdÇ®´Ã€L€ÄÈÈ&™4›S&™LÀž“OS FÁ4Iú˜SÒiäÁdÊy¤z LL'di'´OSÒy i¥?FŠx&“ôÔiê›PiˆˆŠz£i<‰ ÓÊC@  <©$‘ hÐÐ4 Ð@  €z¥)šƒMi6“FMh £@ 4JI€š114bžDÄÑ LFšF£C hš €44ÐÐТB"&„M©¥<”ö“I螧¨ôɵ#OPFƒ@@4 êÿûĨ¯ÓÔ+ü\¢%×E*ŒÂ,ˆÆ pî[´ÝV½zˆ“u/Ê·âÛ„ rÁ,™kø3ÝÝ‚HaÆ‹Ë£èÞnö3ÓÏ4'©¼^‹Ñ§AZ碯ikÁŠ¼övÞ(=Žk²$É-e”[,2É—ÏswmèÖ6®^ÇyÙ´j‘Þ6Þ¯N«ÒX·rs½vð[r³”î·tÐTW75‰.ÝËgvæÔmÕʹ¨Ñ£k­r¤5gC¤+r¨Ú¹«…\UÎXÚÜÚ›F¨®TWNr§wuÜwÚ±jM­¯\Ûm±wuY«sksZ-væ®[kšuÛuÊ.VåÕNí¢¤JiI"-DV4—ÂPXK™W‹æFXB¬E‚±´Æ J" MÀ"Ù6®ÓË,ÍœÂ"RŠ&H #bèæ•-C´&l3va¶IÒèq¢ë¥ŽÛuÒ˜Ûyý&áòåÔæǯŸö´˜ŽzFº=$­G£f”Ùž²² ~î‚שm»«÷­a>—Z+×J.ºÝÔ¢Y×5}'ØÇÜ—1ÍÚ‡þnϹ'3ÿ'Õï< ýOƒ°‡gV}–ª}Ï) Üx‡TˆéÖñGŒCÝ?;àjÀ´G†èuƒZ†6®ßåz¾gÞ€|éépAxŸË*KƒÏ?°ýç×Ý´v—ϾÓì)£ÓÁ ƒ’#‘7}$=k£»~…×ògËLþÚE¿×üÎß–ohX…N+q,nvÝ?1Øa`€6ÈKE!ÓôrEϳ2@~—?ýÂûÿJlM§cq³²ãÑJ<:Qƒ›ö5¼Îéï7Û0ó[‹«´¨ªh±3ÈüŽgBªà‰ r‘ïû Ž{Wo¯Vìd¹¤`¨ßÏÎk°÷ºc].Ÿ{ÕÿÀû(Ò™ÍùÛÐGÌû$Mú?ñ},˜3º}u.8™Dÿ» ü^W<Á£D|Öú›CÙÖFÏÄÆùóÈ=^)ÙY'¿Ðþ7:Y¬uúóP?Ùÿ¢†'Q¾$JÎoÑ=Âæp2¤joú¬GÍÅÅrõ½¹X¹·â@ðŒÉUvÅ庶DZ©þÆ:õâŸÒÏ`òe°J›k¿þ ãXhÅÈä¤LÈ r?äo•7éÿœEæ¸$R8Șrìø–£ëòá;Œç}MƒXAJ£øNa25^³ÊƒÈË#ѵ<~uM D]"4ø­bv^Y>Ÿò9žpyýeÁÓÉõZÊ‹v³ÏTû>Ò#Æ0ÒDç›d1åã ñ<öàñþàa#Ê~nßÐzÀ}Ä¥qàž#Ïa!ñú±ézÿ·‚¹ûà ÷{¯Ký£ó"@1ù­D{\3èôÈí, ‘†#3õux„<¿ˆå6xµg‘`ÂÔþ³™:„!kä¿?ªõCg¦9öîvs9â6«å»H¶£ ­øœ‚ÕCñDO…œæÜΗ¦ØOÓ ôŒÅ—0ÔŽðþ”2¸c8¿`¡j|¾¾WAC퀧acy'Îï7Düg»ÝK÷§ ?..#Ö Hðó»`vFÙœÿÉ!Õ¢Ööý. ïÁŠg¡ëîCz>ö¾n¨íN«ãämÆë•9­î-. ¸ø}ˆ?n;Ø#‚–w?r­¿ÈE4G|º«í ^j¯ªú'|ßÃåÐ5±´€waöû{ZxõY®þ54‘óß·UõqƒÎÀÕeA…$x9_dìÇ.×Ù9É,è:»gyðz¯ÒË;œŒŠi“9®ïx>:š±çà3Ÿe‘ºå›Ä#]“Ùíhñb ÐÝü}ãßOõwÒç=¥ð–ññ7`3¦:Ô`;IÃí2¢zwu¿Ë âbÖë<Ñ…aƒcpOø›Õafüãëa£þÚ°6°F§·»ñ´Ý½¦\8œ ’€’ d»ÜëT5£;QÀÌ Õò13Oµè²ZæUĺæb¡P¶'@Î;‡ßú-£ê×ý9ð|ÿKl“SÁb0\W7·öÜ^1ÌùœnSÂçÛo)G‚Ÿ‘ÏCNîä ¨+¦]1¤ݾ»MÊ7ßò¸Ùó0§—¾±£Ûô=‡3¡BÉ00& íÇåç ÖRÌQà¡„D«1ŸvÓÞý-ØBÕÿk-Åzõú¤ÁòâþÎíç%w<®âlW~´ÕAE…æ˜ö“L )$x°A$¼¸ª‡ê±,Ä¿¾Ãý,ª6ÈüŒnÊZ£wt±ùïÆÃ󵺕d‹cûïâ}þ½z^¿ñøæºYìVÛv!¤}¡Oßwî³Ú@ìéÛÞñéô­3ÙÝO£Éî˜ëšjn¢(O4®³}>ñ_#—´{;2n™G§^sЋ7™¹vã•êý·—ŽÊЫ¹9Õ !¡]yÉ[ïŽ\õ•Õný}®“€åuÜš ¥®¡¢$DÃ=ÙpЖñÝ`lÁ ‰"“•>ˆ…öhx¯…n~}½Ó[^é{¸õÌXÈ4Ì”†Æ2÷Mï>ÓyÿÀ/”zúµêZŸ¿Ÿ¿N~;¿¯ïéìóÍ䟟¯^²–¤U‚zjÕ üP6å¦Ò© $Ú*HT€…¢ :c'G` ƒ9ßÐÚn£ ¥]BaU (8Û 4À !:“¯´Ý7'–Þ^ªg–ç·ºCânêß©äëÕ1ËuÇ©ý—ºÚ¬ë$6Ï-Y#uiN‚@¶p€E6ØWÐHDû-Ð%²‰iLµ1–ɲ@¦Éèf#Öh„_µ†ª"< DIƒÞPGq¡à^1Pû2 gCßÐÇ÷ýŽú¨ ´  IªÔåAéÖÚ—Æu¨Tš’”Ih~•â'Ò )È Tm%°OÕ0Ru€!$!gÒÊjj2œ›hÙ»eˆÕÌ 4¯$ŠH¸hµ©p0 òXÕ --¶DÃiY•÷ÔÚx!i*côÙƒ%àÄj È»¯ƒvÈ+F E1(Í4*€ìvól³q‰¢ÇÕš7妅• £AŠ4ôèjøP}îõÃ:L£וÛÎO¸z“dcîSmT•]Èž`fÜv<Hdл²pÜ!…ê·T˜EÅÓþZѼC3JuÇã`4NYWS)‰Õ¬•WßÙ°Œw6p×h\Nf«ÂŒ †ò;o²M&ÞÓB‹Ì»«mn!­XHÉA¤&Ó~“h<€–ä-\@ýir¯cG­ARvl4ìì¦ÞÁuw_[Kmη¿ŽÐ—=ÁMglÏ0B+>Ù‚sîX+» ”vÃ(4Ûp JÒÛ˜†E“@9. ëi€Á£hÜ ö²*J4 œ'Kp_Ò¥€ý>+øØ7ÅQq¢)6ü»ö91 cQ »áZ»õ!Y;B3®¨„Àô×nh[½‡N›Ñæ4ÒrjAs„Ýàšø’ä”.” ýÚ V“(\Œv–gHrî!{Áê$ßÚ·j…¼Bò¥ P²(K»‚ˆŸ6VD KG0#_4ÕÎ ^@KÈ0,F¼uVoÐÑ2“Ûè× ŠÒpÚ™Z–J*Œ.¹tÒŽÌ‹ ĽeÂc¢ ª`°…በµ³¢Mtj i$Ø’ÅdË7bHPQÑ Þ´ËkFF]a§:Å0ª‹¨ƒ%9ï8òr ¯Û ‘[% ?ã‰×vØ­A!æ5bTÉ-²š¾D‘z®"d@u²Á6€)×]ÈÉÅüˆ!ÔJ@v '1Í9RÞ­³Ò¦’"†«T„"59n;ÃÍQ)×ÔædÅš ãI†>$×­UÕî ½ª7ˆÞÜ˶Ó.5ïšåW FN' X22_ã¦k\nF¬ z h¯‹s­Út®ÙÈ Áé–¹tÉÐVºi¿ŒØƃ'ŠÝ¢yb½r‹lŒû­µq RpS†ý³ne1Óªb²Ä1ÚÉÅ4Es­ªÁ©& ëU¤'²×Q_Alõ:˜Ùgà°hCZêLùÜ,ügëÜ=Þݹx‰ö¤XhW’à µk‡»‚Ãuà¨ÖFW·”¤p·vuĻٹŸ ^…z´ÄÆ{—£v§UÇ[`Gt=Q‚BÖ­*R«JTh_0G`kÅ*¹kYùx'CpÕ»²­ñ÷wî>'aÌ«g”ŠþæþÃÐÝ]²ºqÎÚ7:ý‚)m=Á²¤9u66 X‡#ÆzâÖ•æ%.²¥™D’‘+*J³ Ì£g͹ÿ”JŠÏ¯35)/Ä®¼ÖÛm·WbmµýÚjüÜéýµ£[Æ×^+Åo£n—6ÅËrÕÜí­ç¼wu\ÄWãÇ#»»»~¼bƱxÜ®h®\ånRcÓÏkʻӱ½â5¼\ñ®\Þ"¼šï;š‹¼ï•ÝÑ·5Þv×"/1%ÍÈ…Ü[Ç+ÉÚäOSµy4î4W£šåãxŽF¹©ÝNë–KÑ«ÁFÏ·$·#K·W=Rñ¹QÂÌK!™šÑ¯clŒ³1Œ¢ãE*×&JX’¨¬‘[÷ðÍ8eŒÖšÖ´(¬„" "TJ³-`¥ FÖ´°*ÚÔ”ª¡%¬K– ÄbÆFbÀ¥««X ¢ICý[g8Ë™‹2­—ÊÊäv]Ýt.st1s»·=KÈ•,¨Ñ°– ‚Â)H²YabDŠÆ(ªÒEB1 KöùÀå–BI)’pqÎ f»ÖKm¬k-–­Ó2ës‘Hf·ß‘BÌ «¨¬‘̦L…Dý¯Ô5•™OÛ2“M‚n±)2°„,d‘L0¦aBfRVX"?SÃa€A¾çUFp½ß‹®&œášqÐÞ¶4÷Aò¶éwÊMõ«?3žÝZÖ¹òêk·ýÿ‡Å)Z¤üæV‘*MK/oiôìTRÝ0N v;9j¯Éärp©¹¶8ŸÊ^<ßÔ/¤±§žâ²ØΤ㮡™Æäš3ÁUú|ß¦Ý >s®ïšíÙ«àU2Ô–f²•“j]Ò´0˜S%­R4µ¨­U•U’Á&ÙSÆØ(z½^÷ãþ—í×¾Ö¾±,Bcl1­–±QµlmE¢“hµ±¢‹mF-¶ŠˆÑlZ÷•°V6f¬jˆ¶Ë5cm’ѵPhÖÆM‹h´Z- µ’(¨Ú E¨Ø5 Úƨ¨Ø´EF°bÔmE!Z5Ÿ&êÉ™D«1”&d(ÌH&ëfJd”ŠÌI¬ dÌ¢ É#0B„ÆYh°"2ÅX¶±«hÖ’¶¢Å«lkXµ¬Vª6ÛµEµ6Ø£j-VˆÁPlÉehÔBi0(-$jÝ5­EZ»ŒY,È1©-­YÕ­¶6¶¹mnm¬j*M£kcm£bÚŠ5Ub´[cTkbÛbÛQmʶåm‹cZű[EZ-l[cÔj¢´UµjƒNj•Í9ʹ‘y){RzG´¢÷’¯\¡Ì®Tœ„åW%'*¶ö­m=ž›Ed2XƒkÝ-®TXÚc!±RÛDI $’ Xèä€@%þ—Y–îôê‹Ï›%Eç7®—É_éxëâ¥í{5Ö-£PFѤ±XÑ´U3mŠJbb’1Š¤Æ- ‹DQ¶îú¹h£Ea˜Ø"ÑF)4Ì„›&fŠˆÄTšfƒDbJ1FÒaˆ*KÆÅ%2Å¡ ÊBÂR£ƒ²ËVÅ¥¶Û`#ËÞîg¾¹Üò÷W¾Í=Ûxé™é3N“,jté¨t®•¶˜ñã³s2ni‹+—¬ô×Vkʶ®ã“Ûü{µV5ljŒm±¬ZØÛÛFÖ±¢’µ‹Z±A0 G\î׉žµ+¸»:O‰íuAä(Þê"ˆN ¡1L(cÂÁ®è æÂt.”öM\€|o§sÆ[ÍtIj§Ïb*HZD«TZÕbÖÔkbѵ¬Â™”8ºXíüÿ‡ooW.–ûŽæ–[{›šdÓàÓ'xÚóæY¥WÀÞ“®õÈÔo<¼¼ÕZöá£2ÈŠž}}ï»æÞ=¿MüÚ~ßÛßï1á¦2cÙ¶Æߣo™hw…÷ ˆp4wCb¨9‰`A”)%á•ÈNÕ2¥ ¢»™I:{1 ¾Ç×"ÄX± pÞËÒwËþÞ…%@˜‰1™Š‹{×J°m£lI&ÕÄjL– Qb±‹*Û$íæý¿SNçƒ0õêYù‹Ó›­|5ÓæîÂÁ:c»ÇB”¤¨÷­ ”UXbCw«½"Á‰OÑ–Œ,…`ÀÐGSaŠƒ{x6ÁåZU+­+S·SŽ94ëΧÎÁ3Z‚ á€Ç%„AÌÇ:`¸‹¸‘f@õèa ”0Ç] ÁŽ½ Gƒáüœø^2|«ÆJiñ_…§NП YÍRÇ%Šl:t8±Ñ²ÔÓåØ$¥™–&µÞ RâÑ„…žr’ºæŽlÞ…G•'šRzJx®f@Îsgs{¼±@æ š/yš-M««w6’£7Ê6ñ7˜fæ j/ró.ˆä±*°šÎ.Õ´êl#"…Ö_6¬î0ÔÉ UM•:Ã0y2óg9nð9!V·@Ëz”³“$pébÉ;ZÜ hœ{Ä/ÌD%š½¼ 戳q|»š Ô <7:Ͻ!0õ–5,#‡/HpÝS‹A ºœ¶1bÎ:³UĺcyuÁ¶D¹¨2„óg“|š•‡\ðÍò‡%rä±ÂÛ©³²ÝØÌTÕÚI2ÝslTî<ŒIT†*S7ͬÚV8&XÑÄ3qUÕfULå¥Ã N̉X.†±a¨Zj²‚Ì!9)dn]Î0tʱÊÐø˜04k^*e™ajCˆRú“O§J¼S’- òóN; ì§5Àøølò¨o2Ýs3qæ+å]s—¦3gˆ[»Ù¬ª¹ãÓ"I.ñY'€^Žs8ø3XfÔÕ‚¬:à3œ§G›1"øNb̼áá½Ë†J{CªÞQ¹ÌÐÎGfÊTBS [FMâèLXyw‚œ•.MíCx±ÊÂÌ‘ªä‘”Œ•On¨‚YlÓÊ †X·^wËÖ/Ïìú|¿F§Ò×ÑUjÕ–[e\R $³6hƒ3# 2’F0³)S$ÑŠ2dˆD!FI Aˆ#ˆPa2d!1¢’$ÈÓAPz©ªµ>kC:LYf+ç1VY)Þ4ú­ŸClœciJÃäTõTÙ¹ŒxtÆ›ªÓ¦“F—jT­79¦“Õ·N’‡”mtTȲdRG.Â& "Ð3©ŒXÏMÍrYÔäÒÍÎë#íÚÛXén¹w¬iîx8ÛÝßÙÒb¼1áê÷8z©ä®”ÑÔWZjzNû6x•¬Æü2qÉãSÅUË/×u9Ó ›šžÓ›LV<µ+Üp »ð;èïûîü>ÿÉ;ñßμ°ò¡N¦Ú»°—Àð¼fÎKŒDQ¹‹f5Î+HRs-ï%nÎ#2Ÿ Èç9¸ÌÂÙ‘x§Ùh¬AƒKÀ [S9CN^b&K\³3J¶Ž•’6‘2bZí9jXa44Áw37EãVh…·sµ<‘„¹h›¢¢¥ÄŒ Az"f˜|Ñ®tQk$9ÞrH¤p%dF[›Þ=Ho1;28Oe²2æ·S‡U‰eê¡Œóy¦ó‡.A3g(ðo[$3O c 4Pv ÓÒöîèÉ *’Äܲ`˜'J(ï*È[\æÚMjÞRd±.-¢ÄŒ×ÍC8ß4kJ÷’î©ÁkjY¤;iªÉ­°äˆ[rùFJËK«Vg4fiæ¢vCÎ<±!é͠ƇÂø(ƒË XÇ*îYãÒ¤H›Ý.27´/,`“šòx2lŒÜlŒ¬Á‹c–S ·R0å!¢w*¬`ƒªvêùÍážq Á94ï†ÝRÚšÑÆéíáb‚\àOf‚.Îä麒¢ÒÖsf´Pv To680%65Ýܜ̭ªnX šÂ÷H»hj(âfUÚ¢M´ÒÐÉ„q¶ãvÆšvi‚–ÐBiÉM㬤hŽ5dJ0S’,……rej» ŠhY‹—ˆ1û´µspT‚JšJmè¾JÉßòÞúëâ|Ï¡øçÅôýO•jYòÇS¿–6ªuŸ[ iõ•®®Úféïš3iâoÜïs¬•Öui©|k:z³\éó¨ÆŸk×ë|'Ò}/¡ô«êñ»Î8jlšm}‡¦­ÛG¥8ÕÎt\*j4oœ®(ÜÞà³€Âç¨x9³S̚دJ›“ÀàxtXÚi“¯/!ÑÇ”ÙÍ3ÏUãS§f›0ÜŒxGC#­'”ó#·E&HÜ°£ss{jMžÃÃl&'$Q©SÃRN˜˜yÓDÜìê'“ÊMFS¨íÜm¾§ƒíâ<Ɇœ’µ& 9×3œ\NTlżáX²22<šá¤ñ:’ÎäÜÉ‘ÛGg•O ¹6té¤k‘¹ šXÔ;‰¹´³¹‘Àå-óYäîbðÌñi6ÚywÏ37·³å\N1ùïsŽ˜ú^:ç:›ôHD>Zœ›úþž-ãÃ¥›y2z,Nd¯±ÆÌ‚ÙqÜ ØÑ‚È]XîSlt¸N污/÷/ÛV+ÑX:1TÃaòdFÅÏ‹ 7ÅtΑc†Y6ÃqÂ)´&ˆ7Ò&,‰Á¥@¸Àî7ƒˆKztN„Ì Á"C4H`XècÅ…dj˜Ñ;V‘Q@!‰  .†ÂhÛ‹1`½îÛ‘ àœ¡¶<h0zÐáö BðvÔ ˆëb{ÐB:>Ëî¡Á܉èx‰ë Ñ$^â±¥|Z{4ç¿Üzzݽ}àò톞æ4é7™=—Ξ‡%Å™—ÂÌãqLHH*€vŽµƒl0£Luà˜˜AjYÚ_^u®¯/~ï'ñÛ˜‰¥_i×S}FÝcVÈ#ç© Ï=x^¸áϳZ4é=#¼iÆýÊ·;í÷(}͈¶²B(­kcV"¨ªMhÆÖŠ-¬UEll#cGÑ#B;@ Â uËž˜4 ¦&3×½o•“ÒÖ¤[h–Élhµ65E£VMQTšÆ6Æ´lUAFÛôò'±ëö½ª”5®ILį ubZî¡“‚D¡vZ Væ2,Ó1§u¦‚9u¯+ž—\]Í{VvÇ4½øÞ6ytÇ[óMšLzM'¾Šç ‰ëÔ‰WG(QŽ ¦Ã.š-H}—Nƒlní ƒP²›K,Ý#}^ÑÐ.ÍÝì·!4’ ød"zOÈp{ø´@€#71æ<ÊÕm¶4äÒr.ù\šaåˆÃLcj¯,4­+¶0ÓŒcLiZq´Ç¹˜TõTÇÆÆ1Û&˜Ub½œ1¥R•+…UqZVK<4Ǧ1UMªªóײëz^ü×´,Q´EF-–E”´¾ŒxyÇ+ÙåèòßÏìǼfO*ÖM·4©5Ê•N܈vâLʳ†½=çoeεÛo*Ò½U§†&ÔÒ›R«Äm[iÓ×vîiܶgj<3¬Åyk¶Û*»aTÓS[Û§›òÇ-5Y,êzbB~¡ååîåôãáîº#{ Žç}†ä'œ tºôŽI–ON•£jµçN™ˆõ’vùogN•¥bºi‡£R½[1Ô§•z)'|ÎΕkÃlm5ðñÑìÛ´|„UªD=XxWt<•YPUÞÀ‡½Eðå ª_†‰!L(„¿G2•Š`‰%b˜¦X‘ªÂ–UXTõ³¢š1%ƒ,‰ÉJ¬°©VXŠVeR¬ÀªÌ„™„bQf ,°™Ve¨´•h«%m6Ñ@š Ñ­ŒlͬXKf$Xf$Œkb°b¤Mѵ*4FÕ±¬h±©”UEEI±j(ŠÙ)(¶CdƊɈ-R%‹’ÒkÅ™EÆ0c bUBEE©LË´hÆ0ZlÑE ˆ’ ÚÄmÆÑ£T¥ÉiCbCC + (L¡,™"ÄZ6ÅŠ"²X˜ÊKDTÁ¢"f1&¡1ˆÂRAIf¤ŒPŒÑQ%bÚ-[’Ô¢ª66‚¢*ˆÑcXÅcch°b1"cX) @R ÂXØ2`6“FØÔVÅDM“j6Ñ´`±Š-b£SEhÂXJ ’Bl¦d„cHHQ¡”Ø‚ÌR $i$ˆ˜f“$d(ŠRlQdÆ¢6¢ÁI¬A-j"‹TTT”Q´j4 Ø d²H‘hŒhÐÒ”£I‹cE‚ÈÁ)”L†Á£fˆÆa…!!$$ŠRȆE‰ SfRˆ ‘EFÂ Æ  (‰”d“!$hÁ1 †Ñ¡ „Œh1[F¢ŠÆRRbÔ–‹X*5B¢, ’È¥”Ö4FÑ3S$’%•Q(’iŒE „™F4d’+XÐ&Í$ŠI6E)“IŒ4$†˜ÊFe‹FÅFŠ jQ¤’@™1"É‘IL ÊEÔ•)2˜&dI,Š3@h‰ Í (a!š 2RH2 (’$JE0Ò‘%%à "b DIc`ŠÆ¤Ò( 2’A Ù2R@‚„Í¥›­¶Õ¥cQµcQ´XÚ“Z ¢¢ -EEEŒi0‘cT“&ÆQ±E–Q*2bR!"!,¶M3JJ(‰$ŠL4‚”“,†Q¨¶,Ò)!š„Œ‘•„™#bˆL1†HÂ&I”²I¡DI`¶e”¦†L)›kM J@HM!‚I( @$”AH†¤ŒP2cCBFc0&"’†HIE‘BK&¢M«"ˆÈL"! cI¦H¢Ê61`˜…0Á3# µ£F!61eš‰1Jm%m LiˆTfiÄZÑ‚!šMDŠ6¨ 4kQeµ&eªM¨*¤ª‹Xµ‹[[k£X)‰‚HDfdS6$ŒE¢‚1±“H˜¤£dÂlE ÈÉ F2b4XI2RBQbŠ4˜¢aXÀ˜Š-ŒšH¢“ RDcE$ZDш5&Š¤Ø¨)#EÔEhØŒ›hѪ­cZ¶­£mª¶ÐI35ŒB3"SÄ#&‚(‰"ÊdŒ %E‹‚$QˆD@‚ M(6Šh ›F@²QiD¤5  ‰,bŒ‘±b‘4i36ÛVÚ½KæmëFøÖôF½fñŠ¶U•Ž…‘&òI2nÂR´þ+IQ–00JŠÿ¹¥ù!´ˆ¦²ŠUX U ßi%õ±µ&@&S" ÖÔ×<ˆjº-¬fM¥FÒÄ“T~V6!¹FÜd©1d”0oÑJ­z·åA–Éi¦+)dXƒ´ªÒ©5VQK$Ä’±FP,5FؤږÎMUR¢RP±úÿàýËòÿ´olÃñ±ù‹ªê_ËoÃn;¿ÁÛZ©î½ù[þ|üÖ\ž÷ÈǶ{¬tˆŽ;’žûmUªø.)O=ZNB#çMàiľT–ɸ­Ã©+ûÑÄM·è&Þg:c×[eGËáõßSôþmáê>/½žçëøtÉûùm(ûXªZ¿6 çSƹ7u¨o.‰ô¹›8å_šå­¬p=ÕµßKæmt! 7fS&8Šæmu[­'<ãÁ¹‹aù^»?,꺟näÓc•³%Œa6/F°Ìªtã5c/{¹ÃïŸøiÓÌ©ÓÃì1JSLQXª¬*©UZaX¯ cF ºiµm*›cÓn6Óì8Ñ¥tb°¦+UŠaXÇJÒ«m4šhômµmN8Ò1X›14•1¦+Jbi¦UVÛ46Û¶ŒU)¢»V6Ûm¸ãm*´Óµcj¦1UŒclv®)¤ã˜ÑMtÓ§LiÇJÚª¸Ó¸Ã1Šâ§…86éˆÇFÕ[SN1Ç1¦˜pÓ ¨Ò±XƔѥ0Æ bºm[m:V6Æ#éZUU&•0Ò°©ŠiᶒV˜SŠWeiRU8¦*Xã ¢šTbŒT˜¥RUT­†•JJª¦•¥JÆM)Šâ¦Õ6ÁXvÃm¶ÄÆ”b±¢°Åi]´ÄÛÛ”ª­°ÓjÙL44R´Ã¦t­+iUŒcM4b˜+ÃIڸኮ1…)ŠÅGm›SjÚhÆ+N˜ÒJíÇmÓLi• 4­ÒU©V­^ä·Ãü=﯃ù|߀¤bš"4m´ZF¶ ,TTV1¬m¢Òlh«ÑZ)4•´[E¬­Q¶¢Ø°l¶Åª4cmŠÅ£j‹j1±Q”̆`Înf;j‡CǪ‡ˆì”«„ûY/‚šwyÝùšzg±Ç›?B¼ÛóºØ2FHJ˜ J@>'Щ24–íòù\;ƒŽ^Îø½‰¹áN^ok7yžöÃÒåÇ6[=NÅÚ³XUůi “åæzWÛW¯×nG‡2ÖªÏ5k]É79!7ëV§®yµ¦SIX»wW.b/)ró®ŠYU×–­^­·¿¨¥ìÝ™©˜dÙ–M™¦l’˜’ÉR(–Qo,Tx½}®=w.c¾ØëtëÏkÛºó<]”Rñ¯`í%xžëQäòGf3<µwïwÙ˜W«¯uÓ›-jg“mœ|"S…]*ö|èë⟑æÊÔ­4«íf¾ÎNj\×Ã',ã{rcV ¿s=žÈjTù"O iÕ¢®iŽ÷£u'›òŒaf"TiR›b‹ÔPšˆJr A06Ð%¤@Ò” h†Q)Û wÜ·Q)ÆUà·Ý<ýû‘⸣šçc.qäu'[­áâÒö‹™qéµöDAé,49Sã¨`b"©FIàxú¯?§k­]k±žt—S­ÛÙmy+$•)T–²Y-d«$–R«l–’µ%¥”Á‹£Œ0Xap¥{¾o[ãÖ3ý{ÿŸgÞ{­î{¶UZÚ%¯h|§¿vžïl·Iâ[Ûú\Ÿ\÷<Þ Ãm½~ï/Êëªd>¸_NÁ¥6£#ȶÊÙJc#Pm•´¤6£%ä´¶’ýnM¨Üw+z. ·Öɪ«½pb&7›ÕøÏÄ£ ñϼ»E§FÍŸ‹8–Ml?­:’CôHYÜMê2N#¢¦“S­,šÎß~i6•6áÔðC‰‰¸ñ+Èèw˜˜Jðx›27 Ò:1¦W&£#Âm;N÷¨d“´S§‹¡Âɵ~V‡Ïdü¥ˆê–O>ò¼¯ѱQ¹¹ˆ)/;qŹ\ÆÇÚ$pvåAˆœèîÛr­wuŽnŠsšøVåXØ´š/.ºç;»V)ñ®›r*Ç;i›XƦ5\ÒX× r®m¹k…sz5â7¹)¢-\ÕÖ-ˆÖ¢´%b¨µMs•„±HZ6‹®¢ÕÊ¢K&µ)±Šbç-ËF«¦Š±dÑlTÔPi,IFÑhµsNîqm{~ç{µ¯F·À5ŠÜ£&ÚŒ[gíõ'¦©l™Hï÷\“u¯«†«ÚþcÝ6¯q¶ö+Ö=ξmó'§Éû˜Û{mr´½ã•§£¬[_;mò+ÆKF·¼îÆ­£bѵ‹bÕÒ¹IC•Ê-¤Æ±¨Hwoƒó«ÄmNí[‘b*d£'.]Û¤‘ƒÆí%%ËD"4HÅ"RR H‘”¸sM.ë¡1²n:åÝrÝÌVF( +)X‘ˆÀ¨ÅÉ \ºNí]ÝÎ[šá®étºê ÍÓŽ»œºšݦtêÔWqÐSºó»Ç0ZH»M—.s|Ûmñ6¾oê(J[J4õvíNîëºë®™œ; ¹rTuÝf–TÉ´«œÌËf6¹3®¤f&Qh³d¹®Ì5 ݧvWw!¶dIfM‘e®îeεwNäÁ²Øȹ® ´Ü¸’±&Ç+¶InsÎk"I©µ%£1¬Qt¸´hÊ%5Ò®¶¡²dܹwWU™6D¶ Í\›$4“HØwLCuÁË·uv¤²ŽmršÎW4¢f±rδww4É+E)œ×n]RŽVà-¸uJ’×uw.*H2Ibm¤­ËµÎ\Ç-—22UÍ:ë9tT%%L\ãR,\¹×tÈØÙ"Å']ØƦz»«ÆéLŒË*3»v۹ݻº“Dîvë §«™‰æu9Ò»ºîº©.îÅ@#4¢š¨­Ý·-ÝÒÍÚZZ1F#d˜š”k\Ý®v™M"KFs¦Înmr“­%bîçwUÍ®S)Ó‹s.ܳœmÕÖ“ gK]¢éÔÉ–T[JØñ[¼vÆ4dP€ÛNí]Œ¶*ÈÉRLC)´fÊ]Ú.…E5,S;®ÂÑs¬Òîé1]uÍ×k¶*‰Î5×]43»¬’j']r¡ˆÑ+–®h‘c äî°I¤±LlY¶Òe¤‘F3Jsk›iÝÔåºv‰f¹ÐR,—VÝÜíå›Nê®TÌ°ç4Šj6šdÒJÉ$2ÃS›«!Q›EJ (^ôî:¹Sº¹Y@š $lCwW4”ȳºæŠŠZ Ù×Z»ºÛ©×\âv;·R¡d*'víHÉÔÒ2éQ]³»w8f375ÔˆçJ œœW5‰ ÝmÌr®Î»a’L³B9næÜlĘٓ“A¢Ë›‰%¨§vìs¹ÔÚT”î·.î”Sκ&56Š¼rÔtº›Y¹ÝwMEˬ›3§5‰;ºÐzö¯^Úùþø}õ©š¾"ÃM¯ÇÜÒÆ“©‘‹’*UÚg]º™)Ù&MÖÍÕÛdJPªbc*•1“mdÉSU†LS&EdÄÆ3%T¬LU–YˆªªÅŒ4Æš*ÊÄÓL•¦#%`ªµJ¬¬Íi¥5&í:ë]e9Öæ餴–®–Ku×TË.’]uví3¢Å”ª•R™¼šaùy%bäßí¿šŸ™ƒ}Ò<‘)ù’Ñ_ ÿ‹êM Tõ~‚fôý~]ø&ds.–©Á)Õ&kFûª÷ìnXËðZÌÙW\n ~gÑà„?UtD{ éÎ~ùÿ/úù­[û+ËÕã„@¨Âo† 6~'‚@ïzÙaUñÅÌfF3%ÅĸÉ1†L`µ¦f1f,Ì5XeuïÑï»t×Ü/p½µÂN.k%Äís²Õ{믵7ñ“5SAæ–%W‰+éxÒñðŒŸF'eûV>¦¥Þ˜¨µ¬ä&ž”創QLPb\x8µ²Ìy[M·7Nì"GwÂóžÉˆõ»·)™3bÌœýD4/ÄžG’´³Œo¶.äx›…³qw]<«ŠßþÁ~ð{éù¤¯Š:^#ÁÕ&;]û¦õâ]ÉKÔÙaK,S½f%5™”Äbï_a¿èõn¾¥u(§ÐÙ¡ªžöGsîçÃǬêà–Äéaï:‹£)HìÅÖ½5v6_3xÚ«¬b5ë«Ú{CÝuŽ÷pPíó÷65v2²!äûÊ-—6;.¹‹}¸¯VŠ@ä…«tNõ— Dq¼Q¥•^Õ•‹–-¤ÖÕë·È_!| ¢$£dÅŒ´”‹0…­'Æ|†ß9½úRÉ031ãVŒ¢Q‹ {—q×/h,‘âË“ck%4š‹#ú“òI¨êqõ>£ž9/M&9·ª“ŠŠ¢”o Á¬u<»6ˆ« ØŠ²H3‹j}¹ÆßVqÆ´Ÿ*쪞3õ_Öû±+GØ=ÿÀrðˆá8+&KÉ'±…Mجf1˜íÁwÕ4•Æø>ÖÊ„÷O,{ç?Ôt;;úÍF‘|]¯?´os«Òli• µ&­[âmÕÜÆTJÜÊ‹fKVú=÷©¹º­ç+KÂ*îo9[¼‹…X8ɲ÷.U½qëTFYFY¶—@)ê/gjîKryWkì¿7÷¶ø}žídbÃîcã1ŒV++ªUªß{Ñ¥Ú•äŸ*Ö­—¾’<ƒcîÛÕU<5î| ítÅèÖ“3Zµt·#¡^hŽ{+°æå¢s\ ¤Í“dc' nFÍ,·î_ñzõßvÒR®Z‹­µÑ»I\§m×Q#sÞu?1ù‡oEÃK—“:»öÛSkj‰ÜܺãCW]ÝmîK y4°s]´©}O§à_¦+ù$‘ñu³¢yŠÀ–æäµC«$±‰2È£2céy-òáóU¸}•íÜï¯qUCŸC1q%saÕoò£”K‹óeg(ÎFO9–2¯\} Šá'È"7šTé¦ëg¥hÕu*ÎÕµÝP‘Äš×o'4œ†zZ;z.W5î/i|é^kÀó³ïÙƒY”ÆG¨z îõ’3ÅáÎÇäéjÆ]ÿÊØÞ½²êL[š×+fh‰5Qi,’V¤¬›%3TmëW,Íó…nÍh´ÌL’ɵ–JU&Mb­&Öõ¹EIi,³lÞ«Z»m·£x¬l”ÐÑo²†˜¬°Ú¬¨m‘Œ±ª´õÖl™X3/¼l46czZ¢7®{ÕµSä©î/e±ò$Äð«ùº«ª—R[[êõƒzªÞ¬7ˆŒÂÑ‹J„DDdÜB'|ä»è&ªÞ¾”¯¤ØñŽ"C¨åJGБs½³‹•ï5c2Ëc ÅîÙ­q“®¾ ¼o¹t±–ôí¬Î[-X›1>M87¯™~*âã]fJ‡cÄ6[1VÍ[$ÆuÉõØé)£ÑÉø’M!ÄIŒMˆF–=ŽßVÉ\ë{d­¯!غâA8ß,¸@ú/?…Ÿ uöId=¤njkcÆ&m0¶ÝZšÜ©µ˜¶I VÖ›*9••Sdc´Þ·ï~žúGî:Òx/5é_[Í)OKÕniSrZ»ÍÙl¡¦Äw­w=˜G¥*÷£”±Ö—…Œ1ƒÛ>ª7¹\QÑóöJU×v%—[ñ®aOm+°Õ–<‡ î'Œ›×ĺ΅p9›¸JUÉw—q8 öû+ºä¶4ŸqSN4;&q^*$r¼­U92T'0º].r¤w ͪ\×SšVÑê‘Ë*|· ­‘ƒÄe[î‡ fe•Xòå7‡[„ïꎇ;¶îéäàíIlëÓ®$¦úè[]rë¦èÞûF:èÞÊ‘Ç…»VÖѨæï5`aØeŠêJÃ…jwT“-ªØØeÅD¦ê‰ ›ƒ¯NP8KÇN÷GŒêZxÒ/ÝⳂ9‘#•9¹œóéñ§ÅžÂöIýæ«5 ³­v2íÄÝ#kÂÊ–0c*zß‹êßéûkòXcm±—ß]½}“ín¿ï]×{ª †÷jÒ{q_yÝhNìÔZ4j.õq¹8šIÀÙÕFËKâç]fäê²¹ÔHÚp•L^µ³Ú[ÇÖB˜ªù—%Í+¸ÁÝ|—Ž¤Ÿˆ¿¸7Ew•)øWݹ<)eÎ%0‡Ù¶MO¦È{-ëF(Me›Y*”©5%"JJ–RÑ™)JT‰¤¤*ÁJ•Rת>/põð>z°û?!Ït7¸Çº¬¿~fJGázùû3íþ»¯‰KêØo¸ÔOÆö[œ87”eeSm|sÝͬҘ̕K6KÝæžòD¶¡¶*cMV²f_Í–ÖYe“%YaopEÓäü~)/šâÁX`äûU}’M›Žß²àâÀìmÚ•°ˆÆÖº-Ū;RñEÔ­®ÄêeŒfZ4š¢¶S3I‚ɱS‰–1XŘò¯œ÷“’äN‰Tú\•ÚØÙ©¦k;ûíÌcdǤ“K±õƒ¹mx2À·¹R@ÔDËÇé·‘–+ Ö+s.¨ãTu–¢S× _ •qÝÆü&ë¡7^î;34ÓXÖ)Ü,·–þåß>ìä¥ø©ëv;˜fYŒÌdPÙ‰I ›&É0QH(DA!¢4 LCJ%0"¢‘)±$BAf(`‰$f€ÂI¨Äc&F”ÄšXÍÆd4ÑJQ¤¤Ñ¢¢ˆ0d)$´hš0I bHQ´lX,BFŠ(¤¤£$F‚ÉŠf b$bŠ*(b’¢’Šbh”M&™’6dË %¢Œ`Å")%©–,ËDŠˆ)3,–"”’1¤" ÌôêžÄ›$¸*ö—ÊYz)µ]ö&­V^"´‡Êú·Mæbxâwâ”ïJeZ•mvǵ'­î¢Çz֨誛ո¬—»f-ÍP§¦ë®©bªfËsK¼ñD§°‡{%¤SzÜt]wnú7›—f‚èr«ŠØÛzéE×MÔc1ˆÆ&•Su ² MCA^Y1dš5"rFËf&í·Ü.5¾öŒsR¦Q.tœÆ`f1b²ac‡$­$´¥°#^ùïÎ}ñ¨±•W™á*Ÿ<÷¾ï#ïëETUO†ðùm©øU³3õÌ:YÇŠŽÓ¬ûJÑ¿ÀÓ]ËŽó)Né¯ÇoJóWn)4©Þb+%1Tú54Ó'<´›µO•L+}°Ó’²ÇV©ŒT¬Uc7U¿-·jR°yÓêÒ×M§GŽ}Ö§S1:V™2Æœfô¬xdÛÜ*’±ÒñÓ=2k}:JRª¢•J¥)Uéªq8ÃÇŸÙ¾2aVc&O¯¶«ÓÈòQ*•UUH•ì•Ò””’Ò[I%!U%*UvêZâ—OML•íŽÜ{µ;–x'Tiuï‚CÁŒÛF’¸åß¿Ç w^Ï Úµ1á<*ªU*¢UU*•J§70VÊÕf»Ô†¯Eå½RRI$¶IIJRÒ””””–JJJ•%UUU )R«G £u&*+ŒÇ*V4Òš&˜ª¦šVŽ”î³gnÔU¥-$”’Ie)m%”¥”¥ULzöðÒvÒ±Rª´¥V:©¦Ø™M½ó§JQI,’–JõË¥•–J²Êªª•UJSÅ*W]qŠµ†4mMšl¬4ÚUUNËn•’´’RRIT”–I+%’É%©*JKd©Ie%d¤©-IY*J–UIl’JRZRJÉId•-¤©)KeE*ETUÇiJ•UVK*J’ÒÒ¤²”¥%II$’¥d¬¤²Ë*’ÉjT²É%’’[)d¤²ÊY)K$¥IRT”´’RJIIRWŠÄ*R•ŠÂŠT¥*ªR¤¤’´’É%–I)+,’©+I,©$ºë¥)%%’–É[Id¢©4”B„<Ž ¼ŒH0ø;i,Ž4sÝÆéHÓ#Ü>`[íß/p?=]ÏNwŽ.¬“­ak¥ªˆ‡”M¿}ÙÊ•\2¹5šÂ£K-kMª­—ÎNiõïÇ &²Ñ•‘K U¨˜™ àŸLë=Rláxkã¤üïÁ¾©;˜‡Øw8ý¯¾-Ý#ÆŽú’a^BüSÆxžEô¨poÞ¶xkèn¶Ñ>s†î/,ª¶•µV™É£m§¤õè–Ò÷>E&•¹”Ó+V˨ žNw3\·ŸŸ]Ú}2ôù[ßW‡àûYtx¼u^;NåwÖÜ3;™ó°‰•‰ÔLŽN¤­ö’j$ µt渢Ùcš9RM,“lÌŒÊ,ÉFb¬©&Y(Q–Ö7,8–WEȵð9l³CdG%ÂçsJ[A´£i‰E*¢•JU -%II$•JY%•¥-’ÒKIl•,’T•JªªJ+ã4™rpÉ¥KÒhž7_µÑn½×Õ%6cÑt|¼/·ÌHz½7™ 9î}äøëkî'açÚ<ÓÈƳë³Þ¥2=}e{¶ËåÄ¥æ'ÁÃoN:¾N¯»©ò">|¥;~¯Á;}8îŒù_Ïöš}Õq^o4ßyö%~MÌÃÃÅÔéɆ'Ó Tcí?!/UébMš6[goQ)¤qfwž¦<çNNU<^üwñ.K櫵kÅ7¥w¼±†ýW%ÏÄò‰CU[¨J…P´ˆª‘×Ô}‚î=ÙU«6¢ƒJ­*–Õ¦,±L3,Q–Œe*bË.«%Z7]|Ín ¸pJLú{{Ú‡”©Qœ’U‹*ت´öxü6¶XÁµ §Ÿ½“ä[‹ŸeÅyxÑ7»,Ivœ,“F-ɲéMMHWAÒn‘ §™ÈŒ³ßMY&¥[[Ÿû_<ɤÜÕªù3S#&[».±dÙJ %”³uîW•yK^]ºÅ©Ic·nÄ„Šë·fF’É™¹tÖòjæ¤ÒÌÔ¶Sή”I¢uݜ✹•ÒÞK¯.¯%»)¥UIT‹XUXîé0“"H4©¼•·IK$´’Ù\»K$²²Ie’T´²•’²Ye,²T¤ÉY$´•’T©i,–¤¤²RÊK*R•%”’©i%,’I,²IIJJI-%IIjJ¤¥$¤µ’¤©-²T–¤’Õ’Lc&1 bÒ#uòÛU'Z „éX•Q'Râ¤ÉÆ®ÆXÔvس±½±2R®Õ£¤bÙÅÌI6°¹ô¥vß–Ës{ä-ÄЈÛFE[¥X!\Òß%4ºÓë}?/ÕÎeSŸ®Ô(Íg1£–CÇÒ>seq2š# 8i+ÆMÚ%+¯_ÁW|BmF6%RX¥ i6+“m²”R’ÙeK)TÊR¢$µ,¢kKmªlÓIf²©fI+l“Mm)ˆ–•–T”[Sc-&–“¬Km”ÒRʆ´µi’Ö6e¶¦ j[j³Qk4ÆÅ––h‚YT“DƘړJd¤µ‘J²Q&Äl­f‘’¦eH”ÆÊV–ØÛJ³fÉf¥™š­12‰±²Y-h™JŒÃm%kM´ÖÊ–BÌ[f̵KM$¥-X¦ËkL×ÁV÷«}·ã4÷e 4ÍBowe¥ïÐ٬ܻoe¨öåºöçdBŽMã•í@Ýj»Ž XñˆÉ’yîóŒºòØCg–꼫sòjçt¼¬}ôì¾õ–£Æ8¸<©\Y¦4;¸Z­2?=nL¼NO£ Œ< %µ÷êúçÍ»eŽÉuFD§W„]‘¿ê˜ÆX˼‰\h»Ø]Ùã‘m›eJÓŒ–4Q¤Ö•Sg‘C•ëª¶oz4ÒÕ†cMK@öµÐ¯ip/Çê÷©îªc!¿²jåy+^‰} s¸¹nŒ˜ÆU„:ˆ‘èqG yÖcæÚ6\Šƒy;*ï\JÐNkи­ÎË/cæí£åTâ‘xÂì4{9RúXqÃ`ú¡©<ó’ߥT} mXûK~ó»ß{Îkµe0óý¿–ÕðnUpÅéG¡i-½• û”RékÙ²›~[ÙôͱU-F¶’Û, ÈÊLVRXLeFL •U (ƒß}§[>sâŸ[kM­ö—šÓVØÆVY>}íö<\5Ÿg5ŒtÜé¬V’wé‘ϧOêêA]¯ÈúÖâ¸Ø&X²ÉŒf\‘9Û«tç·­œx\j¹*rª_î_)c†ë¨Þ¾ÿ¡Êã™ä­MªÔjM5i,Á’eX°±e11jjê‰@{Ã(ãý€ìÞÓˆñÒ½– ¾±ÂCº§»ÀB%"èÑ" à  &—GQ°DÈ6‚it ¿Mƒ?{=Ôª^žW'}g½»ËïGü'wNZÆåÙÁëz+Ñ+M¤õuç“©ÎR8œ!Æ™ÿ8ðÁbD-ýÇðüù}öùõORÒ=K(/É"úb-ÏE>!,8¡"LÉYQ‚š3XˆÈª\ ûßêÛœ^:…qe¸u{Ý[oc¹ÕéÅ´¤pø}ogo<å‹rø]iT ;W@‹R“®”Ji~áJ†±}ç@d{€DÀÐÀ’ðjOP#½p è…DŒÆf% 8æ[ 8„[óV ¡‡»†˜aã¾ v¹”V¸KæpͽǹH¬nÏ^èlaô?Qîzn¯O;ìR+ÓïxžoRH/¼K`2׌È]ƒ!9ŠÀj—S!ˆ&\R@ +Íç<{·+Ù­?[ƒÞß¿Kùþ¬¤y“»è½ŸâÒU.ŸnÛ~¶®³·pfoâÛêU/"û›6ú9ºY™6n¹èéñ/Ãw=ãG*U-ï‹áætâ•KjrË6êužYHíxB½€c‰·ö”P ’A~a0V¦[r‚) kë€A$‹âÙÚuµ“Ë_Î<Ö™Ÿ_Þ=WÙõÞ×ÉÎ9Ú‡—¿¶÷jÙ‘Ò?Kú=Í×àüæŸYdõü)ÞØ5Ðü]΃.>mµÙNÚ21·†ïVÛrõ&tIð¼]§å½‘" Gx{ ƒå/´t{TG28ÛÂH2ˆ1…²&¥‘¥„cÌ<¦Ä^x²­¾ësg¥´iÖ¹òǬÑð¯i¨ÝŸ·?b¿¡ú}¯ øÛ:ÆÇwÉÇÜó×nVUÝw×ß[õõž?/+’Ìd’Ú÷$HŸ&†Š¶Ç{òÔضǷÑ/Õó¯[t¯\Óð´ŸLñä~/SUþÌ—TÔ´šj[WÜ6¾ä/‰DIID*¤H‘ca"f‰¹Ó“ήZîÝ î®iyåÏ:d³»tŒ¹È»‰uÏÎK®wNâê\ì;¹ÝÜf»¢í$Û»M¹Ós »‰Ü]y9âÑ‹D@`‚Rƒ’JHÄAZ‰$b 4€EcKdéÜìc–æäs0λ¹Îé4wvºÞioGeˆ¦«›Æ)VÕ°ÌkPÌÃ,f0 ˆŒ‘"\Æ€²b®î®mÈä…£¹ÛŽêèzœ·+Šîå×q£;™;®Ç;½^vex×+zL—.z—ŠñƒDn»¤Â&¹éË…®îÜѼóžQ«Ñ¹®$\î4‚¢µBÄ’ZŠ‚¬)¸@¨Qâ4W]v¹c2½<íráÈÈRlî׈×4W £!ÝwuÒÞ:lgu¼=9ܧn†ó¹—zI×nuö¼”s^M¼˜Åâ+oGŠñ­s†Í4ÂÚ Æà $‚A!Â:ºrõóý:0O±ÚÿÎLƳÁm¡¶â©r™W$qY.ºf] +Ø–ðHÃ&n\ßO…⻂Š3Ô»Áø¶¤ÝÉo ]Àq­r3`mÀöÔs©ô2v[žN¦óÈÿ }Ç÷à6«Ç;ƒ5ÞsîÁvž¯‡õHÛ¦Ž×åó ;½ÓÂÄÙžØjü€>+¡¸îkûãº]¾÷Üõ€üDû9\Àø›Ùrèž_ÒlFúpÿM¸;äO Pâòrp}ìë_®ùFdk¹$ÈâtÏþŽxÄÒß‘ƒq-òß¾]MÇ=­øÚä‚tz‹7ù>m—;ÃËü¡÷ã3ú«ÍFå¯q„F‹ˆ]ïÚöy× €-Ö/…§×[þ+€8Më…d.MëÑæ÷X3Ÿ÷Äÿ±x1è–X Ç!Îgc²×yºµ ØöÔNg½³t€m|ŸÞ÷y|d®Â;@1Wù:õ¿hP†ÂÀ¥nÇÌ·â^w²# ý¥|e§åÆÒ"jýC†Ñ?¡#ø ? weñêùh£c˧ÜÊs9Ï„l/»¬{DàüWœËa·>ÕS9Ì°€êYM§#”鹇¨ýV£ç]#L€ ¡ÕÖc© i‘u ËÎÍ¿¬÷ŧ ˆÚ}; EÕµPG©Ûq e 2Ðáwæ8ÏÞ‹Yýø_q˜~[¬°l‰µÊèF¸?ÉJÕɵ$uDÚ°;47ê¢ õËÝAØC ÃØèã[?é m‘—²ã`á® Œòì}Î]÷1Ià"jåHêë°lx>_«Úñ4qÿÌe6£ä±ëgö×<‡þx9ít\ÿÈ0¸Fd,·ì`GìT¹@Ÿá.³ƒŒÜxƒJ;61Ûöí²`‡?Fu¼D»wMï»÷ŒŸÃÛKá>=óÃzl‚ÈÇ@ˆyÒ^ '{™q«Ð?zŽ}~Üq”ˆXZIj{~#ïüß@×€m=æF‘…rÍ‘mn·µÑ-–7ÈЕßø´nz›MßmâofM³Þ4÷zgCÁA$Q·f«-âaí,ßr~áý¶0‘ç?>¯îÑ^GóþL¦w“õáÖbu¹–HÏw]·…âøú«h¼½r;ÿ²_Š>‰qñ£­Wy9ïG™¬ÕI…‰é1ÛnG‡9é©Æ9ãŬ-P‚Á è‰-ØO4oØál $"Äɹ~‘‰³‘ˆRó‘>*È q"“¾ySSÐÄWÔ4²¼Ñ"8Hc¢ d‰nqÜ`®£Jó5Ñã8ܹò.#7b1!£ò@ƒ0DÀ#£8?*)¯‰"J$¼"Pd‡"ŽÆÄg“¯yQC®C0QèTëѳK¥sJ¬û&ÓÂ5µ¤NV’%µbÃÓlíö>p'2¬°5¼›7jÖÎkFT{­²«> ó#Cg8G“O´üÖI¶©^ ¨E&Œ"ÚsŒ¹EÔuPtº€ˆA$J' º©I·]­t“ZLuv2ȦÊIT©RƤ6ÆÒ&IªjYl•I¥ •²”­ÊåóL¿¢ýoY{—óÂ$„˜Ä[%ŠªÌÚ”²š[ùµlÝ4´Z’ÆZT©)i6›eiQ¬Ú¤Öa¶Ói¥Sjƒj…¥^Ûjã-¢ Úš÷[ó:ÔÂôîn-k1}›»Ü $ã³g¹EF¼²¢ö+X¬Ç]ÄÔvA=BÓQù¡-‘øÖ¯sVÙ\Í¡» Ìëy¼Öº¤›°—®u0›¢~NõÖt^fn­|ß.>Œr-†¤1öH0)Ò&Ù*txE½P*Š4›‘­F’ìi’#Ù_ΣJkTf±Ùu…cX$’A €I‚ $”/zQçšy¶¾jÕ½6XÍfVm‚ØÕ+D-Š¯Ÿ+¦ÚŠ¤´+ÎÛ£Zm”Ý5vkvs3T+SE•Š”ŒR>ÍâØÍ›«_ºW6Mdµ”‰jI÷óçá³ÞùîóS™ôö™¶ky'‹$´­´)²›dµíÍ«_„mxªþ¨JŠÄÓ?š¨¡ú|J™”³-ª6+UŠ±b6´Ëª·–ͨMZËê=nko´ÚÙªß |¥ûé˜DºëŸÿ‹¹"œ(H6C¤€cards/data/ADSL.rda0000644000176200001440000002721215053134244013477 0ustar liggesusersBZh91AY&SY}¨#éÉÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþÿÿÿÿà?_s¡80/©õx¶7ƒ4q>x 8ž"ÝÉÐj@@@o(zçGŠ»¯Ï;9ÞëÏï=¶ovíë¹Û=Ï9Ã5\ç¼ÁÇ€ èˆA ÐÈ= éãÙèPôÏzw|œ»Ûç®Z÷Ǿ}ì8Šb˜™hÐ)áOLh ¡“##Ié©âOChƒLš˜†& §é©êŸ„ÐhÑ3CCL#C©é¥<žƒ#AL dÔÄð!¢fE™¤SjÐŒš 4ÓM=OP €Ð@ 4žID„¦È¦M ÔÓFƒM£L€Ð4 ÒA  Iê¥&ÒdôЀh(A€M1 i£Fš2 …= DØTÿU?SÕ?TýÓ)é©ê=OQ²š=CjdyLƒC!§¤~©¦š PÑ õ µM2ÔÐ ‰ =Sõ54É£Ó) =CÔ44z€hz€4h4 €h4@?ÁäRDŸ‹bØA;€¯§þ,õ7¬ÍÝ i¤«äI¤¤Äàà”ØfÚë»+›wEf°»²’g‡&fsô,™ßÉ9Þ«É:X0J_ 5BK¤Ñ.Œ©– ̸t %„) Åh"ßC¢ÆÛDjΗÄ×4éeb—‰ŸÞƒÞdd\vÕoñ,7ç£Ízö×Ì9wÜ?­gý±Ñ«î¢E;"å¥É;úó!å\l€lñdê`ú •úî¦=×· ˜•Ò8þáŠtÔä“~r#…ØÝð͇PŠt2j?#c9ÆÊÐö®ýâ¢óö¬mxZ™%&ûØMâoÅ*€HDßÜWóü~Æ:å멸äºA˜Ç$a%Qü²æ©4˜®6‚þIMG`_›45&J ‘Ç@Ç·"ˆnôÂ0w"Èß×ìußS½ZÞ®sÄõ¸žçÊçh·¯«À؇=]ÒæAéìlu®Ý8Ñ#HàöG4 ¯9Ê‹ÕÚ(€ä_‚BHjøˆQœ².oV‰‘Ë­‚“~c(j4tDž)EžŽ…ѪMxv®*'ŠÃ{ˉaˉ ß)ª®’I.ºG®9?.™5TYòÝ$'"Ÿ8Þë |èYz:-ùq‚Weû®,töi»žšqzt®PäRçÛ¬”¼s>OŸ Q}1¾Ý´=Bãµ.ïÙíö4Whƒs›Ò›…<±ÈíûÏ9šzäÝ·aß• ªzøèè£Û8@žœé#¨æ¸0yö/‹éç¸ç&}‡¯ø· ¿,ê~UÛìr/Ñ™ÓÔ{bcœ¿L9ϧ—@çœü.'ŸOUü%.¾]iÅq%ìTõÕ½Ä_ø¸‘ƒž"©CqÀã;*vÕGWTrv‹ Õø9 Š…çÖÙCgüK’TJª—ãFyqqŸª®ËpË°Jju•ÄØ*€PHŠ(¦móOâ¼/ßæk¹û~kÆ@æ»{ß*ÏNž óâ<_EÑå›sËŸD1³ÑÎ0ÀЙ„p=°_D…6¬Cg,•rGì¾ µA€X€aáâ¦hþ9ûoz|‡ƒçÕÑýËÄ¡¾_ä{ÿ!ã˜BŠUibZi«lˆ¨×”ö¡jV_\,áƒ+jB*·/»:¤rVmjÉ4&i˜ýO³NOà@:ýžwþþ„?$’7ŸŽä"HñüàÎ黂ñÝ}Ý· h[½ùôH”«u^§öß™ª_÷]Õá«MÚ™0€ ¿Âá2Ü~Ìæpìrt}- =÷áéÎHlî^þEÝ ªøÉŒdD ŠýJªÅUïºóÍ ’²B*YIRTR " ‹R(¢‘R•$’y ‰#ÏYalí’¶É XJ’$ZBBÕ’‰eO’ç‰$ùsÊûw´®eϤò^;N3OZÝ>lŸ÷Æ[L5²SüùdýφÏ+YPK“° ­LeSt‚}}SÀª ‹d¸øyiÔëú>¡ìÛµ—´OPú»¹zº×Ý'ç1Ķr]¯½±’Á²¨# @’#”ðVD- `výYm¹)†ˆ…Jd•‚$HH0tæäDM!¤fhLÍ0’1‰"FG{uÆh”ÈB¥‰CHÓ hš)e&dÙ‘R$Y(É‘4&e ™“R$¥(”“DDZÙ›)È¢i”ÌfP¢LÄÉ×rá`ÁA‰a`£a¢ÉmAFbË#&3ÌRP‰É°[fQ¥4RZ(Iš¦F‹DÌÚ"ÄVÄšL"VÔZ mIlVj#k¢ÑUn-q©A b€š5ý C¨ ëªø®¹vÀƒÉdI:‹Ò‰Ðk¤’:'A5œð8±Ø·s»[•×XŠ2HL™’„‰ 4K”bL˜šdFïW„±ˆÂ"‰ï0ô´Ï¬Ï£Fl4Ý&|Ùôã(S&<ê³L.Ô^Lé—}5[Üíí\Æ’®•‰Û*—f8“†«uË¡ÄÑ»&Š±±›Q5c+Tf,²jN«ÉÝ;®ñ‹"iC«Àuô³µqZ¯opÅ«‰¤]h›Å¸l(¨}—Ûœ¨•qJ^jj^µ@£+ns* 9fvWh$1"<|׳=­®Æ65Y )-FÑFÅ #ðyW'Â/¯æN žÖz "²+ iˆ%bÑmɵѪò=m¶éÞïà€ˆÈ6‰]Á—g€úîóÁOÖç¿wý÷og.xsì…%))Dì””¥)(R” R(¢RŠRR’R’ŠSµËŽ~qâõÕ-vøíÞ›×’Üa ‚ðÎwܧN‰7^nG9êïº[‘Ž¼ðDð÷‡Æ„ž‹îv•Ž  ˆu_ÜÆhÂ#€`~ìð]ï{àê=¸#Ãw¨xaÞÕ˜Jl»¼¸1AXª:"'n^æ+#9pžiÍcÝlƒPù ÕNfÑ–äEÜ’¥öiRUõ æZµè«Ov÷Bæ§Õɘ¸—xÜ4VTCÈxZõŠ/2¢áÆX{$­|AçVºÂ²¬ÛÓÂrû–eÌj/³b¢vâ¯Sí§ Fë›WrïSržóKÔDw î9±2¦_›4¬“z`eî@*&Få%[•ÕwK-ÞÞÎUñÂT_vd^UfäfN˜˜0ó^´U¶ ¨Ý¼Õ\j݃9Qy¯sª©EŠàÜÇÍáìÚל¼F/&ùxãÊc‘®ˆ™å]Ÿ¥ú!÷§8zJc,MEËÙÏ2IÂæ&FQˆ‡©Ú×­špVÑ·¡o"6mê#(݃HI D:ƒ3˜ð©I}›zHk¼]n‡×W™{9ºžK„wtxš$–Ò^SåjÊKäŒ"©ÞbK—±li«ÚçšÛmà{þÿ Á¼Gâç8Y‰u(}OpT5ì <DZ¦¡ ,ò?®ëjgg„"Ån,Íœ¯¶¶€x6žþ]×½Ïkºô¯Ú¯]Ø\aí© 5©8}=¢¯)^RWÞØÄÊ#DWX*Xˆ›´((å dúÍ=½ìó(…T2Vˆ°üš+@û%#ôˆÞ­*ó0. ª×ECÅô¾OÅúîÏÅò|Ÿ#ȶRï‘пÛãáw?ëF|Ó£:Y¹w‡Wk•&kWo’›»ézˆoýµŸ¾á§1F÷—Ô°ª¸j Õï¼-¤>œ@ãWJoÙuÍ‹µ½m³M2’™wÆ®{®É`Öµ+Éä…š—ÒÏ­ +i ל]ÕiÜÄ¡íÒÀ¥%e_>Nóö5.-Ìäs:÷q÷dåõ»¢¸x<êþ®ëªôõfd 5¾´JêÐð/ ryｦͧ2/8L‡'®{4„$@ðv^·sFI$ÔÝ“¬xÚº}ï_*½ÿ‘…iÞv]½½©›!n½ÎÞÏÎÎämÔ˜Å1{²)¤ @ ± H±f$Å'§$åUÀé ‹$$H%D;½]½z{¼é2`ˆ$òò6´=“wâq€¢ Ä$‚µâ©¶–q¬†CA1n*6æ50BE!$²)îñB#^îÎì*¬ ÖF–`J56åíÝê…dF $0 HÃçž8ê]¼õMp'B I$¢I I³ –Ào"gh»ÃÕ@£s ä%eU—zrâ3]îTÕÆAµ‰Æ¹l(X $À w5ñ^a‚r3Ò{x5 !³!ÖX^NLꢃâ‰ZýË­ÓJPƒ)Û˯Ws¥Óº.´Æ̼D5 ˆ.„J{j™¨SÔFëÄíP˜r¶åQI@Ù‘HÌnðµ!T¬Ê‘Šš|U4¨ÃB݇½­ÙoUU—"(½ª!ñãE«Wà”õUw¢‰EʉyÉÍ:bï–ïf©8¸„becÎ…€§Ç™ˆ¬ 0Ëd¢‹‰Y"uðÀÍ{z[K|»2„ˆRÓ'6j²œ½ŒW1häª6¢’¥Ê¹È‡•Ⱦ¾Å #6áá`‰«šƒ*šÂîæv檯a÷N$ú^6*Hfffïœf ã<Ⱦüu³P‘9–ÂëNÿº{âÜn Ü-Jv6Í„VHŽÊ P®Õw7/µ­·vÂÖ¶·nX²M u@Ä0È,bÅosÌæ×VµÀ» ãixˆnªË¤‚ð›÷ˆ&6»'÷T-ZÚôUp/„EH /Û «p^¢« ð»〠¥j¡h¤0…åÇg‰&³[ÚN!KV¬’`b–‘l“"U‹bÕÒLˆ¶&J«JT²ÐÑ“—åË”[©[®¹ ÈȉA(V—ØZÖµ´dU Ä&ùk—Þ÷¹$‹U .¥÷\jVÖVå‘I"ÖÖ gù©“0:@ðöË ‹<º:OkœöTÆ'yÓêì'IÇN°´L¤„–å‚Ñ*ÁVŒR Mˆ/·Þ«‰X337%ˆ&JCD›£  "Å’Ûm·Km½çƒ­Î:mºí%’ÆÂÚì½s€Ëœ9s€¹À\à.p\à¹À]+·³®×9Í]$Ek°eÎËœåÎËœ—8¥kw;}/¥Eb£hÔZ´XØ´kTëmtëÝéµÍŠÔ¦Ô¶Ý˹À—8yjîóTì«Ut–Ó-ev]€.p9s€.p—8eérH¼L’I°€gAŠ€1@’É5㳉3víàm% Ï|ƒ3¦ÄáƒËRsçÏd]krr ≽o§Ö·¾"l5yr#5¬¾¤;-Ùëfj‚Ù妹Ðzšª¨–fg0î”È ‘UT‚AŠbÈ‘ˆÍ¦ð =4ã’´ýÃp„"f’MRm&¤É­"$4±4( £¾Úœ^ØI$”g=Ã3DÐVµ¨34NzÖà%k¯pk슥®¾ .­¿0Ö¸d$â.É ’ewfHÛ³2öîñ’Cm®PkÄ:{Õj€!p…ø¼v0ÚÚà [%¬ú¶³6ÆŒ%QA2D’H¤ bR$ H'FÆêɧ{¶¡–wqC›Ø9@Ö µLÚÉ­Ö*ɪŠ±µ‰–Ð 6°-má+ÇVˆ46ÆœéΖ“lYTóku'[5$¹ Î‹‰.³Àk)[" R" øŸ?óÔüˆ’ „‚VV’yÛtÛ¯ÑsÎÐoþ´>šî]7ýÿàáðÔnÍr¨hŠ>«'PU\½…UuxIÖZµ§º×Qåþ7Þm‚¦]G*kýÆñ@!ðwög=R–p5pÐ@üYÞc†B «Nø¢ƒÊÝ芫Ô,ï4QÖÆ¿\:ŽfШæUW5ê6È—Š¶{ïél¨ýï¬mbö¡œØ4ñPØ°(ÜEœt×ÙøÕt¹8xo¨ª³Æ÷ 6ãeÝÑ2tyÑu{œùS/úÝÊsÿ±<õ\i`ž'Π}¨"rÎQMÍí¡Aòà(ð@K‹SšÊM¿Ô «¹Ì_£p¢òvuƒg'W—Ÿ[™æ›©@€©Õ^Îm©L´$ ù÷U;šŠ¦éP C®ªèŠéÎM½„Ú­õ9þ¿Ô{LŠ™sljž§¡.<Ø›! ì¡Ó6 üÔ½ÈJ´Æ-¼Á×^FÔʨªQ[Tˆ„ˆÎ` µäž3v«˜Sã±8^…ŽUy¼ªl=g£ "ªæȺu…UÝ”C@–Å9bªÝ†ÊC Càæh‰ð‘aàÖ‹õÿQRª ”`™âßSŒ9ëÓ–£ÑòÂÊ–Ô*­Ã¸*6¡è"ªðšrå —º ÷)›-OkLfš0cDMË¥º(ÍAýŒB#úÔ­JèšØZ‘³µ¹N1ˆæA 91ó–H-;þRT¯YTuª¾a´œ,¶íø¹Ð”Xâ{t–ëÄÏ¥Pwͨ…7)œö€³(C ¹æý\U°ª¿v ­€¸8ø:LˆHaUfð‚Qé—@Z¡1Ô±o@ëtÌ™D ª¼q†[÷4í`Ï…¹È,Ä "ªöqUl*6¾å¸j‚ %W£Ç,PTáW@k³ÓÐSê”/ÜÕ‘U^†^>`T缂owÎ@ãnçºöã:ÁUvVÖ3›¼K–õ¼s´Ð¸ž:Ï£R½ºzñé—é±M·y/…×­ÅŠ(¤P’(°š,Z4Æ‹u×[VÛÅ\ «Ç Ê¢©Nôľ· ºœB£µ4®ßÍ”q¨€L Ãn6ìœToÏ—@t]ùÚȇŸµÎ¸„@ÑÅ[\ ½¼Å~n>Æ,¡¦­ÖÔ ™ASoè\*ø¦Fé‚ŽEä¨à¥»Èh¯ZižÀ'Tö£û*Që›ÐE#ሮ¡UDc)N£CàPÓ£mÔº‚a9Ha¡ý$Z©TLÀ5H" @@PŠÃô"ØhFõ”9^-ª}¦íÖÇõô Î?¯ßŸ[Sé‹ÔÏ›èÛ;ušĆœäDå†ÚpTwðþ;ó~ÌþkÓ×<î¿»ì¼2¯L&:ÔæäÔ ]Zø!¬Ö–—q;ƒºÆ#¹©Í;NbDqæ|A‹#§Â° ´Ç!¸@J¹”÷kæ;‰xøé 3" aQ¼ eƒ2вH ^¶ZöCñ¶ëòTx;S`.5ABoïN|ãí¤ ‚^èkŸJÀTÂùr% %´9nµÉSKDwÝSÄqáåq"1A:$‰Ý:õý· ðÞønc±N»Ô퀓X£M´dYFF‘„¢ÂhÔXØѤI &žhm9ÚwÚ/qLM¿Í´ ¹4(÷<Uu\ª !°s¬*ƒØ<ÿˆB|·þfD™DȳþˆéèÕ ¼nÃ7o$7jò;¼×›³“y9…¶é(íáKú\HÞAg ÒY±Be$º÷}÷‰þNûÛ~E÷׸O÷.8ê=P³tZ½ÈkS!Hr1š8ùJÚ4á'}Â74³+ùsÅ9@æòf¨RH¢=>ôª=ØÇ­öôd,3"^•ýŒ­|Fy`’€¡â¶j>æyŽÂv'Æ*C|"SOG|pc÷{ÞÒĨ‚ä(o½ýcX“àïr7-¦v&Öc@‰Ç¥_FHJ€Yˆô6öà»( ‰ÀžŽÉd„GT‰è–N€ðB¿¿õ¶”ûæ!º[w*™:­öÀõø¸VÆ·M¼—š 2pçÜ¢†.Nƒ¼ Í§c¯®ùÇÏn]sz °ÀûJô—*9ZŸ˜û“†ËÑ'øñ‘;c‹ŠU^g— ×ÍݽP ²@íFê’ç>ÔÅ––"IÀ?wRÖ)Û”~Æ” B„7;žëÀÞîÎ¥;ÿKÀ3Ž9M˜l•¦½ÒÞ½-slmi C¦¶kä{¿ñÆw]#þ³µ‰}d/hE#_ $M;:ÞÂDõ/´y×~“*ßd¶1˜ÁJ®¶±7]Ç_%Ïpm牤ÑÝâìÝ-µ¯íi,cä)ç·_ŸæÎÈS^—:e@²Î!œCF»—Âf|€¦xDý?Ög±`ÐúdÀF¸#ï2(W>ßÔÃûûZ<Þã V•òå½j÷_?¸èô¨$„d„d@1³$B""Á²PQcQ£Rd$P$VÖ·Cv´ ä÷WY´„|ú_ïèS«ã¿O!Ï:þ• üuÿw…_düðLÄɦ§™³S[èÖë4›ænVíï&cIg­KJ㊌âXûŒ{~ê3Õ¸õ>/¯pÞ'k>ëµæܱb£P€KãQ¦º¬¬\3¿Ôgç²<¾Î±g±,íùËÇiÖ®¾sÉ÷0°Xžì 7Õº3ñè_-Û¨VèJSÙ;Àû=Ï_öÛ>Àíøß"»ØÉžþ»¼†%náhŒKÑ&©u}áßcùÖ„I©¨áÌãŽgŸ’oq"/ ¨y3c¹Ü<ûÏÄà|½g…²ÈW&xN6K! œ1šåõCLo€îîÇ}6F ›S&uðî8qÈ8@Ŭ,Æ cZE²%dµ’Þ÷䵎)u‰>gÿ>vç™ßUÕ†f3D‹+Ì<Ä%?$…LLP¤âTDÌË"ÃÅ!É»¤Ò…ávºJ߬ß'ÿµ•3&bB@J” ¹&A*G”ôÑóïMùôŸ(Ù"ëÆõù4 _F!¨3 ï›0âò§€dÍ£{K—M£n-œU²rÄìÊ]€§ñÂ×àP˜Ì¨€»=x4B›DÌYa×>0ýÈÖŒÓìðÞêG¹Í¼±ÆI^ÍÕ§“Jvm’‡KÚõztúÕõ½=<Ø×{‹Œs HRt@ÞµI)@ëü­OlíÜWNT B"À pC@Ðd4šª¦”~š§©í'¤žSÔõB M4iˆÉ©„z€d22y!´ƒÅJIhÂ&CI™LÑ@i£O@š 1¤Æ‘£A¦ž¦ÿa%Ry'õj¤-hÕPÊ)­e!iJ­fˆU‡êª$›]|ªCsöHm¦·•"ZÝâ‹ E±¹ Qq‰SÏ¢¦a&,$˜°d%LŸa*h¦nL½°«ŸH\4…ËH_è¡twü¡I™bfR¯èÒèR¥;SÔª­!f½zBàÍíûœ^ÿ© BsºÔ•Ió)lÂXæ´ŠÓéõðË)À ¤žF^@ª3%ReJ)Ç]ŽÖFÕ KëïITšÂGmçûßœÏí­¸ I.â~-E :ÃÇÜõ¶Š%7s….Ç¥®O}ùýÛøJ‰N”Wœï« !RتÖLÉE1R¦d¼Í¶(\àŽB…‚…é¥C„¥½J·”.…À%=2Sb…¢…±)Ð)lJzt…º³ŠÞ —3 FaUfœ_®¨ NŠºf)U¹Š¨iˆ¢c)6ÛyBáæ”,å(\©På)oR­å ˆ¡p NRSb…¢…±)ÊRØ”å¤-Ô…›T‰NwÈ”‰ÈÀF°ª¡¦Lb”Òåã/Á’ªü2R¢1 2‘I²û­´Ù€’™ÿ M¶‰xáÉ)Qo.¡D§ÊP»ã…°j±ÂP±¶JZ(YÏïÜO5ðžù…U aRcC*c ÜíôU^.ͶURœß£ÃÞ3^6öc¡p=kÙ¹áD§ñð ¿“«DK½(Y I… O¸(”ðÅD§4$®°¡aI<¼>`¥•"Sl %<…û `F,(XP°¡b¤ÅI… 𥢖ŠX¥X¥XP°¡aBÂ…‚S¦˜JaBÂ…¢•h¡h¡hP´Jh”–°”ÂS J,¤- DØ¡b•aBÅK P¼qBСl•Gª¹å jBØ#aUlP¶¤/ x¡h#¦`”ÁBÜ(Zš*L/ES&X0˜(]q)Ù©ä‚J“œP±RaBãŠ%8ŠBÜP¹ä¦Å b…±BØ”ý­ì ¦dLÅÌJMĦªªZÀRÌ*‹DªxÌ.!BñP¾‡^¨k"2QN™æg·HX¤(Ô¤Ö·(¦ì±…U™UC1 55Š)™DY•!|,JO%Š©,b©,Ê)… ™… UC0¡bŠ¦d”…”¢Ÿ–±Cÿ>f” ÚÉQLÊ‚bJ³*F*N±BÌÊ¡˜RÊK2¢™R¬(Y%Y”…™2ŠfU& L* ¢™(YHY”…”…‘K) T…¬Å!fRƒ µHZÁBÊBΧiå~î>³ñöEТS¨í %;^÷ÚìóŠ¢—M,f]°`W`Q)Ý %=Ðm}â©KoxQ)´ª”Ø¡{—DQ)¢ çŠ%=’UCÚöý¿çÀQWSSˆQ)Åàcb íŠ%0FàtÞ.õ¸(¾w»öJZlhñj¨ô·¨©ï¤ †<²¨¥ëk¿ú\Óð/ƒ…¢UCš±*¡Ë³¤çŠŽîæ<ÿ‡9J¢–ŸTRôwï~Qñªã¤æ>.’T‰ó?–µ”áð´YuT •T ývS‘U@ÇADÇ­§EN§©jrbZ\Á ¢y¶ž]>hPQ1Þg‡‰‰YÔVJÅfPJ\n‹Á*Š^«‘Ö*¥:ÁUò:= “sÊZøÛøJ_?»ìðE-rf½ÓnÞëKMž[½c' …Ñhª”ã)~G‰jÔTÞï’¦¨UµŸ²Iº(·‰SŽ"‹¡Ýß^üQ`ÇÌ%Lï4•1’¦þù*e¦i®gp#º¤.NZBñ© ï”/@#]à’·‰Ló¥¢Сx;ÿ¸¥¬¨¦¨¦”ªÖÛ¦Ržyb¤Â’‰„¦ŠVŠ„¦Á*š%4¤zKIÿÌPVI”Öj‡Û3ÀÌÿÿÿÿý×ßÿÿÿÿÿ¿ÿÿû:Ô±ú. |Ô³vÌœÊx·ÀA£FLƒM 4Ð2ƒÓ  ÓF44Ðd †##F#F#C Âi“@dÓ&2 44Ó@Èh CL&ƒMÐ4ÓA2Œ ƒ ¦M“Lš4dÈ4ÐÓM! h1 0š 4`@@hÓM@Èb24b4b42 &™4M2hhÑ“ ÓCM4 † Ä4Âh4Ñ £M4!ˆÈшшÐÈ0šdÐ4É A£FLƒM 4Ð2ƒÓ  ÓF44Ðd †##F#F#C Âi“@dÓ&€)I&¦D6SÓ@ éMªz™’xHö)é”ôM4ÚGé&Ô~¦„òž£ÔÓCe=LLžôFõ6¦Jl£ÔdiúMO¸Uó Jy• ¡:¥!õjØUC-¢Y#Q,Ê¢5#ZÓ(–j†ˆÊF¼ú´þ ¤× ¼ŠpÛ6’Xá´’Öâ7¨pÚ¡¾ª­ö‰k5¿ô9·Þ†ü(z_2¡óHû:†ÙôþJÊ«Ñ·Ô¨}Z ÿº‡Ú¨cÿ*>Ý ?÷Cè•ÃúHõho÷û´6χv¡žÎ¡í¨g·¡®m{C=õ ~m ~u gÆ#åPï?b‡ìÔ?j‡Û¡·îPß÷Hùô7õŽ‡?”¡¾xÞÒ†þ…å¡Óæôj>•<Úú”7ϯCÓ¨5 }šûT5øt7Û^Ú‡²#ÿ”?ûPÏoC^­Ý û¤}â=ùïÝgkY¬f³=ïã‰Q?Káåþ gÂkoš·MÕ £CuC,¡™ƒY5 OÅ"Yky%ŠÂ%ÍPÏ?T5Mé©fÅ â@\¿F†©KôŠôÄÁT™L¡ò9pø¼¾-RmͶ«•>>|z…síCTùGúhoú”8Sõ`-¿Z†8êPèýz5š”8üš|ÑÙT®=Ÿ1C©ò¨k£ö*òèsó¶ÆÊU¶­ù¸~Õ ß/x¡Ÿ»C‡üèkƒÂ‰vâ]ª,¡m³m5ü48ç #Í¡çÍ١Ƈ‡îvzQ.Ï‹ívÄ Ù¯ ¥#n%)b”¦ý‚”Ž%)ä¥#šR‘À¥#µÚ(YIuÑ¢…Û#ZE±eEHà#²ôH©¦ùe%œʤÓ&(v R3EU”;…^ëÈÉY+ûžÔQ׊‘Èd‹!¨e)b•ÈDÕHÕŒ’± 2V`ÆÊÌUŒÌÉ–eA’VC$KœŽD•Ý.}”:„òðªL¥b‚§±,ª…:{”-˜P±RÂ…Œæ#J¶#f¤ Ü¡jÂ…”…¬Æ$8‘À)h‚´Gáa"ƒÁF¯/ÉEQ3©îtâ_^†3ÓDµêP×C&µßŠ\}E=}f?‘­c2ÙJk²¡¶ðL6ÄÕT†[D´ª¼Ê‰j%Šˆ²† Â…„ˆÊ†¦1Š#"feŠK*F„e fD³$fB›(j ˜Íe !3(&aK*%S2•YCxa„¦T3ÊF™C$aK(f Â0FPÌ• Ê„d¥Š• # YT0†ÀŒ#T4FeCD`ŒÈŒ¨e ‘• ’0Œ#),# L#Â:Ú#U –”0Œ‘• #0FT3(`ŒÂ2†JY™Â2†`Œ#2¡’–T0FÀŒÊ†1C(c*#e #2†Ê’–R^BìÅ Ñ/eé}ƒB úJF úÕ*Ppú>oûøTúƒª úE õ Mêƨ<êƒÒP}aBë•}R…)ÉAð*%AôäAðêJøv*IAõjIAì‚: ¿'© ÑWäöß½Ìúòª‡cŠƒÇ*è*õ œ"¤Sà”.ÐJtwUIMä ¨ö¤n#Ý„¦è‹…Aܨ9T •7P~WPª¡Ô-”á)Õ*¨iAÒ#œ¡QÄ¡sÊ ”_–EHòŠP«aK¦Fë%E:Å b3B¥2¤/Ðx)Ò N%]AÓ¨0¡sˆÅAãÔ:ƒMH5 îÔE2ƒ¨G”Pºá)Ò(]Â…à{Ÿ*ƒ×•}`”ôÿÓ~ƒ×•T;ÞuR¯’GhGl„˜RéÊ%\Š¿¯PwŠRƒ²G>¿§±Â(^™*˜, +Ê*¨hP´RL.l(Z$‹*ž $S‘KDuˆÑ!0Œ#ÜÐ÷5 ͈ü¥A©AÀG’öžý¹JG^PyʃÎM(:銨;píC¬R² ’²Jí*‰(;A)Õ¥{(4¨2PoJ ¼”•zx¿hàR‘°T"Px°ï* ¤iA©‰\¥)‚ÿCﲆ»„•2;Un†ùüäMÿPëP͆Ùü3Õ¡æ}Åz¿v‡ÊûÔ9½jÃï¨pᧀGШwõêøïzÄœGv‡­ŸœGÊ¡óhgÏ#ÝÐÛÝPןC­ñ¨pó(vêoäÐõ¨o¯&†ÙäP÷µ ýÊå ¾ý »´5ýQ/†ÙC_‚†³^²†yT5™÷D{CØPüJÅ Ö¾ õH×ÓãPøî”<5ï‘jÿB%›|j›<gÌ¡öÈ÷t5žhË¡ìÈΓ§°4ŒÂ0ª°Œ)|RÐâJqç•p#€Œ„a#aRÂ0¥„aRùµ {ÊH—C^U mkœG=C©χC–ÚƇãÐ÷ÙC2’ùx’Ó),ÉC31CC2†e é‘Ô#ÂS?<4#„`IX#DaF˜RÅ\J¨c1±°ŒÝ*ýò¥TÑ„|`|~‘šÄÿùŠ É2šÈ…b—è'|ïÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿsûï€á=â÷z (T ±¶Åe··"àÔjá×¢•hj X4ƒj¥ …xÆз¶ ¥€!4 ;ï==Ì÷²QÐЫÛu¨ªm hï½Á*öÕ PR^Í@l†TÁÒ¢T ¡÷Ï}M ¦£‹5#CMPZ¬*€ (‘¢°Ö¥­($¢‰*… £@4f¯·S£Y¶Õ&­;‚÷¹^¶©)ì<ößmžùÐÎ9°´;¼ùt €X3Ö•P‘Eõ>íÀ_xzª¯¶PTªT‘R¢%RR%Nl°Rçg@¥wœê*ª„…’ª‰hÔT¢–·¡‰EURd*óèáݯ•A_=Ý0èzÈ!ÝܪúÉT ‡€å@Uä¾ï{îÑ* ¹õÕËÜ ‹€7v =÷¾L…™CTö2€W|ò¥%QéÀ›]Ôm}3ƒØœ³Cª+×o³½L†ƒf­÷·%%% ˜LÙŠT%Ò±u @J" €&Ôñ4Ñ£S hMªy4Äɦ™2dÀ)ƒSÐÑ6F£OM2h'¥<˜Ð)úML#i Ð›õ6“i¢ B4@F§y¦©°F“5&ò &d©ì£i=Sôjmi£DôÔž†“OF)ú$õ?Jz›SjyOLÆÕ6S54ýSC4Ѳ¦ChHDD@¦ÐšDÉ©êcMO&šýL“ô žM6D6“h™O)à&MOLi¦Ôôz2ÓõG©¦hÓÔm†¦É4ôÑ6™˜¨ÄôM0†j3Dò‚OT¥%Õ=ÓÒmCÔFš44È4ÐÐhÐhz†F†š4õÐÐC@M #@4¥)"4SÄ©¦h#d4È›DÍ dÑ© &hLÐИi6‚`2?@ †¤Ó„ô™m &ÓTöŠŸ¦ž‚›*)I4šbi©é‘“A¡1ò>i(iž¯–:'„ŒU:Ð)-+Â9’‡>„¢Rv™ÑEˆ Jùä:¡BÉU:‡µ/•©¢jjž*‰É¢–€‰ªªq‡«ˆè’‡UEOŽaj–w=G¼XÜu:(Ý3ÖI)©¥Žju0ïcU»8²ó·v/XL˜!ú™‚¬àÔzgC‚*D#Q† !EIRX(0X[6í!°×ÖªfX™R²ÔMí ¡2*Âj&EY(i&¦Q2*ÖhMbdUŠ†¸šÄÈ« ®LŠµ­ „È«lЛÈ«a¡C ›0ÐY–ØÔ‘I±mH1H5­4‚È@`\&ÃAVÃ( ¤*Ú`50o8JZµå› 8MJ2pš,H xpo§RÜe§n °Û3;µ»ºîÙܽ9¨©kº×mʹµÜðÍäy$@¦àRcc&$uÃ0ÌÜ03ˆâ:Ñìm6‰ÇNtý'vûÌ÷ÿÓŠßzûß7ßR/fw³~û¹?„Àhäc}_瀄oç.IúÚ ø»ùû{miO¾p½´„Ëʛ녠³øPæcOØæÓ•z•ÅûÍa øéõrm—Û8õÓ‰#AH4_É#ÅwþŠ»ÏñzØI´@þKµÖV/ÙŠâB½lB„WÓ?ÙÃv^‡†ÕˆJ³ËjMUüÖ pbâ!zõ6ÐÍebAl¯àv¦ÞM„©L2É´×Ô³‹X73உ"ë?æi÷Ü5³NÆŒÕ:w°«*|ŽÈKº#̈úA & *ámèÍ<š4JÞì,ÂÔ¢5vm¹wDmc^KX7ü˃Ýx&•víU{µ’Ò+è´”þ…‹O*ÿ¨²­ílFe1u®ëMñ4¸ ½ö© M‘âøëaú)u±Ôôz4bx‡¬€/#ÄD&@©Yýì±+7zþæ|’Íb¹Jîgrò¶H þnš—ÖXt+è4BF!q{»ýK0…VÔ*ÒD=m±U‚§ „œI§±Y²eg]$< 3³PˆgæõÂÂ1PQ|ù“&ÞW(æ²½ Lš !&V"SZ†½~Ë ¥÷±t«ÃðÕÄŠ~šla/o ÚÚ&†d\²ºé1QpÕáæ…çÖ*@#. X[PytEÖ¤¸Z² ¯«^,Lu ¢ ¨ƒ)Ç„ˆYÉ:cêÄvbT"I‚èÝôÆ£''”acLn×­œH (T)\âQ@€VNRQIIˆÉÆÎ!¬‚"^fØë\ÆL’ŠlˆPnqGëñÄP òS!ŒÆ¬¤ÂÁQ z­¼*›r¬»_‡5©JÊ•t[ß ]Äk>÷¯Ÿ/e:Ž}VÚhkay%ÌN"[ov>‘óiÛÄêžö..º¥WEÀœÎb˜N´¬!¸=û[×ÒÐÃN³­ËmbŒB¢ ¤³-VS‹ÑB °¦¹æ²Ô$ˆô#⼫‚±…ʤ|ΆùtB MQk6°éb ÷à_‹;VéðÄ8RBëÀFj­Û¹#k0âzï¾Ô#›³{뤷jzã ˆ‚$Ìo|¹t€À)Eûˆ„£%h¬­EºH°º.¼ŽHÍÚ AȈ"DÄXvVæ+£a­þ™} Æ×û÷mìµB9¾È°I!.w2­iˆÒ „Äi 0¢Š 1±Y{Uúúb'ðA$ @[¢Æ 1ƒ7 …ò·sYBï ̦þ«T®…q´¸éˆ|²‚h½€ˆšÏ@sÅãé“^Yô„s1(„EN­dõG:ln@DKïvÑa¾6 €™ ¥–çˆBë°ìn¶¥f"¢Y1ÀˆTDÑ}ÚTÔ 9¢H!†(ðB€B‚ "#Ê_ø(¦ð l”!BÆ@¬|ÆÐÚfC  ƒ "%C„+C:ÊÍlrÆAŒð†ð†ž¢Œ Û“ ‘Vßtݸ¶7ñ¶hÆñÓ~nZ˜À<¼XC*ÛQg)P8U—AE¤¾<¬ºJäbRîS !¤D2"1h´RR)IXð¾(áAN**vK>PÈn8MàF€†%gÂr (‡ ¬à!ù²à÷í»rÝ7$ÜÆàšEZÒ1½l  …aE'ÆBR²t°œ  ˆ¾r ÌK`!1.#yFãa”à@ÛYc:'$ÐØç- -†’ šŒÐJÐÊ6‚$Ð$¸ˆdäΫ½c–¤Þj$ b(Dn›óØìEE]žˆÊ‚ÛR†hz ˜žîc¹oâÊÉ)*´Hª‚ðUÊýL÷4dæc›¿YS›Ó5;UâβI4ô-.dYÐ ÆPÔúì^f±S±²©õ¸Y—-¸¤‡5øJÁÌÒTÙ EJ ëúj v@bjJÕÙán6Ýnj®ŒÊ”2ì½·x™rŒâf‹†3eWS0¼gf™àòS7ÎÓìwà÷kØ5î8I²wlsÕ£®kÓà“ŠlÛtËtTŠá»FØÍ8n ©¤ÄŽ›f%p³ ]ÌÚ•2Ú»•S°Šmšç„q4²B8œK;Dª‘[XÓa`òš¥’5ÜÙªj¨©þýí=Ÿ­î=þHÒ†“$ÉLRÖÈbÖ F`0Í£A¶D-‘LiC÷Ÿ>ï~ÿ÷{ï‚J‰ó‹¢Ï=«ËÑ1Ré¾|êñHÉï¼óݽG¡í1îø ž?Ÿ¦Ïòrÿgîªè“~PÚ9ó»«ÃI±´Úh4ogñ·½w§ %¹\Òn½—²ózJÅ8Ü2Òß]…Žƒ‹Moïý×+'-ò õ"B„‘¦Î(s¼Ç6>Žê¡öðéxcê7õ·TKg…ΣkÇ? Žœcß6½qìqvÝ×ÙV®Ì›3É-ª©ƒO>uAU3|VG(Š ª¦g·Çgã¯,Lî+¦Q´õÒ•6ßÃïj˜ÞèH8ÇÇ\-œ{:Óàë¯/ŒSe°Fõ5_׿”裓3¸¹œHª¥û[ œÀ(¦JÁìl¡ØID')TªF”e YQ)•!” VU ¨©`¤•3*©’XÊ—ò†*4,Ta1,¬,Ò¶-f¥lÒÛQ›mªõÞÂð]‡¦š¹­3üsfE_ÊQ¾C*RZû¾ÃÙó¼ã•Ã`TH7kø颕n좜hœ6FÌ™+3 EĦ]ß&ЛReJÐâòÌJ™¦¶J‰3±ŒÂ•¦HŒÂªÌ5b‘¦UV™UU¦F˜™•0ˆÌšb¤šeÌS2 Ø•[ ^ž$™kÊQ„Ø&„Ê•Ý%Ní(vòjRM¢d¡¤¡¶&Ü™VÛÖÖ½a(Á-¨Ù(“Vb¬Áe!„Ù&) ½H”ÚЛ‰CfPñ$Û¼ÊDÕ(d¡®MÄ¡´MJI¹&JJJJÂko[œ„Ì¢Ùá0¡µ”6„Ú“bPÛT¡¹&Ø78•mJò†Á0šäÖ¤<Öô–bYb[½LŠšbY‰cÆ bÒJ™R¦ë)%[œ•A$‚$1™*‡”0E©¾-åI©ûU°¸;ŠÇ ·ÑÖ³LÓþ\¯¶‚u–UFÚ2Kše-2¨ÁϯÞ'æÔô¯·O ýcBu1‹yø³7­*Ë}Óv×GRÁS~0µP%Y++žÈÞ’:Ѡׇ¯²ÆB‘ïô1«Ämýã_aÕvÞÖÊ‹)¸Z&‹¦VÑŽb¯a4¶«Ízï_»°Q±®îÆ#F•…3F=]Æ.rñºNvmy0ù-Õæ´Xôsb±FÞ®ù*ëW£¢‰s•^¦Ä}ýeÙìZ#ž"vqÈ"ÈÞ¬ Òy€£ÚITQ‰¶ÉÀîéîØ`Žæµ„Óm= ) P¡Q@tMŽu˜"$LR W$p{¢¡ÐBHÆ>®°‘M…ÑqÇ¥4¢¢!EϯWIð÷Z^‚K,#ÊÿQïiˆvÁbÚÔQô’ YTЉè+LK+$ÓÖ{N–½òÌàs”GoÃ.$k\A»4•³©mÕâÞƃ…#bÒ͹ðGí˜Ë—•®ÝÛ^Í,F¶#Y&{æT¢‘Qk¥8Tµ-S8¤i£ JŠ ò4P¯Y…ÆX¯]Å®8Nl0fQõV ¸ö iKjií½¸••8Õ˜b8ƒ“²‘®·@‡ ˆ„“Á%M*äãìË·°SîK%¤oÕYA°ˆhĵH”‘’Âañm*ç^zmãÓµ¢ñb²#— ¹YkÓ®Vk·rWyw¦ãÓÄ&iR‘«µl;„ËB@R ¢îHâJÙl.î ‘-¡ Õâ-[rY «°l`ÚB°«Å]Ä:‘€l¸nØ©Æšm+[Ë(Êõ-zO=Y[Æ´ÍY„@ `.œ‰aˆ bØÄ ±1Z²«)‰Z²€ÖÀb£Y1Ek&J±1"µÉ…VÀ²F,¢ªäËb² ——I%ÒéuÒíi/K˵åuå×Yo.’Jë­-×I¶««.ºK®’êMuºº^]yJò  Ê  Ñ Dª1XL²d™e†ªC˜`DrGHr Á2­ÝC»H¸£(–!º.ã¢ÉML•- ¢]S–QurЭҔªSb*Ä]JuQ7m]… "©8U Cav"&4  Ù¤2HjL&J²*5cLŘÎâÚ£¤¦U«Ëj•kUò¾ÛE¥Tdë§è¾«g^.ÜÊ·91,ÈgÄcüÖ%v•íÿ'ã–î8fWtãô{­^ÇD{Ê7(ºè¥LW+—8Z+—(•X7+ww 1b›Srîvš(šVL$îêmw\ˆ“H¨MBÎÕ£S¦š!\­MlÆžúítÒsÚ4]$Ø£õO-¬¼] ¯í˜¼BÁlªñY[¿§Ó™dÔÍ_wã2šH‹aÂRÒ æ#À­f¨*ËnÒfM“‰+Lk«®Ä¥²ª­S팑˭â«Zɳ¼dëFÊŠóløY6lNe4Z(!|XÄ`1B¬Éš~ŠpNj׉<gÖxdжj‡çi¦SlÇ-KÅùÓT¶k„nSR¾Ó·Å_¢¯¥6[†-‘º‚}/H nI¯ÑS$E“™ÏÝVÃFߺéÅwÅε wØç—kNuO&Zm[×sJWÔßî þtØ~ýT´¾Ý÷iF»+ÅQÎÛíTkâ •)¹1NÕ0=“*u…Ǭˆåòvê³Ï—¶ø Rå[µqU¼:2ÓÙmÓÜçÚ§U̧÷ m7ûCÔ/«yªŒ©è'uµnÕ²¤’§Î¾ÿEŽ²6ÝÀÙÌfD µ±¶£[Td5 „‰5F¢Æoʃƒ$z}Ÿ»>¼òþÿ¬ù4€àbó|â16ìž™ä˜ÏŸHî¬è˜d´/ºS^Y¡ÔOAå„äzÇ_Íß¾À·Ò™Ði¡ðËfŽ‰ØD†ÊqÏš—(þ{²ÄÌùJý»æe5¸¶í¦ÞÿÄ »÷²–½Nž/|bÕ´·zÔôCЕ­ëðú"pVU”bëð™d¡¹±“1ŠÝ,Ñ‚ÌèíTj5c0±2v-#~ÉGMÝNt{÷ÔWYö_äæw¯;f8Ù‚ÞHÞffbçñ#¸v*N†‹¯QþÜcŽrÐ>UöüÿBõÍÌEèzJšÖçz)UöôM†Ù•f)Œ3)‘˜Ì,Á©ã˜æÖ5^³}4۳ݷ‡^?Íø)Þ¼×O[¿Í´'wEx¸ZwÓ¾øU‡o'ªpmk4hf$ø£ö^[ƆWm6Ñnʾ{{[|]õJ–ØØü͈^³ÍÇÅâÕ¬6mea—ö‹ÿÖ´NËÿ%O#/®å×Èjß;q¹Kqæ¥- v~:÷¾K-#Ù<5myûá~³ç6©9ßê´-Ó©ŸÃo~›õ©ç£àÃc¨_*§êøDý”äñüÝf›·¬¥¥+q ¹˜—&#§§(ÞY–²&§âíAaó‘7íY™™˜\ö5JÖƒ¨,yJeðÁ¬~U;SM- <Ú¸gõ¶h¸G„Æ–óU¯¿Âû…¢=ͽ‰c4—@d­53ݵ ôe±naŠzÕÔšrù>´Ô¹$Ä<þS­ëžvè´«Ÿ«)òᓾ©yuáÆ%ΈQ/VÂœº ˆTÖï¤ñü™ßõµjØÛRo“ÈòlZÌùn§v•àV½¿âÚo™Oµªöw“äÛvš×ß{WÞ%h®ïcSãþ;Ë_[-½(S+V’d¦Cû: ì·ª´Žb«ØÕhÔŸ‰âõ]>>=çÿ>>ï3&™Tçòüy8OçcëãݲÔÓµ&ËÉØF‰êèe9Z9J6ÄÜl¦ªøÔ:â]ðó,ƘÖë}x° ý®»UTÄy5ukB|†UL^Š_ˆ7¸ñ9økpyi)½wõÇmö Žl.ÔÒ¼rÇÔJæk9¿öõÏgd­Ÿï_gÆk¯OÆ«ï«‹>T×ù=äÈúÎ Å]Þ~Ü¡©÷±Û˜¹W¦´«}yè–)á)k±éÉ_ÉsëU}IáWZÇ×&p6»¶ïªÑœ‰í½5§¾$áñŸfFðõž]ïºl“½âfJ±‡bþ ýey_Z•÷}gãeo˜^é¥A™–Ň²/´¯ÿ5tÅ; ¯OoŸšhÿ[ÏóøÚE˜ûÍ6L+ä¸Ý„;sÿjþF)ªëRÃïº ÏyÉ=ÞG_ÂOÀB«Yán¬nlÔ«¥^ïÃÛÛÙ;xp¶w:ϸ<4ò‹2ù¼G{•¤:¦ð»¬^5E[W¢éfžÿ“4êã ž$æüõMo°¼ÔÌš®Æ/§ü£é*kRð*½±ß÷ZÖ±W3+Úr­b·}4íL¨~ãLbìikpÔþèÐ÷ä6–¾-+k}n¦¶DEY¥šü¤ÒZ£f_“ëè_*ä§Öõöé’ׄåÉúa<§Òmæ[=×bO÷é÷÷Õ‡`ô¥º/Z£Z tRûEó[Úó[W¥†»¡N‰øô- xÓV‹1C;’” 2È:$è,³å =áîOñôcÎä xgÛ@aOëœBÕì/ùGÖucˆ¼¢;ÆåºpMÿ€FËÞBg¿ZÌÃ23+²hiž‘Æl” ÊK*q–TÊ™bË ‰bZT÷ée¨Z¬ ,Ya1,KAj¥–¤²Ä²¦RË)eN/æj_Ôêƒé/ÛáýjÙÄ´;Š\úÜnβ[±-KYt©-Dµ÷Õ¡Œú]\–ů%¯¯Àý€U¤qš·@«|[pUÖ‚­cXØ[`U¨E…þ­ º‚ó«©q^ñ[Ü·—Ýg%¤\ª?¹¥>·Ú÷Æ?éüfkR:BŸ¼ZD_"_W-¥º²Å[?PØÖóélþi¥FÄ\~þ×vš¿ö®)¸ø=¥BjLQX¦3ÚÕðÚvÂêÔõ6ÿýŽüÔ§Þ©À´¨mdŒe‹¿[£ZЫèPôç z}Ú`œ–#N‚ŽÛ¬ú5xàú3ÖðÏ@óû÷‹+ŠóÃQ<ýí~FŽÞ¹'°.—’øÚ5dÿ4¼¼ù³àðÑí[wâþì/{7×ä±”ÏVôN¨uÅÁ¾SϪô~‡ u~Óàffq:j·¾•À¯Kçî ·ïhX̳³#µóv”wµ÷|EÊ»î÷[BÖÍdxo—›ÓÎ6ßíöŸp¾ÒæíSi!Ãúá%f‰ªJø?§{UÍÏU¶µîmïÛWré6w·;IÊtõ×CC’{³Á÷o“¼ªö9W)“2?/×Òkn†˜ÊbaúZòîú ‹Ù9aï9+ƺ’ò²ïŸ÷Ÿä1î^UmeOÖOÁWÃ`¬Ì¬Ø¼-N]íhm«Ûõ­×n/ê½rÆ¢Éi<†DÛ¬Ž38…m E»x—cTÛwÌéê>o^¶×bæûW)}AÑ+Ðlø˜Õ÷ÎäÅ]Ï YM&†»Äøã°ó*ÝnØ·µOB‡;ì¸fbÌ3•-õýæý©æ6U:ÊX³ô™½Õµ×ý|šGk›;{«Ë=»šÄv·oyºïTUŠ£ç.Hœ·‡v«µn‘·ï'”›„n‰IÝÐóe £¾™AŒX|Jÿ Å/ä8òJá×vwv Uòíý±}âôŸ3 ð¹ 5>þwË£¹½ñÑ]&±ªÕŒÆfde‹˜ò¾@{@ý®‚öÏ;ûÄß9š.Óº§¥oµWôÙ—š‹ó¯œªöóÁÁÞã"Ê~V˜ŒÿÅ}yhú+ûÎÖæ×Öú~•6Ÿ·Núño'úu½õL´{>rûÊا¥çºh]ß¼r_|—iâAÃç¥Òý9õ<—ÞW ¼‚|%_#—½tu2Wÿ^’â÷—µI‹:§bÎØ ¾3Ü‹9!|S?'…!Ð.Ç«‚.‚‚PÒ>Zeo\“Î-íò¿8§™w˜ÝÛ]B[÷È÷PhêeÝÔæt#ßµÐuø9uÇ]àlnY˜¾¤úrm»É¯´^´ÄðŽò“dõ£‘~F£ß¸è\g/kêø44ª\c}Å£ØΖ‡‹îŒ­äñéI™>´w'Xms•]YoKXâñæïž"Ì,f0îÙ‘šhÏ¿ kœŸaæ¥ŠÔ¸Ç 9{Úµ©8è`¼ÌÁÖšäÖæŠxFßв–Ì~Tï¾jJË,&\…”™S,¢­¬V™ bX,²Y.!Æ ©5%ñE{¢ò  ·˜tèÔ–þèŸÜÆ·¦®5ºéÉé_7ý*ZJ2Y±:‘½~x”!~€…á`l c‰Á°ŸJÝ䙘™@ò6}vfÈü)X¼7¯Ðt›-qãÚ>ÊN­ãéoúåGéãüElŸÐñ71;÷ ¯Q™™“Ô´>T<-S¥k5Ö8W›¸¾›Ëïšüñê9Žim?}Õô[}²™Ž¹K„X6Î •Ë·öÕfý‡–uÁô&±R×̼[œé5Û§k×ýCŠ4|CŠŸs…ÿŒðÞ•lº¿ÔÃ}/wËÁö«‚×D±ôBQÁ¿]]ÃÈQç5Á(õjNDæøÃ1~6’J’JRK%)yo­×ôën½K%‰5“ŠˆÒID‰ŒdÔi*0h,•cQª)šõÝÍ*bÆкÕÓ‘"ŽäE;jH4 ¦¼fP#-"Ú?…žyƒM­ãmª„oúdŠH¤{xR×½Ö•z¶µKz”~J#·dtäSà¹H¼$€Üæ6A $lÜãlIµFMÍ»#K)–5WwX¢Å˜±¤I¾&®]‰˜ öú#öMâõ?ù‹üK°ªèKÍÄø%×£Àž%±v;Üwgtþ"Þ×Ì­½îóTš™’ú]3 ÆrtàÕêh#uòr—lüÿ)ôhû«ãû=æõ™c2ÎíÚ_Zÿ㛹¯G£Òlî„œ=ØeC.ÀÜíÍæ¸]*íß!™.ÞõÙ­o2ï€õµu„^P¶„æK•.å6ïb‡Å—ÈxÕ®t·â}‡]à)gŽÜ§Ó79hmÇ›š”¼Àû?üW”þÿÒ+²¤ëÓ°A´}îÀì=]IÊåT¾#ïJwÏ·MíW·/Ë3¹-;n•”ÊX#£2ž-oŽI¾Nÿšo]ýÆÑÏÅ>µ'ÉÍO§Õ?›0Ìbp7{ÚÕµ¸ß_ ~}¦ßKznhîöV,Ê2}%òð–×Jw?SþγðWÜß[ZwçWq=<_R©Þ^$ÂÎxû/É/îàŠá8¼,ÆLÆYæ;׳¸«uÃå"ÌqÕ<_>}Ul_³œc+’ÊßšIÍ–ýbĽԕ˜×¾w¯£þº½\â~ÎO2Ep)K‚Í™8årÜúW^m ÌûÏà¡´QþÔ¾§QW—JÖ?)™Ÿï ç<É]]õš;£}O¸ûÔýËzÃl™¸‰Z¼áu ‘­·`ÞgÆL£È'Í-6ÂÚ9ï¯Û«®?Ìøo åä|kJ­Û3 ªí•Û‡£^Ù¬ªâ® ¯3Åç„öÿÔdÜáŸõ?_c87}ó÷Nßûž»•æ_JWUzç.¼/_~ý×õî‚ö´Ééla¦Øµ«V±ŠÕ–’>»+ «‰·Ùv•¡Òx‡3¹V´)Ú%q™2z­4ÒÆcJeZ`ÌËÍØZÔŸ§*©¼·Önç/d»)ªÌ333ïÚU+ð.»¿ñ2ºz?žoEþžJ. É36}óÖVþÉZe7cÌíŒÐ¦§ äü½™­µêê÷w}OÙÉ oxaѨ‰áUÝÌ_üt-°#­ÜêÜÕÛµËK¢PžÑ0„÷?R$ Þ±ž‚™…ëé 1…~á¨wî~TnƒA]†'t¡7ið^FsþGccÿÒWu-¥=nªÏ¥<µËYÅ%‰Y¯Úç$%ß-õq×Ùtžbeu+ö”w!\®Q^îFáÍ°îŒW÷UèÞMs—×ü¡…Ô¡Óù†F ¹ca¶¦bÑ:îiÞäQ^67hnîˆðUFÎÙÊ"2Ò&!m²¤Œ$Jº*n¥2¡ J|¡—Ì›ã߆ü3ì«‘žn×ËÒós>‚å2BµuéfŸîÖñêÐø‡Ûù~¶‡ˆ7‘}$½uú¨~Ÿèê/ú¡ÄÁ· Ò|èŠë'=£«Ìcl“5#xa>ú±ˆlC5L~WH¨îd!l4¸”³àÒÒݲS60å³{M‹c7žYd’7*;¸ ´¤q¥½”šØÝ8­„ë\çU1°ê¾¿Õ|¾Ë“Øô|äàýoóBgóŸZ%GDvO¢lôUJm­ê$-£˜—ö$¿ÄnU!ìQ×{õ:‹Nóc±üìcCõüq¯3µc胮´`×AŒú÷¹éOKÑ좽µ g]Ž‹£ûTžµ¼E-ØßÇ5ƒ;[íPg¬d}`'ç!z^§É/CêV9›&Úú4~õ”œ·ë†ømó^4ö¤‘C-yûQ ÕÜÿID™3H‡˜Ãmz‰b²¬Gú=wûßÙï¾óÞg“Û±‡TØA‰ÆßWUAg6.çw]¹»Ÿ¼_pnñÎsžÛ“T‹ÌDcßt%3œz Ñ›=‚3&ÉQžqª¦HÔÇM²8Æ3í¼§¸~³®êoÚýÌΪ'cÉIøž’’v?)E7[‡ÚÁÝsù^¯i‰û⸙ ¾Þñí>Df§RɪN†Îª³UŽi˜Ü…ÊgŸ-M&Jxµ¥4ÐyQ»šÁÒ™ïV<î#¤=GªÞöØ!Ðl¾jÒ›ÅE1¡½àÀõ#4‘K±ÔhFˆjâ\³ç»B>h³]¹ô(…ž¿©§Îéf¢áÉGÚ´u*+Éõ{,ã9%öª¡H˜¹ådõæ]¯PcÕg¯ ÎKªó °CÈvãÙ8w—ý<¼øòvµ@CºçÂ÷oYúçà¼XŸijYd‚Ÿ¹…ÃÑßüßM›ˆ|ý‡M¾²¼Gfë¿)˜A½·W¯ãl|ŸIo÷»5Ÿ:ÓfKÚ=ÍH"ô|Ž1@PWö Äÿ4ÓÜ`{ן[Å‹°º“ ‘‹¬¢jhiùÒõ€Ÿ†MXðúŠ!ý<LËñ¾»»ó=#·ªpl'[JØÉ)ª«ªLm/Yáý]—u)ƒë*Yóï้ÇȇïAži®ëI¹‘¢ ªŠ ¾ϱõú†æû^ÚÃÕ*!ИÜÆÏ]NöÃzBTô˜ô—ŸfÛó*‹·œÝe#>š"µ¶®3ÈàÑÖÁ@‡ˆy{G6WúpCÜ÷‹Ïm¾ ìJˆNÇå2Ÿ<‡‰÷+°Ùx±Î¸œ¦º âh1|ˆü¬ögçðd-±dâë½2¸U• !ÝéÃ_¢ÿŠí<\^ÖöeIÛIx¹m}É)¹v—©ˆN—ÞºûúsMò÷Ô2³^–&RÛ麸V2ØöîžËOïìØŒe÷}¯¤ÑHâšþÚÐ{(Ê„#-šGf\r °«»ÿ«ïð ~µ)œÝÑÿÇ+ÉëQ ™²Xæ¢ýW•Ö,Ì©‚ ºQ 4ktòkîC£uåÃãsåßæb¡­msÔíŸî¾¡˜ÚäFÞzüÿ*;Ņédllluî›3ç|¯Yâ>÷wÀÍk³Ÿè-[ÙÒà…1µ^¡‚Ž*µªé(©+{%¾W3ž— Ô÷m¼¨(l¿òfk-€ÆøŸ»ÊÀÛ:ækòªª ©ª—ªŽ_ökO g'ÍÌ`k÷PÒ™x(‡þÂÕ÷±&[l~nz§GÓ8?G/YbloêÐÑXª.È5n=¼Ìû(j¨†'ÁÛð¾\´Í¢½ãR4’5ôΓÎ@zÓïV¬îÝv–wy~Æ-lá[Þ×eé õÒªk¿b‰Óvú„CïT0Clj†ÆÊ0‡×¿îçæCæ°¢ »C"D8£grîñ^Â%‚}¤gˆå¬ÅŽaýþ®Ùþ³q››mÖ¯^êø;y‰‰t¤úИÿ—Æ.4þ¯4mÜfÒ$ôÚ£ÛDÐæ–ý6æ×½ízÍì_)ì̱"­Cþþô!ÜìÜy6YĽ_µ¡m!-ž`™VXÖíñò,}Ÿ¯&Ù®éø²yN•†ì©j¬N å³ƒÉãÒÀ”ü;[öN{UL0_±qÇ„ü}ØUÌsÃùjä:!T¼6´B %3C1`gPÂü×qôåòØ£Hª($£*¢è#kj×O™ÌUö rÉUÖÎÊ–õxÇ þ·jüäWè¢`†ƒ¼¸Òr»Êþ!"“ê[ÙMß±¦ÒfûÝP†ÙU¸ršÇdý›Ðr!kô4:ß5õ|oe» åÌéæv öymì÷ŠÜ¤m·ø1ú`‰ÂrÜ;‰Á³ªóß¹îüÓ‚½oÐü¾ß¶¡k»€7>»H‡ñÿŽçjÇ GûõDQw-xWœVu ÿê`âfÎyC@’Ùõ_2wAÛúŠ7‹î ‹ÎfÁó()9ç“W+^è*'Â^ƒ¸žM=ãõ”AE¢{Ùñs4y=ëýôÕÔ\[Ýþ«<Ú÷dƒt Bij®«¶Ý+*ún×Dr,n[8ø†²ö[ê›* öÒnQvß¿~C­˜@SrÃy€VU}«´s«ÉoÛœ£ëº ìò»g¢9·âJ–JÔW±Îíºæ&/ÒàƒBÊêºÊì­ÕÕU[晦Ýavú °uJ_!&t]e„ëŸ í6¢ kö68±ÚNö„CÀÃÂáîÇÎoì8Ü7"‚@d^¤å¼¸œA¾fßtÈ„ð»÷ Î{—kœ½‚mY+¼•¢õ0‘ ]žÉsºX=÷—âvŸŠ®n™„‹AÊw~'Øôfók°ð;ë™ð^¿Ù±À{×ÛëxÙõr›+ao2çvKS‘=ÛîäßFaõy´%ð×^6õm( Au®¾ëÕ"ßs¯B]Œ(óÛØÝÕ߻渊â)KˆOñ2wbÊÖUåQšÁú)êj]{?aœÕÇYTº†ÀÖ:ò1ÃgûÐy“w¼Z͇ÌÆ7†Ü®‰fv Ïlç9BÔ}ðß6êr0BEŒŒVµF5‡G>Ý]?•¼èË µ^‡–D3ÿð»Î“5QULÁjÇÖhGPÇp9v0gs˜J×DTu‹V*Þ°Ãõ¤ýï>ë—G_–ŒÖÓ Ú­×m¯¼7Ê °Ðþ;îí½Ï‹‰êêÄXY–´á@TE‚ V(ª\ ÿs1XÌCÜÖÀȇG¾ã:ÎC8:ѼØP–~€ƒ?O ÑrºÑûu»ˆ¶uÆiZ!öÝa¸€ ƒÅì;m›P?=gE-!”[6¨7y°½zϹÍÞAtGØTüÝœ-‡ Áãþ®ç‹Lˆ_r#4°°r“’kküÈ,š1ŒF[±­Z ªîV__3Ï„Uú(Á Ž3EÅZǸwñ"úæüÐåîÞ!—Ÿ>XĘ„rCC½õ_|q7íÅÝÝÏ­Ûð¨øzŒ¶£¼™Y™¹ì+ÝmN%IOS Xˆ=/ùÚÞ¿Ùæê*,2ÑVS÷ÙMmN._BU8¶ó¸¯*¹7•ÒEÓªhiÕQ¢«_ó Š5\>òdo ŠV¢ 0wº!5‹.ˆ3|ÈÆ2Gd¢ò̘âH9åfvbí<λ¤v¾ïw=Èöø¼'ûÓ[\Až5yD¾ÿƒ7“ÓV¼óZ¢'ÚŠ²«A"s^¶ÑÙOZhAg„žÂq´ǨÁÈ/Q;›k¯7Q¦äk&–î’{Òw>¤›s·…Nñ´h‡pâ4Osâí.n‡îî(úŠÐ¤yŠ ǽî¼C¨¼R\¦Âv|B•¦Uitôí¤€Æ†mˆDT;B󙯔ѦD1øúGÑÒd™[&]ÓâwÊk毈2êÞzúãø´B$h‚Äõô3Rõê ÌÐ7®N.+gÄf„'P DQ¼ë¸›³“ôì&ºÐˆE,O‘à!Ø}›•Iŵµ·ã“ˆ1¬¹ŒÌˆOÔ¢ž,›ŽTááJPe§î§ßŸMæüz*å[¾5'}Å<¿% Žï½0õì–˜C#ô: ‰^ñd‚ øåÐìº9=ÕÕ‹­ÏßoõøB‚hk"û>_Lþ|OçV>P¬ñ ¸b0ãË'Q$žƒs¥\Ú€žæÏïøZ„ jÔ´ž¥åæ¹™¨´›¦Ðˆ@ƒ#!ÇeãEàª}ŸØܯC(Íd•¶glצÕtN¼ÄX+ãÇÜøsŒ loÅ|o¥5 ªZÌ’–¬]~‚llou9±°„E Äé·4„"‡mðÌþ‰{ûWû¥UUQA?/²ámˆYª!nÞG¿)\ŠHØïD8Ëb'v¨*ˆ*ˆ{A8Ýwo”$üñeêô%ªõŸŽ ±äë‡{˜KÓi¯Yä°uý0†˜Æ’ožÒl#I}{;®Ó»ýã¾çD…YóøNé0ý¶‹ã0…e Æ Šª¨¢¢gí÷«8 ÄṌA ­ì©ù«Ë'UATAUßü-y~‰ÓŸ@>”ˆoþ½ÄCmô®Ü2TÒ§ý”A~~Â!màŠ¢[ùÒù_žõ½BÔmŒaè$û l¶O\BxÎÿ×ý]ö-ú7{_šéßûî:¯Âóÿåý¿÷»rä©/•j¨õ[Ú¹]}YUg8¾Ó©ÝCkª+"%\ûª„'lRmiC“˹öDzñ®˜–ÕÜAO¥AU7])÷X!šh¦N+â|JZœbˆwý-Iåñ÷Y[œª¨"¨ -´$ì…*¼ª¾µôDᨂª¨.î’w<0C³Ù5Á'ÂýÝ+ó×òr²1€sAQEPETCT06tþŸËwšwï(GÿmŒh;>>ËàJ±½ÈåZ¯*HA¥òwM ªˆ*‚¨qQW…ùëPÀM÷u€á*!â®w0oºæ‹¸¯ítÆ={âñy$£¢”_á„üè–BAs1Çl¢?kª°‘ÅÙ`È÷ÿ3„EÔŠ¨Å •]l¾)òøÙŸ­™ÙŽËÞ-@¢¡P™Õû§éw²Ú×ãÚx‡ç!ï½È”#}ȯÎ!¹ø«u5ÕAMÿɹÅe8Láà Âþ‘¸cÌÁË]Ÿ(w1´w`!»XQ÷t)8pgøÜúåî;‹êÔõ&©sô:~NŠÆœzåD7[€î8‡å¾Pu]m뿳jÞßQIÍ¿n*¨…¤«ÖFØÇ|ª&ø;ÌLÞÏðgÿÛ’ö,—ðœœc˜NqTþÎÝ:ÀmÏvÚ®ÇtçÆK°ûá1QáXùœæ j¶ÒÞt\øREÁeN”0>yDCÌЇØkKVOëfcÐ}}NAD(„ßM5{ äPýrŸ¿°Â³ …ÒÒH^ôÜ›ÉY ëÔÔE<s…)DoäRÆ9çQã³ ÇŒ@àŸKz|”¾£؆ý•Zíÿ+¿µãþWµßwºûþ¹µê:%™m Dݯ÷ñŠE'K“NRâš#ùÙ·ª*ùþ7ùŒŒ­AÜSð*´Wþ*•gQïõtWLˆ?ˆà9´VºíóÐr½DNï«D3ð½ìÆùU{öd¡w¥ž{~ùºp"Åß¡•.Êb¨½8çI˜R3_Jd9ÚTB7…µ_ÀgÄ7Óí¯ØÁ»'â7‚“‰¾^ô%Ê)ìyìÎœûgXh‹“”Â;]æéÁ%Å5r»+H›BºÒQfñ\PpÔ›WçŤWǦg#øö°sµ^ofN— ¡4'vsŒÄg†¡>b1ýJ"˜8#æ^!rÓŸ¥©c*u·l¢ÑWh;zò8“>3Ë’d‰h0ar0— .º’„¥%&+­ —ê1p+tj|u´m¥.ã^û™6V;á¹³4;“qŒ»ŠÅrúˆEŒÊi†Àñƹú†èãpqJ>0$ 2š3Úº¬’Ç”rÙ– 3Uªu®D:õñ*d—Æü²&:®V‡7·Üˆ%½µüØÑ„Ù8QeÑÒˆ¡4hq,ø˜·µ’>÷ãÆw9œµöhv_ÛHÑW²}Zr¢`AlÙÎ&BtÃ>‚li@N£„ñO+¹´³´©XûNK.×Gmܶσ\N]_ú¨‡±Íð´õ§\&qE3˜ÌÄÆB €erKà“ –Ç„ÔÌ+y¿{D!}ÆeÛm7k¸Žo¬SN·Üò @DLÍãßäu%&c¯ ˜Sª, i,ç–qmcpeK6¤·ÛP²Ýk;€`û/Ï÷ÙŒqnP< “—&ÉÂh™&ŠÓ¥ÓˆZÎ}WÉä*Ç;‰?¿0I"&’›ÍëFˆtÔì‡ D³ cë&¬`ÒOÙeäPoË’¶ÏÁ|¯ËþäÝ&Æ#eÑeèÄTüoÁzuÓŒ~$íŸyÞh¼¥eª±–+« —ŽªžŒ.£˜ˆ1}m=òH³¬ô­[wu+þºŸ D.M ò 4d‘Æ¡`„Úß웟ȥnÅÁ}Ñ1ÔC¥kÈ«7oinÒó2(*ò–::›;£Ñ±³çò%ŒcyX©Õê’º’»ö¼ëjg›H!Éø[Tû)«óä|5&§· ¤?*îÎz²öÞƒWe#GFÕVºØL5ö5.=‚w.…K•¯ˆ1ƒ+(íåiµÂbÀÛ©:¡á"(0l¸Óø ú“/’õò’-ªÊÒ¶™åÑÎýÕKŸjNuIÆde© ztÑê67ì¼­ug£aGn¨ƒ2 Ø0f(¼º-ŸSöu†+—Ø¡ãRµ×)0Ý]Î1èi]Ä–ëóý$½¯:ê,ïiç)Ú¢”ACÝäéíˆ34¼å8±oÈîx »|!¦ýtYâWÅ 5˜¼T8X{Zù"ˆh¬ëÔBnàÉT‰™~a&ðOJ›z ¾bZg2óVÑØ1ÌØqø¾ÃLHù6I·0!­¡V"¿‘Ä*ëcjÑ Ü1c?§òÌ{s6š~úš1@SþMp£ƒê pÁ!B…lM ž0@~ IÈ ]AòØ“{6q³y¸ÜòÎ$_ ŽW㜃í˜oì=wo ¨ÜLñ5^Áöê…e­“Se8Jö'uƒÙÄî|ú89žLPüSî¸BÚ}9!nÇñˆÄòü‚iŒigü·ÂØÌ~³”ßíQüìµ·Ø}7¶’yèRP!Aê .¾÷DÆn B°rMÆq´³øøÙ:~±W>µŽ4þ’¢"5™Ÿ¸©Œ;nÐF¬)H­Sf}Ί‘ßR®þÆì¹b*2"IÊ_¿Éh¶(ª ð×È”ðbp‚¸_{¯·voáÉNõv¼_Å>'i¼ë¾«;¡±‡gî¢fN°¢ š*ÂOs]›Võ¼> àŸAiµ&óÙß6ÓÝ{¨=cR²~?±­Éàˆ{±ÈnÑÜ&ì}DüÏ[çOvÿ ZÝL]ÏŒ]Î!Õ<·Í}7TCà« ¬ƒ)öþ¯ó»‰uC{½ó|KUÙoÄuÏ6ë]4ø¶r_>-Éû,«x÷ZÜŠP}QY Ä2ÔŠ!æ2*ž«tþÃó³åç:¼½Õþö«"=;nꪧn×.ÔØ6mÔtô¶y úóÙƒnFõ³w8ãÑpõÑáFí)Á+F!¥ûv½·3•Í½{›ÔU·rÌÖ¡À`VŒÆsñ¯Òˆ8”BT œ}Æ-ª+½[™G=\àrú6ºk’åZ7t*Ý¡'QTO“ãžÛVz¨R{G)]îüZ~¹;í÷B.OrÔmeGð;¥N¥ÜM=U…Ñ Ëï©ŸëöÕMOO[(ƒ3 ¾)m$ÛÚOÇþ«g®¹ö=ÁÅÓ÷¢?sðé3sõ¾.¦[o‘¬HcevÔ„w †Kƒ§Wû¯ÈÏ•HÑdÖbNÌôÕñYOØ»¶ïàˆqÔóvB«®)„TV+E2* ª{_2dìÿ_£k7{´ñv)•½ŸgÆÿ§o!(¡ñ4š§ê¹õ^£rÖ×°œ¿²ùí´Bàí?ÌJn’ƾQ]Ïî%Ðûær0^Š†¨… U“ÞL²Å1ê×ënzQ]mã,CÌ®n®gÛל¾Û=Ç©FÚLFí^˜©n±"iÑO_ØýRQéé-ì›C{´”WÞ0$XgŸ+\qŠA†Ä›Az)õ(OY‚½¿æt¼U߸Mìþó4@Í=5õõB)4†$“i >ÝÐÙíq¾ù/í­‰Õjº¡ãS3uå|W™–¶­¶¸^^÷‰z!e›×y  *¯ÈlóâO+äZÕådP%Ÿ“ÿ¥ØR½ ÝŸ»ÎǪpDƒ;¾4Ÿ”A×,qE›Þ]„«ÊD€ÌQ¾[vÊÇ ^ˆˆ"8-Ó;Õš±/àC2̾as/@Þ:« }Ì:‡“£Ð|o?Ó÷ðÒ)ªŸ #@TXH•1mÑÉ\ýŒkñ CË¿lh$@QDQAE\cÑõ?[Lô[ö‹ÕcdÌO´ö¹s<æÔ×fë]º“M‘ùå|Ÿ–ßrøuüßoï¿ òÛ]³Ïö»­lI°M¯#¨~²q`G–~›‚nú¿”Ä=Î Š€ª ¨‚ª"Š¼ +ÞeÎR˜<< ³D:¨Q×ú@µÌ7)f³Îi’òÏDÀ¦z€rf¨ªª­D?…Á?(ÐÚCjϵ>ú«îZG¿i6Äšû§ÜhÄzŸ @Ï}ÑòÃÂ…ßD®O‰©h‚ç"/÷°‹D: ÄÇ`?ìH"cj¤/é­/Êîf|ÛÅì¾ûë§&a=Œ÷-:ÆÒÃÇü.Ÿ¯î„Sìo&¢ï’ÕŠôz(¢›îe¼ÝÔ{Œš=½‚‡ÄZ e1› ˜r²Dt"dU<¥Døƒˆí¨vnx®øy2¬!éX>à§Ôóe-"ïÚCH¡ˆóLClhcCºT«úž2ùÊ!ú¦‚§ÆŽHÜ(»ª2Š$íÙ¹¼æc »ç -¤êa)]Îò˜C\9*ˆþ#ÏŽ(o?>ÔGŸ×s9Ü𜾚B3»é6 wVM,c'Uþ¹!ýtCp?˜á( c=#DGPB >€êùߣðÙ=᩹,J `ÏêÒ ¾uÛpî>Ò4»V&ÒcJ7ÿ&ëÑí,?ÂX@c Ýõ°õƒM#t_‹ ïX¾£ÿ.új×Å­ê–II+á%nÒ)z]ݬQ…õ¯ò¼•zåù‘N`¥H®Ü(ƒíïÔªTÕqºŸ'¸¯ÖA"SßTë”QgÆ˜Æ aÒ 2u|B½›Ëê’>ªkZ•4Ö½§[ëWŠÆ=™†0ÐΫpÕð2œv&²Ì·¤ÄD lûAŒ`Ï|AB:¿ýOGÕö@ýÒ[¶R•uö¯ø//F1%¢M¶Ø—%¡AG!ŒGºùžOMÙfΗ°»¿Á~Çöñ®M<§]ÆbkK¬T¬lÛ,é{Þ!Œ1r’¾ÙÅ1ˆ}çÊ¢Æ|bcņ"m©­6b4UôÿW^G¢Ó­9ÜCKj½—Óû[Ȟߺ•¦’UÙ›ÛƒX0ÓgÌHÄB`ä"™fW~2êðlÚ&Ôm¾ßõ;ËxÞ»àjÛyªkJ¯Fš=æÿÇßf¿rÑàß´çÞ²ÜDÚÌÇ%¦ŒÆeSÚå$–R8˜˜¶#RTä*”)?€êÄ œ pÅ…#Hn–Š F0áál¨q9ÂϤ6…ŒØ`ÐfOÌ!Gü¦‡­6dɼ£Œœý’‘çÉ)&)#/Š@)“hxN 1l” ¯¡5Ná@O¼X‹ÅeG–1€qA숇 ¢ŸÒPP@œp~1|ý‚# §–pŒŽq”q@ñÀÄઢ¢ª_ÝÊ‘&UàòRN<@“œwøöÜs^S2Âe™&(º +,fÒœn©\.5Y);g¦ÔÔ1ؘhë­ÛTÚTÒ•µF¬LÙiPšµñ¶›Z®˜«|#[bÚÞklµä´²II%õù]PhÕ‰*õ‚ njÒ‚70,Lgá„! Pd(B22“1RfLÆêÝc{ŽWNKV¼-Œ©RÉT•%ûyu-ÔºWJºWK%]A[3IµZø?W^DMhÖJ·ÙZ­\Ò’_uº’T³%+eì{]2•«I&Òi%›Me”©*2•$–«KöÝ]%-$©)%¤’SB‘’Ò¾¸é+JY 5d6ôwEa`cÁŒi‰ƒÅ’šI2¶´öß@òò²RYI%$’K+,­–õ’I%4kV–’üçá&½¾ìîn»ï½öÜ[ún_ µ÷£nÙ×»Ú½…ì)&–IKaŒÆ eŒdJÎ a¸· c^”¥lÔF¦JJɽڽçË̤³4¼ëk­¦­²R–Y4”ÒjÕÝÝiÞ]u¦I*RTÚ¼ët­+Mm²”¤¤Â²1K%YLbÈ™Z²Òl¤«)¶³VjÛ~‚Ë©+c o:¾+ÞðWW÷vï6øbc˜UŒ|?ºùy~ÊÊ–HÚSe5HÌi"MÓ6Š¢ó­Ô•2¤Slš¨ÑlÖDI&2%;Ñ׆ï€òòÿ+rÅ-6Åœb$tÄÙLô¬;?KÃÆ×¼Ô2›Æ0ná|¸ncMq‰ŠÛmõ&¬¦™e—Ÿ±¢ ¯n0ƒ›i»ÏuN9´x¤ô%DDCàã9•ç£D£¯$(Ÿpꇟç) a<Ó9¯:n²–¢3dhb‘D‘êLJÌb²“J„Uuè~óš8hð—%ˆÑÂ í ±¤1# C@@U=ØyŒ÷ü+=¥øR[1†ãHß’4Æ@€ d°h€–F…q’s†åwßCA Ïš©©Ì7y”ûRH\/ Z3Œvg¥*/ <àd¦¡c!êäb²!t°¬ä"(%=|ÚŠ~æxqÅ E<“AÉ yk¢élyÀa;O]·¢gœQÇ0SlR‘M¢ )¸§@Ðø3epøS8¤Ã )€bøà ~Í-lA˜7†ÈÇïÜ0ñDãÇ«¢ñוŽ IÍz‘@}å`çûélš–ˆE2Šñ¤P¡EÕ°³ZÔ ’8xhŽ)ä-üÂ1 ƒ˜ÒH^æÙ< HÇ" ñD=± `Ψ²…`Ë(„Bö£DB<°†!AÕRîý’Ξ÷Q° `Å`¶”C‹ÔÂŒ‰„¥ïâHÄ»=C7ï!¸Ø3 Êc(#£ÇÞÑå¶d5(æûxL[F #ÁX3 Å–.ƒ7¤>˜DÔ4,É1Q ÄAŒ:Ï Ŧ õ>i¤Û·a°†PÇÚ8¢œ…Ä᳜ǔˆ}HàfªOÈìçì„yß)„9œîÕ‚XR-âøÃ1øÖªžp’Ô_aÕÂNÙó©æOð–?Ó“%Rüa·´Þì?îÏo&Ð@¼¿"ša4. `YµÜNÏy‚†ÁKM9TôZâ¢ðÎ˦«~O—»\—lïÄó+hšKB#öíu+ŸM¤ž<Hˆ¨ ¨´ÀGƒFº¬Õ J¨þù¤|ó „Õ6`Û4 e<²eiQ3 Y‚$’CI y X"Á2«22±£ ˜Û´‚m7×_k´9GYÔ׈}VIÚe#}è›ÿG&ÁbI IeCrÂ|DÒ*Ñ4µ8—Cª À±À¼þ„òY(aš› ¸&E[§ä»>¹5É‘Vö×}†²êúA5ÛËlj¸°E@-lÕ)“e}þÛI“sAÒ:,P‚,«R 'Ɖáºç+«Z ¼d;î¨- ¡ÓFRmøÚ®YÌ3vòå;0Ym·`a×KwM:(¤÷2CÁó¨:&ÍdÔC¡º(!8é¥lªdu[ x`EŽ;¡Ø‡c§Åi7I‡¤1áoÆGtÕ:†)R Q%‰b<¡Êåí1ƒG4¦Êˆ5‘È6]Â?%ƒñŒa¾VÓÊrMQº°${©Y"¶½™¤H!€$ú#ä¦Tu‡ì”{5¡[…a,ÝæcL™ôÝãã3â=;Ä;Ot¨ƒà ÕѵCê15Ål«¬„mÅ<óbsîzgÂgðÿ?È[ŽÁ7;ÓX|GpyðOôv¦j˜êpöïŸS*YºÖ1˜æüùOHp³6ß 2¯VSâ }¸äŒ?± åXï÷†Ý—•šâ œü p _ž«Çx…ñÃ$·ßþ³,CV€ìŽlqJa§D¿|’V1öýLZR¯ Es+)þO›z«t‡Åß‹' _pïɲTpL!ÃÖˆ5Æ!<9®åIö|ƒÇqÄ"ÃU­9ã]RÜŠ(ÚYFFóD 5­ˆßÁ~N‡óŸ¾ß¿Ülro*W˜9§Øùî7”:}ﺳÃy3§2åylG]cåZúwò˜Œ’„fh#ÌVœö)%VF$ƒ\-ÓÙõØÏí¬²kÏ6UÔH£lïƒ'·)~FàÑûÏ&hÎÙ¥k ô&‡Øœ†s°Ô÷Êv{A…š–n72`fÏš­ LF&m4Ú42z"†n0jYî´Zå˜5c¼y[ ô(“)ŠŠ C'ñ,À`2rì ñÎYGï°Úl;Á› J6þŒ ÁÄBŠÓˆÐgˆ0df~ÈÉ“AŒfîi_Þ™!°†â•÷ 6ƒ#> Ì0¾ŒšC@Ä&ª-†s/—„Äɸ¨}qG×$:üóKÑÈ{ÿ$½³Bô¥åþÆ–™ffNZ1·I­9º3Õc}56Ç /ñ…Õ'íA>§!rjq¯oï+z|þ™[U;ÿ­ûéñ ›(&A2 L‚d žuìè'7s×ÂKÃ¥àï´¿Ù/ЗüD·¬z\fœ÷ûý„;ê[$ºz[Ðà©*ñ”¦/)4Uu©j+ïÒìן~a»k‰l¥™ŒÃuò}û…å[+…A;Eöaë þ¿Ó÷Uº¨ÛWö^ùÏR÷ðMî ¥.ÆM ’†J,]Ú‹Ê:Ç^ëßY/¦—aKÏRûû¬WV? èÞ1ë5×ÓŸ³˜˜iWÌlÕ èˆ‹¨Ý_¼ÿA_ßûxç~æoš)”ý}U¢»Ç8ì‰yt¾Ìœš\-b]ùo‡ˈà(ÞÅò®ç¼Q:Òð&ˆ—Ä-‡/¡ÃÕÙÑoô¸„ÃÕ»4ø*Þ<ñqßS²nWÒÛ5q›ú­Gb¥íR•SDÙÝæ‡õ ø^PZm’^â‡@êe×üýü¹n÷›rƟζsEw‚Ù©O$‚j+˜Þº™ /ç¸ö‹GuËÉ´Áìñ²¥_ÌæO´Ôÿµ†b™ˆÆ.‹ío5e«GÅ{·b¥îO»üj¨å†m†Ô œx’ù³öòqëc6ûwˆð}dÖ‰È\‚Ö<˜ÿ­Ùú1ߟ,ËpÏÎúܧKÃ4>%YäþbÜw¸žß9ÇZt/þQ¬¸Æz¾¿¼rdóÕ®¥Ü÷$Âe!ÈBe!‘C¤9@cÍdû¹ô:öNOp5ú5\ó€[€<8Ù-ÞØaêoõW¶ÿÍÌ·DʽUWF^ Q&ò\Ì¡¼“% ªŒ&RNùG±¨+¨ÂœÂ¹ ½˜®î­³=Ò}ƒA<áíÐM'!åOº;ÑáŽÕØWb,¼$/A7r<µúÓ–—C5œ‡´ƒÊùu!•"Sêý/¡ôv®ÂÛw‚ò“|ʯ(º‚yƒ¸Ý›Ï–’»u7Öá¥z›ö–µÃ70øõd§ë/ï!¯J;¶pµ íòeõc3ÁÈù/åõožêÝñKåÝ4ŸyÆIoÅ&þθ !ôØï}EÔ½ÿ]¥ÜÎ+Êe»ûKgèy=oFÖÓFéíúvc ¨.øÄ*<]c:c9¢®vºh­b1sm#kÀ=,½/,³·?8:ƒ°^¨Bï´’Ô4ëß­NM|°h¯ömý©rÚ¯®¸ó0×Fâ« ƒxjV¥ž‘Žä¾Ä½ˆãVìòÜVÑ;SdÀ—Xé*ge¦z§Ä|äk©p]Œ~k¹Â]:dÜkSÖâð¦(Qþô‰¬ã:tô~æðÒ~.ns~Än‹½õ)âÚë\¯ÉÚ íj}^óÄÚôÌË2ÌÌc3Þh¯Å¶ž±ÓTü_QƪÓG=ZçZÃŒ-¡ôûA?TèÐþ>¦ô¨ßöºðLbþ¹{Ô›!u·ÞhJ»ßäNQÜ¢nì#³0VlµKV×}Ñ¿vý>&i›2“*ÕXÚ—5ÚÈ&¼‚iîM ˜ñpN”Ö‚kA8š¨ÄˆªlØ‚nWÙ—Úש© å;ýh»îçÉó#Žk‰8F;°Þ^ÿΨÇÚÁ˜´b»¬ëuË®]ueÒ\³%ÒÝ("‹ù•¢ ÄåÕ" Ä/(hÓ$ý#F'þŠ\Š8).|& |ptSñ÷2üb™åk¤ƒ¶0µ¶›¦Óxݸ'¸m¾6œÀýä· Ô{åãV‘'Òs'9ðÜOËFÍ£ÞŸOôa·¡1·<ãÊ¥9 UtOÙ¤ž5¸ZO©±œkR´x^ýƲä'Ú·ðsi–º)¹²¢9àÐðdÔñ‡ÝÒ:á/ç’ýq¨÷…Òmãc*kí¥„?Ðr’\)/„÷Qç€KÈ’íúVš ·µJ£–= –ÞÛZꌩ¢,´ª2§0–ÄKT–’[ç’Ú6Wk|ù¾äBé;ã³çÊÍQ}]•AÙÅïgÖjQµ/cs4j;A&/¬ë‘ÁCB‡Ôx‡œµo5?vš‹kÿÁñËž’äÊÄlJäÉrEøœ4ᤷ%°ò3ùz±5.€(uí“¢­ØÇŽ¿î_ j~uaÍCìÙ”fKsMVËLe[‡ÂâÚêã¥Á­ÞK¬¸=òK©Ø§«ãTî­Çš.Z—#v;©m6Ç·´¼èŸq¤v]Ïå’çÔµ› ?–F|‡ú%ñCû+ÌVÿµß‰}j¸f¢_I||·ÓÔ—£5­G™ oü»¬WgŒ±ñs‡/›ñõ ·|‘Ù—Ä–±«ëï3_Ü5×âÈN†T8ê™l%¥ °Yh––ÅLK)e,¶kJšTË,TË-ïívPUïÁWœèÔtþWÁµL¬f«™˜·%·79O2Ôßj£ÂÛÅ-Vîßd´kµ‰â3¾UF©-~Ë%âÍV᱋ÕN±«Øc©tšM°UYy_?ô_?ü‘ïœfÅ÷o’·©QÝÛpU]µt"÷‹“»wå302˘²ÊÜÙ?Ý¡{,ÓK 31˜““'§'´Ó=¤÷>¦¬Â»h H‡†¥Eg! YC B5F ,Õ$ Ê! 2 $ÛHnâp™ºf‰¦-¨´Ñ™¸V¾3îËÂÁWN[ày÷שç‰ó_(µÎ¼­Ñ£åþSÛDéþð½¯6ú—ˆImNŸÉv×:?,¸ò±’Ùèš©ªÒ2ÊaÖàt ÅŒ_ŒØ\šE^KjqÙÅô6©jøo÷›sšç´o èè½²ÿiÆ‰Ú ¬â¾à4;IÙ8TÞ?>½îM=]+ÎÚïáW~‰hK¹d—5×[Bó^Î4¨wÍj^)‹õ0çù=ëPMÿûš;M‹°‡/þ/-Q©Æ˷ꯙãpÂÆÒ±Y£4fgÂ8Ý•®ð¤· ;-ÍYNˆ—£\%â,©•2Ë‚ø„¼Ú.]:™/ÉD¿zKE,’Ù‰aäVðµ‰p¨kš¯%¹¿™-Ih–”´KJ›«›-£Ázqj]õ‰£®C»èúkñ*¹³S‹œš<µ1kvŠú¸¯ËæÚÕü›.ž|½[zûØL¹Æ©[–»˜¹‰¡ÆndþŠ}Íg^fõÓÎÂéKê¶X<ÓÏiß0µÜ,œ—æÐö‹é¦ŽÄÿÝëø|QL’œ)ÆÇ:ûTG“üÑ îÅ翃ç÷žW¡È;Wˆq.KðþÀUÑj ¢_ äYá9ce¢ähzcÐr„»À*É-¼–ÝKV„±ÞÉkïR_$—“’Ù0–G.ž®#Zr+;Isß[SA¦2ÎÁv²n=sଟ 'ç|ÍjÝžx•í¸òöwÎÝ*7Ø*ïºÍæUœchà 0Æåãûw¨µÞºé°¹¢^pæû%ÄD¸Q.~D¶*k¥„™eL©‰e²¦RÊX¤Ë*`±,²‹*e¯÷ë\—´óÒÎÏojéãû¦ý ÇRçi_AšSLÊÒ÷ÇûYkÊMšäGh·ÍN/?]gYúñ½¤¸Y,%èl¶¤±/¢ÒvBÉ[…0â2´r㾿•¨Ž2Krü­$—MÖÒ*ÒK w@U¤KIQ¿úͤ°Üö•…]?Ç,ÄÑ-eŠy§Ð¸j>¯t–Íج<ÍO(›ùnN¸‡º¹³'ð: ¾gss]Ðr’^‡ß᤽.IpÔÆ©i\Œ–å¾hKÍ‚­Î©-”K`–ÎK^%±»¯m¿æuâîCÒ;i8¥kÉõ—Æ76ðÿW¡)ÆU8J~©ËZ å‘÷‰{Ï6.G?%#ŒcK‰ÕÈáüýÁ÷±Ö²¦¶”Mâîç»Ü5/%âl‰|¿ù¹|k¶Éò;sp•ÏTk~—6º¦M¶Ê÷«|–Õî!= šø™PʼnnT›ßöìwüàGýFÍrUöœ.›lÏ\f2ÆEä³áa.êúêw3µm¢sªçº ¿ÙäK÷¡ÒW3±Å×sO=Æi¤l©Gþ¿q[…ëx´Wxvÿ,¾Šõ[Øt~}”uÞn\óü7¥Ì2£ z—Üq÷‡|{½œ˜*ð59š™+,TÉYo%Gq’õàû©.i%¶[ ß ¶IâKZKÝAW‚’ó½J›¤—%±»ÓzKý6çä†ÔУ°5Ï™¶熲yU»žJZ›¨ò «EÓý~ºy÷Ø^+¯lÔú}q@ë’Y9)Q¾úÈÝWx%ó<$–ÄKŽðÛR[I.e.È»^#ÖuQê*õ]':½Tl“k/à¿¥ÅùM'^%hœõMìôâÖÙ¿~6¸*ò4¾0r˜­•üï¾{pk"蹇rÓBäp±8Güi¯²AÚ uò\-æK@M$»üÒZ•ÅŽ Š´kÄ·i.‹kWc¡Ú'e-Ýo¾iÞÅ댵œgy”¼6°îµ8”÷TÐóºÏô<ÿÌ×ÅÖq-\ÒÇØ6ë­ô2\óZ=-úTo’]™TpðU®K÷WšüRÿ_Ê­õÖJÿEq¿þUÖ‹¯çAÍ5k‡ï¦­Óáµ®–ó7U®<k‹·¡-•úª> µ)Ô õìN?hçש“Ò¡N NyԚɭæ”öêî‰qw¶’wé7MºxßÀý=[[Gfæ’y”æK„[%zSÑŒ¾õõѯÞW飸)ñ½ȼŽx»><¾çcrNŽ¸Nê¯ p¿z‹î›yy÷ýçj.‰ßm›Ïðaüê&Ìýpv!on˜k£¿þ%¶Ûõ,{Ù­ÝP—‹°ß"su¬õÔt'5õ#Y_›³uŸþü­i|ÛeîËÌ–­fs^B,Õò¹šá›47ÔêöÎñ^ßØMÓöãq¬¿×êª\Òù!qY5%Zçc.“èü¬è~W»—KB÷¿ž~a¯qcÝë\µ)mWÈt-»yZÊŸd[Þbàµw_æ…ìœm`ºeÚ£^ µSÅ­q~[†‡tÇQ« îú¯{îskÊ«Zºky…ö“\âjøSï¥öGn%zbÿì¼O~è‹ÎÛÿF]!o§:ÞÕêÞ°½Ö»Ý¯èëçÙ^j–ÂÞØwg¤ýÚèáÇ—ÖJó(ãÿÍÁáôVýó]qm^ô”2¾ v7q7÷ÇØ®û™{›¤½Âwè_e›êë‹ÕQáºÍ¿)öEp—‘ðrýIþøbuÏ3µî¬Û !›XϱÎ3èQóùÖÿþirü÷Ü®o!è}°¿’} ;ôt*W’†öûú^›-’M0Üg…ʺî%µÉ£ØâWýùßZÚ¢(\DþvÞmÙÒBþ/ £7Þ9…|Ý¿ÇSËåúÇéäËó~. ^Š¾~mMT}œpD¸ŠÂº?áv ¯«Ãým÷MMª¬¨ŠM‚ýɯ“z[pYëÁTh§c´´ôH ÕáÁL(D[«Å§w¤¯Ñ¿®µrL¯|TH‰—4¹°ÑžKëj‡gž©-åµj‚ÕöŒLW)š+³EimaÈŠ¶ùsU–|ÖbœdE¼¹n**¯4ŽDT®£öæ/6óÓtýM`1¦jÔ9í87œ“T››sa’mÒZ¤ÚÜÛ»btœØ—ltîª*6:®»nn¹]6¹Ñ5¤­ˆ ’Ñ[)ZPDA"Ïés~Ý·Í…žK?KØaXs, Çf>HQQ·®æ¶›;G9CÈôÇóv?Á¨šüMâíOÊÝÞÛßK5Ù­ñ·ðÑ®}7Œpßœ®5óÝÅøGÁ{«ÊÓWšÕ\Õ%%jžyÛàÞ•ª23kZONíz9µjˆDwi×,QîÔTñ9\×ø«äºoÝË ôwþ—Åÿ›ôÒÌ/îû%Ëé$2´jE©5×η^-6P†4KÐ#•¸DŒ$x:ÅË£Õ¡nD]ŸÝ,Q´Æ†Ý˱—JHô‘³ä½ ¦‘î ç: Õt*é"ŠÒDÐÔÍцMCRÇ䈕 Š8w¼K‰HÀõ4(†Î©0#zEˆ² Ti«_%ít‡Vcø¾?ë#„ÿéÂq #œn½Ÿºnëh¶±ŸÓÜøú+ôØ.ZÓû—@ŒS+ ƒ]¶è¥IQ H<¦Ó‘ˆ )\Òà dBF($cÆtø£“9‹F&2™·Œ†…ÅÒ¢(8'S8Èòbsh¾d'J!@ZMC`ÍæÑçLp&HsÂã@¸8€¤b’–) £"T8”Œ°QÂ’•'%'qÄ H‡’–äB$Y…#¬˜hÌ£ÄBéBôCD  ‰ø ˆ¥¢Áå…àU·9Xà€¨ ÁH‘Ê^"J@ V‡ ä( s‘4´ºé [.G¥d„[?–Á¹g éÌ‚i±œÒÌôתnÉ8àÈΛ¬…áðº‰J* Šé_<¦*@/(´&Å5Ìlµ áäË-âoMÕp ãÀ|þÝÖfjÓÖ¸¶Ë[‹Õ›=½¼q<\›c±»oO³Ä“ÿDÊ•”†?4³A8"'7Gf·¾÷½ð®ñÖy .GT”{m.“«Èª®°d’VqœìÝ»®æô|'QÒÇ]Ò×[`»vÜõj'tœlÛtçÃ?h?ýÔDïÉÉQ{‰\ŽF£7‰}b`F–D)¨“ÃI¯2}‘!âN»9ý¯v G┵ñ턱DÓ6‡î3Wõi¦§0]-þÉä¡é Æ|•åK¨U÷®î³²¥ïô¹ÖÊŸ¦•­6±²10­1£4Ðú†\qt+®–Åßï»/pçí³<¾f“ÉÔwuüwUé}%úÊð=›7ëFŸêß9wŸu½CtÌÆKGŸ‡ÖlªØð$ÿ¯Ì–¥ú‡Ñ/œSÄà ¶õå÷çGªªŽÕ¯«6×ê4Ùm &–‘CjøŠÐÉZ:õNý†Î­,ª®òÝ])”þfïbœ‡TÓM4Œÿ³$?ÖOcÜÞ'ÅÝ âïœ+µîëwÿeSÑ<›ÙýÙiKüg¶¡âº«ì67õãÎÑh^ÒWýÛ{²ŸÒBÅ{jò’÷ÑÈIú©æ‹õ‘?¯†Jßò©Óå2÷&Åy—Ë_Š6êxü¯Øzue[ÂèÕ<›t¤øÌo%ý­þ8‰ô ®%k¥z¢\ ~‰q¾šhÅ‘ôôÙkÖM2ZX²éì[•”ÓÙºÓ’2ÌÌÆà«0έOQ­4ÖÑ‘™5뛟Iñim;§›MÝüYÑo:»Ä8aÑö÷Á÷³n_Ø:ZôüS3ÞÎ.Ýûe”ã¸wM–SÕæ´æë0À·ç—A”óW÷žÚ†ÿê/,=Í÷; Q·?w–Z#èÕ•åUùDë½~¿½Ëd~ò¯RÕ¼sŸïåY¤öTépŒ¯ë\Ü»ä¹Ï˜Û>“Ð)לfûêêØo—w¼‹öÑre·ÿ”z_اø…]ÁrZÔÏy[UäÅØ*{Cÿ9厨ÿmoàS}8kð2Xyí?¯Æé¬ìê©ç]±ê¢öŽ ÖyÉoh—_½«=“pŒ[L ¢wM¼xý¾Ãäu¯ÄÖùÍïÛâ÷ü¯yv¸éq“œ“IL’2FâÛˆ8R= â;•Ýï·=èY™s¼¬f5Þ•ê=d=¢¿E?moX‡Åß’{¯ý–ϯ_QàŸù#©^ð»ó®à ñ*åçžWžeæã)Se”÷kiÊOtñ—7å<<øô¾èwbÉm†‹¬z¨÷éy‡¦í­›‡­¤îÚ>Úþ©Ó¥t;ßV°³+JbX£¸6*]ÎsdÚ&.FÒPÍ*d5V´»i1%_™Ú:çd]ÄŽy:&u2ÇæõÀäjVü+WªQXÕk†ôx`ÁÃ×*vb+ú«Øç@Ó_}öÛÙòõíÜÏéÿ*^‡d'-à[Ô¾ÒyavÊæÎa¾hæË뿷а¾m\ƒù„è]®:Ùý«Èò³Ú¥áDáÄàûÛèÌ2Ydç> qÙÌG•yÅu”ÉVÇÁ¬“Ö«Ï<ãõm?Xž"áÇ•«Ïÿhw×5gÑ¿1adc)“ ¡sòù2X22seÞ¬ÃX¶d·Š¹ËçG¹ày.Øéªß|òðoÍ<ÑßY?”—ìÆÒ»Ñ\„ãNþä:·«ì©Ï>+ÀÒ¸…à žgÁt^O»W¼ÈNñØiÆ~î¨Ò]@º\cÈÜœr}ñ_sÉr Û­èáâÛ+wÞÃükÔ%yQ:'—'EM˜fÊíL:ÙÙ;9æÔÂ9?Š§àþNÏúÞ)¾=µÔ¥êœç­>vã„fvù¦w©¤É ì;v­uvŸÒ—¤w‚ôÜ—†ÝIoðàã¿(œüÎ%Ý7%Ù‰ŽÙÕdo“èkk~'üŠî4róÔ®ÅæVc@n‹Ï{uWµ%àÓô¸g"»Œ÷ÚùÛÇ»\UÊ:E]AÀ^—«Í]Z¶ Vÿ–n-Z²cßËá)ÓTèÿ+„-·¢G×âòŸqÏWlž‰èÛ»y™Õ'ωº/ÓSÜŸ¹Õ ñŸñIéÆ=/oWŽ—TM¢¹­™M;UOF÷%íýF32ÆdÆL3t$Cü‡>QÎaZß‹•_‡¯¿1%é®Ô²x@EçK§kÝ»¥Õºîèîît Ò\é™xê,Cxä›»¬\îtåÌÞuç—EÝÈ eçtxîçWirì®êæîŽÅ;Ž¦w8ÓºåÚ6yÞyÁbóÏ<ÎíÐ’†]5qÜî»ä|¼f$ÇÆ=<îí¸Y¤wvM.:ä‹Ôº;™ºîhܺ\‹¥Ë²®ç§ç£Íâ¥Ý×s]Ý;¤9×uvènîrî9»Ç:r!çxòNyÛyãºrî8×J1¸n"\­Ü‰Û»»Ç’ñK·;Ï'W—9áyÞå Ñé!©ø¢¢Ýº= 6Ä&Þ æÂØÌ«VÐô]kÕ0J|hA¯Gw*89|U.’ÝKoaëït°u äq‚zBTDÛc·5*7*(1¦á—wW Ù×];»ÝÛºírÜvë¹LîDë«›–îº."ˆ’çu××€çsµË§wt臎£WÖà]\®\¹Þw“ÇHÉuÝH.ã®î.åÝ]Ý.îîéÏf“΢.t¹œº:qwwuÎWRt¹s®íÉ·d‘F”„$zʦÛnG‰Ë¢ª'S»¹Îiq»ºá& jŠªª”=wvËclq´Ói¶4ÌËÌÆ™d¹é60Ú^{Ÿ'ÛMTµØZÙ†‰šhÖ¤5”7~‰øëÚŽªô^i¾µ$«¹aIÞرeK¸äc3z{<}ž=rîé·þ¿¶0­;니á®èÒx¾•Ü¯™)šÜƾÇ]£]ÒÅÒºø€Ü¹àn§ÎuA€?Ø_7ïœÃ^OŒ·~eÅ©í%Áþ/Œ¾ÛßÕïlŠáw&o£ùߤ·¥ò÷^›“¹“ϾcÆÙr â¥ù"Ü6µ^¾Åi¤6·–ôƒ/êæ¼AW+æâ\PÎ]0Æï}¬»]¦GòÿÔ¼˜vÓ ÷­Þµt9®<Ãú¿ý+Žr)áýQï8ësçµ´†é2Ï]éúpwËYy5y«18…:'—1Lãz‡Ãžêkß°¼)¸œ³É%àÛQúìSŠ_·ÎÚw¥+ÔèÅý˜ÚcÓ,2X˃:Ä$h|ã§ïê<)>U  æŒ Hx實Öó5#¾£Ž¢èE<¨'-—nÐÙѵmÚ”8 §?ã6ùryy—‰.n¯Aöˆô jž£Søêm²˜ÔÕ*a‹Ú>› Ô}êxîS­tCÊò&XfWµzS¾oXe“3{íÉL”öjç²{%{>ú·ÃÛòuZ¿K|Û 31 ¶.šúÅ?¹ˆè|ff:¾´­¹[HáÛë1 OÖS½w]Œ¾jþç¥ëT÷ØwÂÜì—¨‹Èkzˆ~_᪫¹ˆ½g€ cäjÐð9FS(Ì»®.E„¥økàU&eR©æ×Óœ›T§Û\ß—úúC›ñúº¢’ºSÖ>VïšMÝó?Óoù²ÇL•Ë?Ãô£˜ë“o¹8òÆÕÜwr(ö ¾{*˜ŒÆ2üzÀà×”bÆÆŠ‹•|4¾w?йfƾbc0Ìï/ü|?åù³¹.áçžeÞqmg³RÝ·|Yôa𤼈}mæô³½þŸ{æú¿Âiá>ð9ÆëÌ®‰ÞËr’ùÒºè½bN¾Û¿:+è±íÈ%Íž‚¦Ó…•ïƒìüxYM»c ®=YsâöŽ¸ùNùTµQÙ<‚¾u]T•Îpã×Qì™%ãý¿ñ» 7¶ÁQ§(ê˜ãÜ*öO8zÞÌì$ýƒ$~Ãà>“´8:¿è/\œï[µO¼ÒNëŸbuòý­ýè׫×üÇvÿ8xUõ{ËtN¶œ ?)Ì*˜ÚÕ<µõ•\úßÈ2𣢯•?ã÷–¢Ô,Ñ•kæ©”Á¢j2Œå? gìNËdÆXË2pçI=öøï"\ôJ»;ë/)㨗 îþ¶•ÇelM‚ÿIÒF?“Ï«4œŽïol7 %É}ß!aei†Rwü­4Ìxæ%ëºÿ9ÏÂt‘ßWÒ\-®¹!‘á«eI ýÄìF­V@©¦f7ô`ºìÆy3Οþì?t¾÷mÕFËe ´š‹¶œÁMl7|’ÓÒŸcL¦È⚥êavyê‡Yì_ÖíÅö9ùÀI7áì‘uWðC]9‡´vNÊË3<ë‹áSðñKûç¤Úm.ÇTæÙvå:aù Ú!ü äý·žï_cnVîéüÏ ßMgÛ6~‡ Úîï}¼Çúý©Ä¥vQù]£rK¨«ÜS¨8Oþ×~ÌÍbkafUŒÆS0çlÕWß\ÏÅ'ë5¾sƒºÍNþÆO,i/(ò×»Šv®fýïÕs/¶w½*ë üïq8l+ݸæã’.ZÞ÷š§ý¥•[øÀÜž&”ÿ'³@3 ”åß»¼g“ùËoH㨪ÇìV×ö¯Ö¸Kå|é99¹Æ”~>s]÷9…ør­ölõdæ×X뺺RÙ2•/‡½õ춼±}Œ×õ­Ä^–Ž‹kCâ9o$_·vô"äJdhÅþ¶¯Ë×úok½ãÙüƒäï>íw§¢ìÚi62Óؼ³±î]«Ð¹W6W®,úÃuzkmç g_ÚÇöªê^1Á|ùÛ<|=½/ÿ\PX¸‹ ýí[ñú¶ø‹Uy¦?Ù—Æxº¸œÚ:$R$‘D*£I´‹m ›þb†Œ0±ƒäí\*O\›•ÞÓ¹¿uÎ^âÄv»óQÍUäÏÀ¹Ðº à^ÿ¾m_Õåx ·ff ÌË1›õמ¿‡¯ _ý+°Ôyz^P{m¶ÏÛͧ*ä¸.…Uæª`¿öO/+¶ïkÇw}c&î¶N¡i‘jb1~üüÎôÛÖÄÌ>2µé±¯»)xtöÅ?ëñÛ£r§Dô †þWô²Á½¬–)´W }a•}ôé_$—îÿ:ö·™~c‚¹ç.^à÷ qWÂ^hº2ßhôÀó å›w_qüFEÖ×]ï[ÌÒšSOrW¾,èùg«NºãJ랟wþýÏ.qÕ~4'yüb3eœu[?ž–<¦ Z´Ù ýkp˜ÏâÓ8Äî›eâVï`îQμètõs½(N3×½Á÷Û—Këž‘³ž)•ZÚV™¥4²Pÿ|¡=ˆç1× ¤¾-i(k/£%IÄ¿ ¿35ùgD\«ß¾]z7¸¡£¬[rÜžvø×ÜŒ±™™“‡ãÏ|ùvøîu_B¯&ÛEøÄô¹¤±ÙŸe'%¯sdÞïØÌÆf_ÍåÓÎ5k3ˆ’˜fD˜Œ`¤Â,¤¤5)h“h™”“B@%ˆ1„Œ¢ „%(ƒ(¥$iDdɌقLÈ…d,”FŒ¥JS4e‘dÁ £h’0$ËÉ3I˜¨ff1œÃµÃâuiÓÏÊOxÿÔ¾÷ïkÙ×ߘøLþJŒ^fC§øéi¶–Ž©Ö.öH;‘ËãZ£?ÅiŒ­Bhôy{÷é]ékFê'%ÖÍ¥ìîó“Ùõµ±:Cõ!ähôµÜ£÷§È•Ã?ùnèýŸ+37n‘ÀneÑÕô¡v⻫¹r–çýânIäS•øÇ©/»]ÞGðoî«âyÐxú?Qqg u¹Ý¡ëåøEê…‹º íüóì§úüà^.®d¯E Ïɵǚü}c¸Tý/ÌçZWtÁÃ]èODSœÅOs«ö㉣Ì97 îeèrYŠã[‰´iŠ´³-0›  ÇG‹ê·v¡uõÏtffiЯ®æîÿþ¿Sœ÷¯}O¦_Àp“¶¯¦[Bþ^-Ý+ë]·Îw?W³;æÜD­ßCyOJÐC· î»Üvë¼·»M¡Wéø­v•Xz0a4‡ÖÅ?­?šJª"? ¹õAŠ~ƒ9|Žê¢uûi•Wõá—ÖLÓF¬Ç‡ùº® Ï.¼±ßËý&hþ8Úâ“.ccrDàúîFs\#tÔTîö+ƼÍ:îwN½åä§Ä®MÌžMñ*ÜA ‚¦“i±²î ¦ÆÈF8ØÚD$ZILíT@zBš¶†Ym©ýJ¡woóMiî·š{eé0yÿ.ådÔ¬õ·.ÕVZG5wa¾Í¸8ÿ3ömQ‚‰³®šéxphÈëm¯£œrâPe4”3%6Û*Ej ¶‚«¥])¦7mÈL@…{æSÒ,:bXƒSF9 ‘¹#…8Âi ÄQ·xª*[¤[Q×F¨*YHŽ8ÍJ‚Ö¦™COqP=Ã+‡1kW—ZüòìM.‹á.{šB¡)UfVE9¹®¥ÝtïÞys!!&I]wnqx®‹ùýtõ½§rò‘ïÃMœ«¡”MFÜN84êFŸ6uŽ-xº—\ÍN£—÷6›æ{ Ù8ù“i2¹qTäôÎ4ØÏh¸žÏ¼kÉ'—uçx<yëמtÆîDSDjÔr[­Îá'àQGuhۃќ¦qâÝÈ“YÕÖµÔïÝCi‹B(ž$– Ó!:öRx턹ŽWájSΔHù.7P‹låVh#{Úˆm·3ÔÞjä¼ç¡B”¬’ª «B“EæuoýŒ–¨Ó±Ç¾®;cÞë…—˜8¢ø@µ†÷í=ѱŸ¶(*è/˜°‘Ì87–Ê•\Þ]séTBq¼UÖrxÌè?xÝw6{F·çµ•ŽœË½+Í<>K;-füjå=žkÛáˆ/(þ[깄^ tè\àeóf8:Z[Äì^4€¾CÅ\0Ý:?Ëô³Ì àhLlC}±î+ðö8$1¤dY h®(…MbÍ”ÏãõéRËüü•­ÀÑ]$pM¨`ü æó„?÷à~™ù'5,ý#!3šPT/—@¶œg|TÒ£%VÒOlY¦ó ‰È8Æè‰ä‚8NÅ"{!âã/’!"{Ä1ž»)’>d/ƒQA$K…náåj£’‚v'Bv½PîDqQ¼„\±°(BRª„måëÒðèù¾ÁW†}ÇoÛì¼4¦st•³²ht7#wIf–ºÌ¿!ó¼~/ƒnš)ÙLxÝ'O¶aœX‰¿:þêÊíbŸó=ÿEçLA,^D÷¯f?H@ô€Ž¸°™,½ªÎ‰b/½È:1Óar;tïdÂù°Âjã*VŠÅésÉ’:¢dY½»„Ÿ­“ŸÊÁ§ýM²ñ²0d `Û¨ß pÏ»IHÔˆjºg¤«2Ä·ý~ì„ÑY‰„ÖçO7kŸ©Ï:“èO’RÔ:4T©B®8ʘr⡤‚ª*ÖjAÆ_¦S·‘£ÕÕv²”W…‚ZìtU7`¦¬…ÕrªŸ6jŸÍD®–Ó¨žª$q¹+aRý­Nâ›·Ú5ÑWã[Æ"彞¹©b•UMóKcã’¯*]Ã3¶/¤’v» Nh¶hå&/³|™ g{ãƒf„AžSC)ÆënGµ¡§\•.Ê»S>e8}$2E–[z‚ß¼Øîí¸z”k[®³Fëkµyø$QÆñßW=åü„-Ö^fÅ‚‹³bWŶâ‹Õ츫rã´çU\Ç‹51H’*·aŒu¾4ó'F9Ÿ°z@û"Ú*’”²›gÆlÓ£ðÄ[¶YÂ[ØßÕÇ£¯¼ÔåmEšZdºŸöψ|?\Î4DR²­Úý‹ˆnª|µî:²”¹{Œ¦`Òš€luÆ<ïoM`ݦ3Zð¥Ùµ´'¨°·µ|7kW©[söþN¼^Øeï7/êäúµC‘æY†ÿ2Ñj^¥€Ø9Hwèý¨¾4 ÅÈÝóâöøØb«®Ì5×ý¼|´owæǘ¹)ÐÓÂRäÁ8þY¸mQ‹.º÷žËÊ4¼£Ì¢ÝÛÏûJÑi™†a‘!, I D*"$R”"XÈÈE´RT%F)"’ÅI‰ S&j4PQ͈"fLÈM&’b Ø*LjP²#((’"S$Ë¢„ƈ )û·ºüí­{=ì+|ÅÆ9ÒÝçîôïvr=V³ „ÈïrÄò¯g4¹)Üœ­´<{ǸwÐÕ¬o›ë.É/ü^)ûÕò—ñ÷õ+zïð$ÆÓñ×Ю_sú•ãÕ뻀åÌ'm{km~þÚß3[Ü|Oáÿ­øï—¿¸'³ÐÌõΓ4²› éeÚTÙû_ rjߣkÕ½Ã÷Iæ§MóWõEìN'sÛ¹°¢úíÙGŒ^±ý3üÛÆt;óËÃöÆ׃±‹3×iÜû>¶õ´hÌ\·O_¡uøsðÚ7Ž]]ÞE٧米…‡:Av)PÀƒ`&4úíf2œGÝúiß ´ÂCEc"| ç‰)¥RÚ“‚)¼¤Ü†’Ó~|Fhx¡ ?O&¨Úe»Hj2ا96DÖŒ1ŒcY^]t’W•µ]ä`LɆakòp+Ÿõ‰ä‡<´;ñ]3fßpo°ZÚ-W¾Z)¦¦¬R™%™J3 ]ÈyO"㣥­ã˜9Núu…µünfàá¢y>2x9-Ž \ç÷8Ù.©Ì‹Ñ^ñÝ<žõ°v/öþªŽb9kýÿA¿'MŹ¤t/-d»¡ÿKòUþ'ÅÏT®ƒ±¥äÓÍE³v«™¨Ùü =¸Ð}‹º©Ylm«ð¶­ïZ­îjí^ÁöÖ6Ž§Þ1k9‹Ý}†ï÷3£Ó4|¯ððįJ•¸7=Bµú½ÆˆZº‡ðí\ÓÎ'wC»Ž{aý2ç7/þõz_Å.îfc2õÔ¬áÖóvÝ¿×K]W ÎûçŠS/ln?kc ˆUIªÚüªóݽxÿ(å±hÆÜð·æ0hB¦2èˆÓ wßû"DDOB]nú2m·âgñÝcñŽ½ ¢qïá·àR»>¬ÉÈÌW~Wö#úõÊìÊ­~nŽU_=Öw¶hÿƒÞœ7Š«Xü¢ëÅ~3^¹Â·~B­EËÃ;z¼³‹7‚«|§9K·M\ô£pÛ÷¶œˆÑc3)0²F)‘ 4 f1ˆm‹Æ¢"ÑA¶‹&fÂTÌ„¡¦&ÉŠ£QÙëÁyŽÀBcË‘ ¸!€»‘m<‘s;OÝ—yºËÁ4â³[ƒg'†ô“OÕÎÑ¡8†øªh—_qÿËzoŽ©Óg8®zN´Ñ†á¯<ÇqŸ±-hy î5«[ˆsVˆäßý'žµ+^uÜÛæÛn4dÌX¦òÝ«ÿÛmUò ZI‘¢PÒÖõú¡ÂëCë¿+Ewv¯Q«¹~©¢OÛúÎE«çØÌl)‡'Å330Ìfµ6ÎZìÜÛR×tJt-[픟bÉw›8?yôZ¯øʯû‹¨%Úµ[¹YÞ.`»…Óë›.OŒÊµW©`aªÚKÜÏ+¿¯7± ¯/iUÛÙ;˜kÕ¼ÃÊ» SÙG‚ùŽõ¬þKGSî|õÈE¬^ö½l´ÞY™^'­M-¯vªÔâ4~ ™çop·¿Æ¦³ïKoãU“äá¾/=G2¿åÔ-;^9¨ïÎ~h¦«Cã}œòa¨Ùƒt¾ê¡{¾•°±ûÐÒÝmyæªtœ¸í…ÚêàõÝÏg×ôÔëÛH»ÜÃÓáå ï³é´Oë^#òa¦Y¦{} Ý¯fßxº©¸ØdñVçÚÛükÓúÄòjyL+ýõS¬6‚v÷W?¯µ¸;Ÿ[:]ž¬¸‡ßZ²™G§Æ[[u†š›5N2ó| ŠS@ ã)V¨Zc‘ÌpMjxûNûãA÷íÌæ:ä¡Õ®EŒaƒûè¬uyI%’’òê¿7å×-×)z«j¾=Ñê}¤€zƒAOü œÓûžˆÁ†Ü|PpA"¼«Ïø î¿âÖÏ=ì=KÊxñ<Ž8¥Šñl´_AC×ûkß! ±ˆ±lÂI›ƯWnýK•îo˜o”ôÞ–Ù9¹L_¯Iñ¾·àü[Yî³ÃjÌû»w³]¼šS¼±?Kð²8ž­kGFoyr&Ù·Ü[§VÖÆ6_ö_}9Qš½‘Ð2´TýŽ ]MjIΕ‘ð'Jùmm_ÆfV`p9½fàøÙfSC4ÉšYe™Ô‚´Pñ¥aWçÔÇ£cM£1f4a¦2µ)Zü1Ž³g¸eRKÛt¦¥pã<-õWžuò¶ºÿ|a\wpiÖEvhi½½Á4¯ü±$êN嶵œž*{hòkƒe1ÑÐ׌ž]òÇ]aÎøݳeƒ(Ù,ž4Ï$²¦æ¯Cö-5 —X¸Z_ñêeä 9y&½Sãÿi¤¯"g˜fõ…øâöÚ\Cö½W‚J3 šQ¬l2D)šh¶%kào~øV×»WÚæŒc1Y+T¥®.¡¦,l3¼¹^p­.1Êf¬ÓL³çl?e¦V¾¾lÔŽ+as½BÿÁ¡} +HÜXÝ bæYrÙ$íŒâq_+Å’Ý'-]W*ÂcF“3N}•¯õˆ[¬c®»¡à;Et ¦´¯ÔÅtÞJºî¨ú¬ë1ÊŸ¹KÕ×7ïÛ)ö²”õA= âËKü©d«¦£ûâB­^GXßŪ²½žJô¸ó¹^;Ó¡¢¹Ac€£7½¹ªã|ÑÕã0Ás#²;¹j“þíªéoG”k Úë…øMQ檄—Ç{JÞµéª×ÒªÍ\ÐÂ'ßwexrZÒŒÆ3 fe–'g‹Þ©1?t±­’>’&oñ`5^•æßûh×¾+F¹ÒZÌd»] 8ß“@ó§¹iݪÅ{ÏùyÙá}–šÊÙ<“›h-ì¾Û¼RÔ¤õ¹>sziUìž…Í¢÷ü§=ÝV—ªž ¬«<Øn"Ê®z¬z&5]üæPälæ™]uáKExw¢ÒåÇ#l¢‡òT^µœî3E}žxˆˆÁô–†Jà  ‰7Ž:dÕv‡&v]ožVn–UuŽ^WÇÕ/U‡ ^í-É~T=}1£KEY—†tÚC‘$ay´0] 'Þ!ÃѨ!ü´ámë«6ö±Èm©_¹¬¶¿ÎºV…wY~:Ž5O5:9Ú?¼k+‹Gr-ÛA•Àˆö…eCJ©ÞÅò¥§ØMì?kôa½¦3Ûjzyµ31Yd93jvv HÿÁ‚ëìßp—¶N0^ÊÄqÈsèëW¹ ŽC LàùÜ÷ ­Y‹»8T´¨çí;wa&²¿W|m¸gºmÙÑØÌÌ)î…’lyσA[ιPãU?[Ê{]a÷LÇ¤Ò ejb4(6Ê_:&RëÊõšE´aV²^¹qÿ´Éf3Q:WÅpút]²4Ýò_ö±z>ÀÝpÌÂÆrÒdc¬Kµ#)_¬ ݱ:7ph.„“BŽÜ=Î…ç뻧ÓÔ­ë(0g ÉWW`ýø²ZÞ§O™\«+„«AsnÏ­W·ý´ïL’û>ɤÛM~gÉ´©z©ƒê®=\(30wºX´kŠã¶å³´Þ¦¹Òs'\vQZÒúÎüOaF¡^QsŽN…À¥«Y9…¼¿“E2¸EWè\âÖ¨þ6>K•ié–T·§röMI_{'e}óK×–(ò…É (=½w„Z‹ÌÙ<ÚöˆöbÅåÈ4Ù'çíáÉwÂÐî¹|…a€éIxº¡w®ö³H5åÔÍ=Àc»ðØÐûO‚áw+v}H¹m™ý _XŸ¸[Ÿ’léMhŸ™&À½ÞW&U=çÅi:Çîiï”Öµ¶¿u_×ù¿è\ñ½/c^¾K$Ĩ¶4TTJi¤™‚™b€”“ ¶5“1„"PÀÞÝÔHJÌ3'“†”q“ ×’y>;tV¢ÛG»ôÜk½Õž>êu½Vš6s9öѸ‡“za¢t6PÖÅOYgTVT\šaaMQ<<ðûssºišä{4dŸÄÞñK{Jù[oŸùµ·ÿvZ¯V³[Ü}`—s{K5iWþ›}i4¦mÝ„6bd#ÿýß!®K\“Å2 ‘oZS1ðKÚ‡³VùI­$ôÕ‡k1%ð)2.TÈßݤ-û)}Ö{3q”žÇ £mŒœ±j«÷Õ¸´#íÙU_’8Å‚»$ý JŽµˆ¿z,*|ŇK¼ÓÑwúùoJ­h_ÉIˆ6N%_Ç—ºÃvÜ»3ΖÐìïñÛ©jw)s.œŽ©W<ÛGƒb«Âó š ¾Kèq»ñZÛÏ))¤—¦ú£H^gömíÐb\ZNBÑ'‚¸’·Æñõ´Îk_'R×Þm¨f/Û§ÕÛ´¯xX•å"æ,—§Ž£ÓÍE[1¢6ÙFñ'gÈšwžšUñXmX·ê»üŽÔ•°]÷ã°é•­/Ö~§T&¯†Ç: ½ó ÓC%ͦÅ}){”µ Õùí!»©'ü“ÓZ$ЋTÕ+êaoŒ\ʲS¤b¯Ã|6˜·|>àÿÞ6Ÿ95S»MGüWuZ‰·æ ûÖJMã.ŽËÒGpÜ´WIx€j9»›ÇËA[œ³f`xËã´}^¸èXjSyl¸„µ {Ù|Õ£PôàôzŸ0¬+¬|2|=ÉZÎ2`ñø;‰e/“b¸R¬i ¸¸? ª—üEùm/tYçá¼i]Ów¤.ÚKÅ^@­~{c{…“ 2ÛuüÏ"‰š1W¢3_0Ýéx¦z“ÿÈÊáð¢£ß ó3>J4¢Ý7íóM^Ú? ã £ÿS)?ª?ɵF¤>b8\7‡f´GmÜ’ ¿Ê*ž]ˆ?\iš™]ýûžåtu]fk°ñ–X®‡ö#ÆÒýº¯c½ô¤µ½Y]ü4»¯œ¡¤F⬩ú°âq«l½³cTÌ&Dû¶çBþ„Xåhz*š-„<~›=Kºö^y!kªqGiUÞhÇq9p¾[PôÜgγ^~ ©Ùöhá˜:{[ð;ÖòÕï’PbB š¶+Œ\‰yqxF«Á Àháx=»¯./£´ìDy18øx¾á“þ7m–U_°8Ö+Dr¤Î÷L—›«×«JÞÛ2ültïnàa牲GäSž‰¹ã ­.#Á½¡vÖ¦ú—¬W©+ëë)xv#ÙÖò–žJwŸjK‰1\vÛ[ÏC]Ñ1Šé­•ÑøÅqíEýEü•ÛmBÚÍø±Ìù¦•},p…zºõí%x‚Ç ¸ëµ0™4µx¸e.²®üúëîjr0ïY}ŸáÇ“\ßžEl VÌO½6ˆöRÈ?Ö\0Ð÷u‹ˆ¾È½Œ¾í?ž‘Âm)˜rEìkâ¸? ð?ItœsÚma¼0]S¾ýßO¿xbÙ¼'á}b˼}öÚµ¯‚èõd·äySÿó’e5›(v$p ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¿ÿÿÿÿÿÿÿÿÿÿÿþ—ðd(@&Š¦ñ)à˜MB=G”Ó@€€biÐÐÐLCÐ † †@ ```¢B€'¡£IL 0i©‰¦Ð¢`ÒbM©é¦š š f›FMO@ŒÊl êOIIú4ÐИ˜2hÐM4õ4Úô§“5?öÞ’D?ûD‰Ï>õìwˆa“ò•£& ©† Õš°ÃþêjÈÃ6l˜4j¦°Ì²jÑ£VL•£F¬*°Õ™™“&«3%aL2fÍ›&d¦L˜f¥hÁ£6m¦lÕ›3&j̓&JhÍ«Fj0ÔÍ‘‚µVa„˜UZIªªUUaUTª•„¢¤ÁFa††`ÂU&ª¬0aU…†V •‚ªaUXa0a*˜C %a« Y&UUU› Œ0ÉR©¦½÷-/ëg³\š6¬“b°R« aJ©ƒ *« ªUV†+ 0ÂR¦ à )XaX)U„¬+ ‚ª•XaU…VaU†VÂ`©U)ƒ 0¦† + 0ÃI)…+ ¨¬0& ÁURJVŒ"ª¦Š¸J&U ÀÂ`†*I…!J•† ‰m‘DÂR•H`Â%S Rª°Ã …L$˜aÖÁ&*¦a0•7²UA’**RndelÉ Áƒ L)d˜J´J[p¨TÁR©ƒkd™«4ªÈ`•*VL0ÁT˜fÍ„fÌÃ6I“%¬22`¨É‘2ÆLV¬bd’– ™2R+ i† ¦Œðš® «DÉ¢fMZå–í2+F¤Ã-q®0Ê›\\afd¸¦LbZ²Íc •˜fÓ6ŒŒ]$×,5».L•k˜Æ3ÐØÃa.¸]­dc,™eY±0™æL3Ï·<¬Â±-Åj¹dÔ˜ËLñI³Å2fjÔš´\”Õ’“&Fc+uaX& Õ“VŒØhÌš0Õƒ6´5L•“VVJÍ45Кë›<2hjL4Y¢²fa«6¬šµTšµM˜fÀVRS,µ`š“3&f¬ÉªM ®°ÌÉ«5djLf¸fMXhÃ@à ڥ&‰’²5+²J1ž 5’dÉZ´aIª˜h¬Õ¥EL5gfŒŠ¨Í™ª*£FŒ×+dRdS Y£FhhŒ•š°¬‘†fM ´jY«VªÍ«C%³kÆ¢ÌÌõRjÉ™›gQ©Z²VˆÉš£5GJѱ« Yì͵· F¨ÛŠÂ562V¬Ñ‚fjà L͹¹µ·bí&I´ØÑ3VI“ckbdZ6)£6l߆ՆJÚÜÚÃV±¬ll—jím&m¦mæÓd×ÚòÍs•±þ× 0±Äɹ¼Ð•ÀÁ7Òd¬ÛæÔp#sc#c‰†Ôllh,¸4a°™†ºï8Z¶£W @âjádÚ¨Ì7…FLŽJnp¸µ™±›‘u öç¾áfœ(ÚaÂhѵQ¾Ì7Ü%`ÞdÜádªÞFÔaÂßfàSˆÃ6ã…µ±«7}¹X7Û›Í綸œLœ,”–,qiw#±ìœMÎœØÓk Â͹ÀÑ&gª7¶´L+…¼ÍºÅ¹75E76µÀ¬Ñµ¹¾ÚáÛ¾ŒóÓŠÜÙ¢š·ÛÎ!†MˆÐâoµ0âp2L²Xp ÌâÌ6¸›Í†Öñ«&MM öósCžûšµVæ†û&mæmæçY¸¸e áÃVšêßoLŒ°àc]æÆû‰®xq4dܳqoð8œnćÏ̇v;ˆxBÓ°mfñO vžW‹v¦²Wbñfñ-ÎèCµ7+Èœ ŽFûÇ99‡ ±Ä®ÁÊxöMÍçÄòüÍ]“6¯ ÜãVósžÃ',ìœöó 7Ý‘çÜÚå8ÜnCšÍ«½7œònµµÍq·4o²uŽ¥±£‰ÆÕÜt š2wfNƒ}Ðtî6ûsFÚÃyÑ«‰ËrÜÖÖÁ¼âsÙ³hÚî¤;W#Ër7ÜMÍNè®ò®¹ÈjsN5a†ç#šÕÐdê[sFæÇxz=›SG=]åÊq90ãr:'AÆÑá•ÂÞfÑÀàu®ƒ¦s[öÓ”æŽSk6n&¦+‰±ÍWAÆï ˜Sº·œ årÜmŽs…£&Õvç§uîSk¦o+¤a±ÀÃ…Xp8Çqq:§–àsS‰Ì9®G)Ðw³}«¹z^ªº479ÍŠêÕ®G,‡naÎf|Û–Cštî{§tG£o9¶0îÎ'RC¤sFî ­Xu©_4ß*«¼92+G^ê]½›¬hî •…a†îì*IZ3oºÆ€ï¦ŠªhɃ'A܆Ó4ê\J©%•d“N¹$ªº»8M㺶[ôåœNòœ÷Xg«–Xå õo0¶¸¢w·8›Ûý$“3¸¥e0µ$白*&Åà‹é^£qßÛÈ›ý¡ó©ßµS&ˆd˜3%3y&Jï-Sy™É’v­LÓ'^Ù7™10ÔœŒ™36û¿´h›ž „Õ«TÉ£$ÊfËÂ&õú6NWÍtÝÇ,ÝnãÛœvéÑè¨B ¢tu\®1¤ƒ…ñiª22ÌQe—<ˆ¬Ò»€„š*¬(‹†]úF7³ s ôôÆ‚ÉZzYèò·ÍD–Iñû•·•¿Ñpsö¸4ד{ œçJ•Ðôì3'Ò#Ô“‡FœÃ  ¯ô£õI?ÒÉL™0Vxz³GÓ=c òL“ ±”õ¯Z’SÅzç®VL¨ú—˜ùÑGšyÇ_’H‰!åA,‚!=X„d$´DŠ²n¿æ˜ÁŸèøøþªìó{ÂHØT ÁÇxëº|ÒI¥A!#éXIÊGÞY"6õÝ~ñ*.}_]á¼~£¿,‰ie´jðìwì|ÿ€áôhÙR!ĨKbKHœ•$úIl‚eb[A…‹-%±lHbâÛ!I‰l•¶Â¬U²¢‰¡ŠI$¶I JL[`BØ’0¨bˆÅ‰&,¨ˆZ‘ X!l‰"b‰²$Å‘!Šˆ‰hI#! d€Å$©1ŸÆî¢ãÓ=q·¯äÛä÷´x näîÖ:‰†HI<îI’ B¡ÀèÆR$’}éRª*U %TJ¤"UETªŠ¢¨*¤*•R©JUH*¢?µX+ ª'¾T‰2,‚²b0© ¤¥ªª©J…X"¬‚ªXH*¤%T‚¬‰+ǦL)!TD‚ªATHª˜T‘…’%TI0¢Hà ÂI •$Š•¬0„aI ©"`¨†SŒ%’Fa!L*ªL$lIš¡îŒ"o½L’J’ ⶕJ ØRFIRdTL’¤$‚«s ¬+5a“%+4¦l•›#&EfÌ©‚«3 ÕY³aY0&fL)›%0Ɇj¬Ù³&l˜23d͆c5dÃ$¦fÍ“ •“&«%fÂd0ÂS&L¤¦0UVl˜U2aU$“DE îê’bN‰ˆ§²%§T£•±Ym²È¤ l–¡ÕµIÈD‹RÔRA"‘P‰:ošÅãÃФ划l=³fK‚÷ãýoí?|OÍÊF¤H$uÉdÜùg©e#ä+˜ÐGò?'qR})©õ¥ö¯=[ë†p’BHý#F>ìSø“Ì4ðæŽÙöÌ?Ø;‰>:‘Uí3#úÐ礼=kìÎÙš6»ªF)öì`”†ÊIý "¼ÀòçdÃÂÎÉ…y5*+*Ð’l“‡‰DúÁPwrVDŸL¨À8Áþ§‡8QÐTOV•ÛÔ‡ã¨OîJ$P{²;°V%Bt‡ßOT¤}²Rj Dtu!ù¨òȤUaI"?°Šx…OòOLU~’&=û°DüÿÐ+ ÀPü—a$ó G£H¯üœI„Ÿ ÿ·Iü/ø )ÛÖ¬ ö¨•Û‚§îŠª÷©±(TGhÉ$ï„©ðžùÏr$vŽCQü¥?ú‘ìÓÎ!›óEDGê¿(ÁÝ_v“Ú¤`çøƒh)ýÉ? %HòãüS÷ÏÉaõêð£üÑàJTªû©'³· a†NÞûf ªÐ0ÜÌä¥%°Á’dôhïÅE=£<#DzT{DgOÈÂx6L0Á-G\é•))Rx·”V©ÎDrùfö\¼ôg«ðŒŸúy>‰ „Œ!’G aÞÌòE"{tNâQ“¯zwnàu$îHýVÜOÊnH?äý§é$dñÝ‘ÿS!#®DìÒzå;þÈŸŠ’{ôû'Û›’Iàßà½Ð‰<+×:ôé'’nøàùAöhy?9ÚíÏ,mIÚ?1×>`ò¯PýÂ>Ÿ¾ž¸Ÿ)Þs•è ªO@ÚBtÿCõžhNø4Gž=™ûHñ>|ñ¯ AIGUJÈÑI¸ˆ÷@| xÇ¿?˜ûÂ>i#ì~éØ>'¿LõB{éLZÁêƉ"{’A<ÈOÓHªªïB«ÁXR¦QXdÓzÌ}ËÒò.~w­|” â<›Ö¼> ÿúcâûO„í]©?ÜŸÚÂ~3ïéþm? ð ßéÐÿ$†‚=[Ó=»úÞ ów+bIêñŠ’| >¥'©y·›~1¢Oó”GÜ3I÷ $}ÑÚ¢w—~L’DíSB'ë"~Ãü{R¼~YªOLž%ðÏzO¾9Oõî{øã^‰ý/áVŽÉèÙ÷÷ì:·Ú68Þñ¹ëp°öϲrÛbø/LÚÑÈóíç9þ¶Ž6¬³”ál|VÇÖ2lyVóðzž¼ârÝC&¯ êœ&ÎTþƒªhê+«lfÉËtOßtN[qâ_1“syÌtï´}£¤o¾K qº×¯,uÓunyÜ[š:§5ÈnsÇp3·¿¥Êq¶:gHúÄuÌ5uN¹¹Ïrß\®¥Ò:ÇVöN­Í~s¥+yÆýç°H|Ûß"¿kïò&BœÓ ÈÁ’VMZ¿YïònxFמjÍMó )R«p¥Td£#&d d™Œ™Í«>¨š4M‰RMÆæ8Y³2o"eÂa‡"`ù „ìX*LÉU)¢z3FIšL•*h¯VŒ34MJg¡4f™¶få4fÏ"vÄ󜬎fìóÍÁï™(Ñ=%Ž° 6Æ#$)Ï(†@k•Æ æù à9 0m9˜g2o²{çÞ3Á‚¸•Í)+"l÷m{cb¼ ¶hõÌŒ2R`ÉÛ>Í‚a犬“"aXHíONŠÃaY0˜>Íöb©å‘Ó¼kÙ»'Þ+Ö¼[«~[ÈŸÆëŸFüÇŒa“Á8ÞQ¾ähØ͓˸Ù64lx7†|VmŒÆ®Z²{Öãc…ÂW)Ë6š³WŒfÞxVŒÚ¶< &×Õ70Üf­Ž[&MÎS…“kFû˜Õ¼æ9LÛ\º8Âæ72q6²nlq6³o*¸Øs:÷šÉ¾ë›îaÜœ \· ‘±ËhÚÕN&×½“kóÊó­Ðp¿‘#°*J®Sè>ƒ5S©00¢¥U?­RaÝέ’C!Tªš« ¥ 62zi(ч¸Qõ*…Rf*•)UýjØÚöÍ¢hÃGð»6ƒ5IU]+­jïÌÚ$ªª<£þr¤ªëàÑ ŠªW²W-¹«¶fjljë]#»=Ó'R؆×5^9¼ÜØáhØUdéÙ¸˜8œ.­…VÖåJùjÞuí.Þèœ->uÀéÚ#úÔªNJãp¾c¦q¶Êlp9îk'›r9ì9¦[†ú©Iø« mrš9™©ùlÜ Xmm~ó7FÕÆÉ╾ÚÚŒ»G&ÅyæÓjŠŠQ‚º æó'AÒ7ÜNäÕÏa9M¯ÚWèç1Y3U?=\ •“ņÈáa’SÚª©Tmp°ÑN7A“%h¬> ܶûFû˜Õ’ºg=ç3HUG²SÝ°`ýår2L8UU’¼¤Àù…NS"0•ªó*a†ªR¥PªUHžIX`ªäQ0©þó:¡:FI…J©UUJU%UUQ*U!J¥J¥RU NZ°¬0ªªURª¥DUUU)QJ’•Nèà à …T¢ªUT•IEBªH¨ª¨UURR¢©ø¤(˜)TªRŸ%U‘’)U*‰Rª…UR©!RJ¤*ª•ITU$¥UH•R©T’ª*ª‘U)d[V––ªR•¾úl²ERTªªª­ŠˆÂ•UR°¬*•0Í‘‘Y0¬0Ȭ£ ÂRª”Øɇ-Ÿd³%U%TªUJ©U©+50ŠªT’•¨•E–ÙR©T¥)R”¬4V+ ¤*U%TªŒ« ”ª•$ûü[ªR•JîªÁÐúÏ«·6Y¦ÜÜÉ’¤”®îà ÍÎdÈUI=¬`ØÍ‚”!‡6ª kÉ-’{Æj­Ÿdßa3§Æÿò匲цÄ©ËéW—ñ|_ÁÅË-£ÿ*Ü íÏ|Þ«ŸÓ®ŽqX)ß~kFŒ îð{í¹jz†¬6ªI‡LÃñy1ŒjàVJàVõÞ5fÕ¼ÃTö^³¹âãoov-zkwÓËáß[‹“7 ¯u®7ò>åËmmy7)æ¾½»§·#kiû®ywfÙ&È6.+Ä2=ë4ÍÔ«xæ+ɽҳ¦Œ;ø»ýö 4§Šu ªœgú\Æ`òo0ê^½£ëÚœµvO*èþy~©ÆltO8ãp7š7•ÆÕïµmxfo ß{åo¾‰µÑ¸›^e›yúm¯ã}³cݸ·Jë9ÊóÎ 'A[][¹çÛXfÍÐstì7›é&7zwƒ×¾uÂèØyW¡p?™]+˜äy'þZ°Úå3l3z½ÆíÊÞfÞaîí×½#¤t®”éÝk‘¾å¸N&×zeìw˜ÇDÜáa›è9lˆ}}†NôásN‰ªq*IÊè;Û&ŽGw|ã&b6VÕuÂx…f•¬jî/ŒðQ×®\>Æý+<¹l+«umŒÈ}W–·þ©› Œ&EŸtï•]Kº;'ŸwÇ\ïìÛMUÞ˜a¹™†­Î½£  ÂUQ)àœnEfˆ¥Dy'÷°#UhÑ„“'Dó]C4ÎRåÑxÂãáw2Fª¢Sr°RÇÝ»Ã9«£aÑ:&¹íU£ƒccC5NÉ8™ ¼UyÇsfɪu«9öùÖLÔôN{™YôNYÌq»«–¯ sZ³fç0êÜöæLÙ72nhÕ¾àr0å¨ÉS½«ñ°IŠ…<h½13W©ùûp2T©UE)R*UC…„“ )AJ’ª¥JO"£¦ó 0”•R©*IÂå;g-µ\÷5XhÕ“…¸ÊR•b¥%J•E UI)ITˆÀÄ;’¤ae”R¥•*J•IU#̶º Ή¾î­ýÄØéU£4Ãj¹r8èÔâ'H©Š°¨å«ªªJ¤;¢“ª¢©«FûÆ®™Âll7˜n§§YR©’Sê”0óHɱfbË,c·°ÆLDµ9ŽS™'=ÄÑËs•ú‰†Ç-ѹì›Y4o+V˜ˆß²×ɉREKjujÅ%¶ÚUU[VZ²ÙJ°²Û’⤥’Ú¶ÕK-«VÛUKjÕ”ª¶))-«–ËkÔãm«Uc¿\-¶\Q0¶Å–ÛUeZ¡l–ÈjÚÂdµe¶[RÙiÝ*ኡeµou¨[RÛ]ñb1J¢LIîØa9ÊÉ0(_,±zžKXúµ`û¡ITªJlúDaROˆÁƒ£R0T;»¨xVIš¥T’«¾(Œ– ¨ë”ÁRWNÕ’dŠ¨ª¥E*…(*ØÉ‘’"ª%S"¤0£ L,‹d´KbaÓ<ÛC14P˜TL*QU!…IT”¨­Z°É‡ûÚ²j¨UB”©LÙ*°ûÖ²"ȲER|ÛÜ6´f¬0FŠ ¨•‘†Ì˜dÀÍAîԬ̚(‰¡(R‘jÐÕîØN‘H3T“C&ÆÆhÑQ šTZª²ÕTFE{†lf¡5+UHÉAT’ªI¼ªÍ[sVÆ¡6*%+cÊ›Y5SóMŒ˜‘ÿµ!¶݆X2!£&L†ú°ô­ÌÌžA“EWÜÃ%d5+íX`öÉ=ˆîj{Ã$IÒ{nàµçÿí]Šíìròß‹ú'ÎI#ÙY$Z„I³lá×gNzOæäÏNQä? Q¿Å6}£¼îý 埓¹ñ‰RDås6¹üÝ #Ȥ'ÜvNný~[øwú{Ì÷­ôÑ*DÓƒÎüêwdÏsnÄIühžÁ≇sLÄŸ¬ýg§:wã¸8ù¼ÿËê¿gÿÔt¿ÅÆ„ýwчoüþÍ>*;'*w‰Êy&Ô&©!ÝÂHêÒ'“vîdîÉÛ¾µ?I&Ôâ‰ËžÜõdô?EsHlùÓº>äyE ê#À«$‰âÑùì ý’0Ÿô'æ0„Ù$‘Ö­¨D‘xâ|œ=DîhOœÞHüdófð{~ÑëÝ:ƒ¦ Œß+¾{áüxlI'S§Íò¾{Å~IñJ¯ßw¹¯Œ Žƒ¬û@Øž`:GÙ;ßo ŒÐŸtDÕ~0óžÐªžÍÛÑ_ñR¦¡Êþ7K¹&d’»Ÿtæ]ž1¨Ÿí'u>#$ç£r¤Â#¤¤“Ü#·&>*¹R'ÿARGˆu|¥öO¤jÕ"aÅÖüÑÎêç\ “¬t×y ži÷H©½®î>÷Ö/>£ç9ßTøüœ„Nâ‘DõDžÕIó…ýHœš@š°ï³¹t{Y:N—¡ÊÆ1ÍÓMô's¡‰ïÁ›£àèsuñ/ç0ˆ~C›Ãy/tÿ{TG¡(vô'Ä0‡²Ü_ÝŽƒ4ÃôÒI€|%"{T“æ‘DyÑ(ŸèHù¯VdƒüßÔ¬ò$Gè¤TˆÿÚT$ò'ܤÀI÷j‘(~aóÄÉ";ª¤ŸX†¡Ó%U HùBw©J’ªJ¤2Dñ © '}a$ý=Š#€t`‰öĨŸv­æÿ1„÷…Þ”O¹>»½²#÷…0‘ñˆy•%w—lÉ×daP¬ÝÁ…&†ƒ&$¬$ü€ÿa†'‘hû‡×2T{”ryVL20ÉoÞäÍ‚añQJ­;šwÌ<ÑUÁQ^AyÈF‰<)€žABy¡PõéPO·PÛB¯E¿ÈÓ°é>‡Ïã¦é÷Ð:¡ñ=²0"?àø¯PƒùPT™¢u#A'¿C߃„•gŸÉ‘ã¨oòf‘¢¡ÊíηL··»ÏyÊlÚ‘¿2Cži(Ÿª”é3¨;C«=jU+ •ƒ 땆ÁYa_3j#¿ÓåÆþÆÔ7Ô’©;¢`z¡ðØNü0À|L$ù †Pê:O£{xïŸî<Ïoµ¤`‰û)DúQPþÑQÚH˜§2‘Sí I3#à¥~¤á$¤N»œÃ¶T*™TsúÞñÖfO­vÈÀzÇA„ÕG¬Pþ…#Ü¥ íïŒ;Ò&i€¢>…HêU‹TŒ„¨ïlÑ™;ßÍó›ÿ[¬Ç×ç°MÏ„T0’sƒô uíßóy¤}ù%Ù¢vj£2ªNðlT°ÐO2T#Ç¿ìñ"UU$È#ß$L ?œÂH•ï©u½(Ë óÜ`’w$¨û¡Øìê9{Ÿ©©jï’z4‰„$Ñ®*ƒúT›»† p>‘R'©TšT‡MóÞ#$õ%!"·¼§­öy3<þ–J“óÍþ³‹Ù´?=SÔ¿ ˜Mõ?îJuùúçê3šW”yw³z32NPaòÓû’{¤}s4òÉ]üþ– üS±$~ Ï0÷JHÍ܃÷ž©è•›ã§¨Dÿ7jíM& ‡Ó¤ëL?©ÀúÇø×¢OtðÌèŠíR}Ú¿mÀïƒì'ྙ„Ã6Ã7¤dÑ› Ù)_Šòiï4ljÉ2a0à ͆îØa…fÍ™…f¬0Ã60¦Jw6ÔÚŒVIš§×+Ud¬žõöG Á>ìÔئ¯€Ã%fâzvÅna™ôŽÁÄàz‡!ôîk£sç-“VæóÀÕ£œå8•Í×ϵe¡¡ª¸[Vû”áq¹m­XhW “ Õ¹ì•Y&ùMà`ɾ͢¸Õ†ûŽãhhÍ£äɱËLÁ£˜o¸à,œãb«CÓ+@p+ç=†Ù%^FàßNSh2çº#‘’ISÓ"dÉ0ç9­è„ßV3DÉM²`ùm®2hKs2l`É› ÓW´N”5­µáÕœiXjaš¡š`ôdÃÏmÕS6+)›6F‰št]7M´Ë6»x¹¼¬¸ú=½ ÷õåeÚ€­%A]ÉT •0<°*áÍ€ÙpD¢ 2Ãw1´Wfy3¤Á¦¼yó¸81»…ë ç&î™æyº³ËØß%d¬ól*»F _bN½šdÉ£6GwaUUùöÌ•“bd*¹´<èQ¢2 4ñ, ©*»SÒ²¨òÉþïÝ:Ÿàï©Òžü-ñž¹ëŸÔ'D%*ŽîŸØOj>¡>¹<«ûÝÑÂIäž™*R•UUJŠ¤ª©<¢~ùÛ*HUAƒÑ¦î/Xõ‚?H~Š|ƒöÞí~ñ üBuïdWŽGd‘êÒU‡pOø§½OÑI:¤ÕµHìÑ<ËÒ§JúdðDùf{—N›V(‘ÿ¡;ËÕ? óx䜱ED¹wô¨TR'°{c°°RQâÓžÅØÚòßPCà?Éã‰|ùo\yw®>I$÷Gð¿¥Ò!å|øúsê{“fŸÜ‡¬|§^ìÙ#§u¬}óð’šO˜;F¢`NNÄðçæ'~h¯6~áÕ$÷)Í vþT™Gé*ª„év…O ªÂ°Ã´O¯'bûýéÚ=óûRv„W‡TžtñÇúƒÍ¤~Y9°Âp“ͽâÄþªv~ $ª“{ +^ÉI„dJ†L¨a>‚Rv‡­a)4™²}BèÑÙ³¯,ðjHŒ>[ra5ú†ÇzFŒ‘“ fÄaäˆrÕL¢¼_ÁXöé&×佋ï^¶Ghÿ£ú@O½Oõ¢¹BO©)ô©ò_{'Œ'á¾;šý”;«´$~Ê4úÔOûž‘=#À¾ý©>žÔ|Cù ì‡üßǃå'«xä}"|$û?½íOŸzšCÏ"=›óNDú´zž-U_xHí{AQ>Õ'O°}‚Hï$žžIˆ¬ÃÊ0úÅzfi:Õʨþ5HóHøi'ZìݱìÏ$è>2ŸäOR>ÕñœÄ|gõ¤ž¡$ëŸøCÏ%#}ÙŸTìß|&IÿÄìh;$‘Ù>*½³°>bzò?æH𯌟‚©Ð'çÝ {âGµ³Æ !Ù;àü1)ôµ$ô§ˆ{"> ÷%9ï˜}óä$ûDüsxµUUGÁ~±*Ÿ‹ÃÓ°0ª•3xfJ{§üÛ™¼+Sc&fÆl›Ì7*¼oâ76)[Ì&¢)JVa†V 0éY²2JMˆš8 š*aDÕ$Ȫ*lL2RN†Jyö­MŠÆ Ñ8 \)·„íͽ‘62MR’‰ ¯®jÕšdr›Ù¿¼Õ–M37iÊÍÉìZhӕÆìg·Ø©¥nßlÞ&m6úö¤Ñ6µJö(ÑIìON =‹DÃ6ÄÃëQãɨaêžÅÜÑXGsbiY3d±Xw¢iC êÞUZ匈ñû®wéŸý=!¹yw´q® :×úé€ô‹v e$ÕJ„Ÿ~Ú“¸$>É Ðô/ût÷É#ò¼ü³¶œ?!'é¢`ûtOÀ(|ùDøaö#ø¢|DÉvCGˆ>ë ß-ƒ ‰ê )*¼àÿr|µCÔnë«?AóðïrÚ“é_ü=º¢²VÜ}(¨ø)íßõ€êøw´ªR¨¥Rª¢ª»1?qðQógÓ=2|·fðpŸÜþ×Tõgž9<‚(yd0“ ¯Ңtò§Ï?XûÇÞ¼xò#äîwqäútx#êQÊ%C">¤ÉY0É‘ë˜ÁêY› ž¹§®dL\õ¨hÂ6³2FJÍÕ«%g¸õÊÑQ†S½3ŠÍ’0wfNÄ9jd²;S%ž1’b3¾Q÷o4ÿšOz¤wBEAô§ð$Ÿø$;7Ý!ôï4$ó(©ÚžµãGŽþ¢>½ò^pNkÆ¢~2~ê<üÏš~¢#ücîG<ÿ’vi#Ö'–ùTžØjÞO"|'ù'whû„øIR:ÅBLŸÒï‰ñßâf>ý“ÃÀBžéÞœxÓj|´ú0ö†;âh“îy'hSõÉÕ¨<+Ãø¤x””ª’º”¼’OïJOû"{%*Føi>Zx¢|µ;CBGä ¤~ÃÚdCØŠGñ’ÑÛ<£4LÏ0¯tÈy40'÷Qòª“A¢IÁ*I'–|´fL‡–wÓï‰ìCܼº'È™žäže‡ÈwäŽRCÌ»óGIØ'š'ã¥ED{ ütIÙŸ®žiÙ§œ>PÂ<2tÏ<¤GžO6|¤ÍÇtOÛO´|&á;“ ÔÉùÏ,“Ådã½@ü7¼to4“Ú:í>¬rþ.äŠp¡ [téœcards/NAMESPACE0000644000176200001440000000615415053435634012603 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_mvsummary,data.frame) S3method(ard_summary,data.frame) S3method(ard_tabulate,data.frame) S3method(ard_tabulate_value,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(alias_as_fmt_fun) 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(apply_fmt_fun) export(ard_attributes) export(ard_categorical) export(ard_complex) export(ard_continuous) export(ard_dichotomous) export(ard_formals) export(ard_hierarchical) export(ard_hierarchical_count) export(ard_identity) export(ard_missing) export(ard_mvsummary) export(ard_pairwise) export(ard_stack) export(ard_stack_hierarchical) export(ard_stack_hierarchical_count) export(ard_strata) export(ard_summary) export(ard_tabulate) export(ard_tabulate_value) export(ard_total_n) export(as_card) export(as_cards_fn) export(as_nested_list) export(bind_ard) export(captured_condition_as_error) export(captured_condition_as_message) export(cards_select) export(check_ard_structure) export(check_list_elements) export(compute_formula_selector) export(contains) export(continuous_summary_fns) export(default_stat_labels) export(ends_with) export(eval_capture_conditions) export(everything) export(fill_formula_selectors) export(filter_ard_hierarchical) export(get_ard_statistics) export(get_cards_fn_stat_names) export(is_cards_fn) export(label_round) export(last_col) export(matches) export(maximum_variable_value) export(mock_attributes) export(mock_categorical) export(mock_continuous) export(mock_dichotomous) export(mock_missing) export(mock_total_n) export(nest_for_ard) export(num_range) export(one_of) export(print_ard_conditions) export(process_formula_selectors) export(process_selectors) export(rename_ard_columns) export(rename_ard_groups_reverse) export(rename_ard_groups_shift) export(replace_null_statistic) export(round5) export(shuffle_ard) export(sort_ard_hierarchical) export(starts_with) export(tidy_ard_column_order) export(tidy_ard_row_order) export(tidy_as_ard) export(unlist_ard_columns) export(update_ard_fmt_fn) export(update_ard_fmt_fun) 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) importFrom(lifecycle,deprecated) cards/NEWS.md0000644000176200001440000003403315113472334012452 0ustar liggesusers# cards 0.7.1 * Updated `ard_stack_hierarchical()` so that the `denominator` dataset only contains the `id` and `by` variables. (#482) * Fixed bug in `sort_ard_hierarchical()` causing an error when sorting hierarchical ARDs with more than 2 `by` variables. (#516) * `shuffle_ard()` has been deprecated and will be maintained in {tfrmt} going forward. (#509) # cards 0.7.0 ## New Features and Functions * Updated `sort_ard_hierarchical()` to allow for different sorting methods at each hierarchy variable level. (#487) * Updated `sort_ard_hierarchical()` and `filter_ard_hierarchical()` to always keep attribute and total N rows at the bottom of the ARD. * Added argument `var` to `filter_ard_hierarchical()` to allow filtering by any hierarchy variable. (#467) * Added flexibility to filter by `by` variable level-specific values when using `filter_ard_hierarchical()` to allow for filtering of hierarchical ARDs by difference in two rates. (#438) * The `ard_strata()` function has been updated to include the strata columns in the nested data frames. (#461) * Similar to `ard_stack_hierarchical()`, `ard_stack()` contains an `args` attribute to retain information about input arguments. * Added an article illustrating how to summarize long data structures. (#356) * Added `ard_stack(.by_stat)` and `ard_stack_hierarchical(by_stat)` arguments that, when `TRUE` (the default), includes a univariate ARD tabulation of the `by` variable in the returned ARD. (#335) * `shuffle_ard()` passes down the `args` attribute of the input `card` object when present. (#484, @dragosmg) * `shuffle_ard()` fills overall or group statistics with `"Overall "` or `"Any "`. (#337, @dragosmg) * `shuffle_ard()` messages if `"Overall "` is accidentally present in the data and creates a unique label. (#465, @dragosmg) * Add `ADLB` data set. (#450) ## Lifecycle Changes * The following functions have been renamed. The old functions still work in the package, and will be soft deprecated in the next release. (#470) - `ard_continuous()` to `ard_summary()` - `ard_complex()` to `ard_mvsummary()` - `ard_categorical()` to `ard_tabulate()` - `ard_dichotomous()` to `ard_tabulate_value()` * `shuffle` and `.shuffle` arguments (for `ard_stack_hierarchical()` and `ard_stack()`) are deprecated and users encouraged to call `shuffle_ard()` directly. (#475, @dragosmg) # cards 0.6.1 ## New Features and Functions * Added new function `ard_identity()` for saving pre-calculated statistics in an ARD format. (#379) ## Lifecycle Changes * Updating any `fmt_fn` references to `fmt_fun` for consistency. * Any function with an argument `cards::foo(fmt_fn)` has been updated to `cards::foo(fmt_fun)`. The old syntax will continue to function, but with a deprecation warning to users. * The following function names have been updated: `alias_as_fmt_fun()`, `apply_fmt_fun()`, and `update_ard_fmt_fun()`. The former function names are still exported from the package, and users will see a deprecation note when they are used. * Importantly, the ARD column named `"fmt_fn"` has been updated to `"fmt_fun"`. This change cannot be formally deprecated. For users who were accessing the ARD object directly to modify this column instead of using functions like `update_ard_fmt_fun()`, this will be a breaking change. ## Bug Fixes * Fix bug in `sort_ard_hierarchical()` when hierarchical ARD has `overall=TRUE`. (#431) * Fix bug in `ard_stack_hierarchical()` when `id` values are present in multiple levels of the `by` variables. (#442) * Fix bug in `shuffle_ard()` where error is thrown if input contains hierarchical results. (#447) # cards 0.6.0 ## New Features and Functions * Added functions `sort_ard_hierarchical()` and `filter_ard_hierarchical()` to sort & filter ARDs created using `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()`. (#301) * Updated `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()` to automatically sort results alphanumerically. (#423) * Added new function `unlist_ard_columns()`. (#391) * Updated function `rename_ard_columns()`. (#380) * The function no longer coerces values to character. * The `fill` argument has been added to specify a value to fill in the new column when there are no levels associated with the variables (e.g. continuous summaries). * The `unlist` argument has been deprecated in favor of using the new `unlist_ard_columns()` function. * The function no longer accepts generic data frames: inputs must be a data frame of class `card`. * Added function `ard_formals()` to assist in adding a function's formals, that is, the arguments with their default values, along with user-passed arguments into an ARD structure. ## Bug Fixes * Fixed sorting order of logical variables in `nest_for_ard()`. (#411) ## Lifecycle Changes * The `shuffle_ard()` function no longer outputs a `'label'` column, and instead retains the original `'variable'` level from the cards object. It also no longer trims rows with non-numeric stats values. (#416) # cards 0.5.1 * Small update to account for a change in R-devel. # cards 0.5.0 ## New Features and Functions * Added functions `rename_ard_groups_shift()` and `rename_ard_groups_reverse()` for renaming the grouping variables in the ARD. (#344) * Added an option to specify the default rounding in the package: `cards.round_type`. See `?cards.options` for details. (#384) * Added the `print_ard_conditions(condition_type)` argument, which allows users to select to return conditions as messages (the default), or have warnings returned as warnings and errors as errors. (#386) * Added the `all_ard_group_n(types)` argument to allow separate selection of `groupX` and `groupX_level` columns. * Added the `tidy_ard_column_order(group_order)` argument that allows users to specify whether the grouping variables are listed in ascending order (the default) or descending order. The output of `ard_strata()` now calls `tidy_ard_column_order(group_order="descending")`. ## Other Updates * A new article has been added detailing how to create new ARD functions. * Results are now sorted in a consistent manner, by descending groups and strata. (#342, #326) ## Lifecycle Updates * Function `label_cards()` has been renamed to `label_round()`, which more clearly communicates that is returns a rounding function. # cards 0.4.0 ## New Features and Functions * Added functions `as_cards_fn()`, `is_cards_fn()`, and `get_cards_fn_stat_names()`. These functions assist is creating functions with attributes enumerating the expected results. * Updated `ard_continuous()` and `ard_complex()` to return full ARDs when functions passed are created with `as_cards_fn()`: instead of a single row output, we get a long ARD with rows for each of the expected statistic names. (#316) * Added function `ard_pairwise()` to ease the calculations of pairwise analyses. (#359) ## Other Updates * Improved messaging in `print_ard_conditions()` when the calling function is namespaced. (#348) * Updated print method for `'card'` objects so extraneous columns are never printed by default. ## Lifecycle Changes * No longer exporting functions `check_pkg_installed()`, `is_pkg_installed()`, `get_min_version_required()`, `get_pkg_dependencies()`. These functions are now internal-only. (#330) ## Bug Fixes * The `tidy_ard_column_order()` now correctly orders grouping columns when there are 10+ groups. This also corrects an issue in the hierarchical functions where the ordering of the variables matters. (#352) # cards 0.3.0 ## New Features & Updates * Added functions `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()` that ease the creation of ARDs for multiple nested or hierarchical structures. (#314) * Added functions `update_ard_fmt_fn()` and `update_ard_stat_label()` to update an ARD's formatting function and statistic label, respectively. (#253) * Added `rename_ard_columns(unlist)` argument, which unlists specified columns in the ARD data frame. (#313) * Added `ard_strata()` function to ease the task of calculating ARDs stratified by one or more other categorical variables. (#273) * Added functions `mock_continuous()`, `mock_categorical()`, `mock_dichotomous()`, `mock_missing()`, `mock_attributes()` to build ARDs in the absence of a data frame. Where applicable, the formatting functions are set to return `'xx'` or `'xx.x'` to aid in the construction of mock tables or table shells. (#256) * Added functions for printing results from `eval_capture_conditions()`. Captured conditions can be printed as either errors or messages with `captured_condition_as_error()` and `captured_condition_as_message()`, respectively. (#282) ## Other Updates * The `ard_hierarchical_count()` function has been updated to match the behavior of `ard_hierarchical()` and results are now only returned for the last column listed in the `variables` arguments, rather than recursively counting all variables. * Add columns `'fmt_fn'`, `'warning'`, and `'errors'` to `ard_attributes()` output. (#327) * Add checks for factors with no levels, or any levels that are `NA` into `ard_*` functions (#255) * Any rows with `NA` or `NaN` values in the `.by` columns specified in `ard_stack()` are now removed from all calculations. (#320) # cards 0.2.2 ## New Features & Updates * Converted `ard_total_n()` to an S3 generic and added method `ard_total_n.data.frame()`. * Added the `bind_ard(.quiet)` argument to suppress messaging. (#299) * Improved ability of `shuffle_ard()` to populate missing group values where possible. (#306) * Added `apply_fmt_fn(replace)` argument. Use `replace=FALSE` to retain any previously formatted statistics in the `stat_fmt` column. (#285) * Added `bind_ard(.distinct)` argument, which can remove non-distinct rows from the ARD across grouping variables, primary variables, context, statistic name and value. (#286) ## Bug Fixes * Fix in `print_ard_conditions()` when the variables were factors, which did not render properly in `cli::cli_format()`. * Bug fix in `print_ard_conditions()` and we can now print condition messages that contain curly brace pairs. (#309) # cards 0.2.1 * Update in `ard_categorical()` to use `base::order()` instead of `dplyr::arrange()`, so the ordering of variables match the results from `base::table()` in some edge cases where sorted order was inconsistent. * Update in `ard_categorical()` to run `base::table()` output checks against coerced character columns. Previously, we relied on R to perform checks on the type it decided to check against (e.g. when it coerces to a common type). While the initial strategy worked in cases of Base R classes, there were some bespoke classes, such as times from {hms}, where Base R does not coerce as we expected. * Adding selectors `all_group_n()` and `all_missing_columns()`. (#272, #274) * Added new function `add_calculated_row()` for adding a new row of calculated statistic(s) that are a function of the other statistics in the ARD. (#275) # cards 0.2.0 ## New Features & Updates * Converting `ard_*()` functions and other helpers to S3 generics to make them extendable. (#227) * Added helper `rename_ard_columns()` for renaming/coalescing group/variable columns. (#213). * Added new function `ard_total_n()` for calculating the total N in a data frame. (#236) * Added the `nest_for_ard(include_data)` argument to either include or exclude the subsetted data frames in a list-column in the returned tibble. * Added `check_ard_structure(column_order, method)` arguments to the function to check for column ordering and whether result contains a `stat_name='method'` row. * Added the optional `ard_hierarchical(id)` argument. When provided we check for duplicates across the column(s) supplied here. If duplicates are found, the user is warned that the percentages and denominators are not correct. (#214) * Improved messaging in `check_pkg_installed()` that incorporates the calling function name in the case of an error. (#205) * Updated `is_pkg_installed()` and `check_pkg_installed()` to allow checks for more than package at a time. The `get_min_version_required()` function has also been updated to return a tibble instead of a list with attributes. (#201) * Styling from the {cli} package are now removed from errors and warnings when they are captured with `eval_capture_conditions()`. Styling is removed with `cli::ansi_strip()`. (#129) ## Bug Fixes * Bug fix in `ard_stack()` when calls to functions were namespaced. (#242) * The `print_ard_conditions()` function has been updated to no longer error out if the ARD object does not have `"error"` or `"warning"` columns. (#240) * Bug fix in `shuffle_ard()` where factors were coerced to integers instead of their labels. (#232) ## Lifecycle Changes * Corrected order that `ard_categorical` (strata) columns would appear in the ARD results. Previously, they appeared in the order they appeared in the original data, and now they are sorted properly. (#221) * The API for `ard_continuous(statistic)` and `ard_missing(statistic)` arguments has been updated. Previously, the RHS of these argument's passed lists would be either `continuous_summary_fns()` and `missing_summary_fns()`. Now these arguments accept simple character vectors of the statistic names. For example, `ard_categorical(statistic = everything() ~ c("n", "p", "N"))` and `ard_missing(statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"))`. (#223) * Updated `ard_stack()` to return `n`, `p`, and `N` for the `by` variable when specified. Previously, it only returned `N` which is the same for all levels of the by variable. (#219) * Bug fix where `ard_stack(by)` argument was not passed to `ard_missing()` when `ard_stack(.missing=TRUE)`. (#244) * The `ard_stack(by)` argument has been renamed to `".by"` and its location moved to after the dots inputs, e.g. `ard_stack(..., .by)`. (#243) * A messaging overhaul to utilize the scripts in `https://github.com/ddsjoberg/standalone/blob/main/R/standalone-cli_call_env.R`. This allows clear error messaging across functions and packages. (#42) - The `print_ard_conditions(call)`, `check_list_elements(env)`, `cards_select(.call)` arguments have been removed. # cards 0.1.0 * Initial release. cards/inst/0000755000176200001440000000000015113466401012324 5ustar liggesuserscards/inst/WORDLIST0000644000176200001440000000056115113466401013520 0ustar liggesusersADAE ADCM ADLB ADaM AE AEs ARD ARD's ARDs CDISC CMD Codecov DIARRHOEA GlaxoSmithKline Hoffmann IEC Lifecycle ORCID Pre Rua SAS's SDTM Unlist Xanomeline ata cardx cli de env esult ets funder hms httr jsonlite mis nalysis namespaced pre quosures reusability sd tfrmt tibble tibbles tidyselect tidyselector tidyselectors univariable unlist unlists unnested unnests wilcox cards/README.md0000644000176200001440000000713115113471221012624 0ustar liggesusers # cards cards website [![CRAN status](https://www.r-pkg.org/badges/version/cards)](https://CRAN.R-project.org/package=cards) [![Codecov test coverage](https://codecov.io/gh/insightsengineering/cards/graph/badge.svg)](https://app.codecov.io/gh/insightsengineering/cards) [![Downloads](https://cranlogs.r-pkg.org/badges/cards)](https://cran.r-project.org/package=cards) [![R-CMD-check](https://github.com/insightsengineering/cards/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/insightsengineering/cards/actions/workflows/R-CMD-check.yaml) The [CDISC Analysis Results Standard](https://www.cdisc.org/standards/foundational/analysis-results-standard) aims to facilitate automation, reproducibility, reusability, and traceability of analysis results data (ARD). The {cards} package creates these **C**DISC **A**nalysis **R**esult **D**ata **S**ets. Use cases: 1. Quality Control (QC) of existing tables and figures. 2. Pre-calculate statistics to be summarized in tables and figures. 3. Medical writers may easily access statistics and place in reports without copying and pasting from reports. 4. Provides a consistent format for results and lends results to be combined across studies for re-use and re-analysis. ## Installation Install cards from CRAN with: ``` r install.packages("cards") ``` You can install the development version of cards from [GitHub](https://github.com/) with: ``` r # install.packages("devtools") devtools::install_github("insightsengineering/cards") ``` ## Extensions [cardx website](https://insightsengineering.github.io/cardx/) The {cards} package exports three types of functions: 1. Functions to create basic ARD objects. 2. Utilities to create new ARD objects. 3. Functions to work with existing ARD objects. The [{cardx}](https://github.com/insightsengineering/cardx/) R package is an extension to {cards} that uses the utilities from {cards} and exports functions for creating additional ARD objects––including functions to summarize t-tests, Wilcoxon Rank-Sum tests, regression models, and more. ## Getting Started Review the [Getting Started](https://insightsengineering.github.io/cards//main/articles/getting-started.html) page for examples using ARDs to calculate statistics to later include in tables. ``` r library(cards) ard_summary(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_fun, warning, error ``` cards/man/0000755000176200001440000000000015113474632012127 5ustar liggesuserscards/man/selectors.Rd0000644000176200001440000000265415050667010014422 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/selectors.R \name{selectors} \alias{selectors} \alias{all_ard_groups} \alias{all_ard_variables} \alias{all_ard_group_n} \alias{all_missing_columns} \title{ARD Selectors} \usage{ all_ard_groups(types = c("names", "levels")) all_ard_variables(types = c("names", "levels")) all_ard_group_n(n, types = c("names", "levels")) all_missing_columns() } \arguments{ \item{types}{(\code{character})\cr type(s) of columns to select. \code{"names"} selects the columns variable name columns, and \code{"levels"} selects the level columns. Default is \code{c("names", "levels")}.} \item{n}{(\code{integer})\cr integer(s) indicating which grouping columns to select.} } \value{ tidyselect output } \description{ These selection helpers match variables according to a given pattern. \itemize{ \item \code{all_ard_groups()}: Function selects grouping columns, e.g. columns named \code{"group##"} or \code{"group##_level"}. \item \code{all_ard_variables()}: Function selects variables columns, e.g. columns named \code{"variable"} or \code{"variable_level"}. \item \code{all_ard_group_n()}: Function selects \code{n} grouping columns. \item \code{all_missing_columns()}: Function selects columns that are all \code{NA} or empty. } } \examples{ ard <- ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") ard |> dplyr::select(all_ard_groups()) ard |> dplyr::select(all_ard_variables()) } cards/man/ard_pairwise.Rd0000644000176200001440000000235215050667010015063 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_mvsummary( 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.Rd0000644000176200001440000000356715050667010016260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_ard_columns.R \name{rename_ard_columns} \alias{rename_ard_columns} \title{Rename ARD Variables} \usage{ rename_ard_columns( x, columns = c(all_ard_groups("names"), all_ard_variables("names")), fill = "{colname}", unlist = NULL ) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to rename, e.g. selecting columns \code{c('group1', 'group2', 'variable')} will rename \code{'group1_level'} to the name of the variable found in \code{'group1'}. When, for example, the \code{'group1_level'} does not exist, the values of the new column are filled with the values in the \code{fill} argument. Default is \code{c(all_ard_groups("names"), all_ard_variables("names"))}.} \item{fill}{(scalar/glue)\cr a scalar to fill column values when the variable does not have levels. If a character is passed, then it is processed with \code{glue::glue()} where the \code{colname} element is available to inject into the string, e.g. \code{'Overall {colname}'} may resolve to \code{'Overall AGE'} for an AGE column. Default is \code{'{colname}'}.} \item{unlist}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ data frame } \description{ Rename the grouping and variable columns to their original column names. } \examples{ # Example 1 ---------------------------------- ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> apply_fmt_fun() |> rename_ard_columns() |> unlist_ard_columns() # Example 2 ---------------------------------- ADSL |> ard_summary(by = ARM, variables = AGE) |> apply_fmt_fun() |> rename_ard_columns(fill = "Overall {colname}") |> unlist_ard_columns() } cards/man/dot-check_for_missing_combos_in_denom.Rd0000644000176200001440000000200715050667010022061 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate.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.Rd0000644000176200001440000000511415027040570014710 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_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr results are tabulated by \strong{all combinations} of the columns specified.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) mean(x)))}. The value assigned to each variable must also be a named list, where the names are used to reference a function and the element is the function object. Typically, this function will return a scalar statistic, but a function that returns a named list of results is also acceptable, e.g. \code{list(conf.low = -1, conf.high = 1)}. However, when errors occur, the messaging will be less clear in this setting.} \item{fmt_fun}{(\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")}.} \item{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \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/dot-cli_groups_and_variable.Rd0000644000176200001440000000152015050667010020027 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_summary( 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.Rd0000644000176200001440000000110115003556603014672 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.Rd0000644000176200001440000000242115050667010015401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_ard_order.R \name{tidy_ard_order} \alias{tidy_ard_order} \alias{tidy_ard_column_order} \alias{tidy_ard_row_order} \title{Standard Order of ARD} \usage{ tidy_ard_column_order(x, group_order = c("ascending", "descending")) tidy_ard_row_order(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{group_order}{(\code{string})\cr specifies the ordering of the grouping variables. Must be one of \code{c("ascending", "descending")}. Default is \code{"ascending"}, where grouping variables begin with \code{"group1"} variables, followed by \code{"group2"} variables, etc.} } \value{ an ARD data frame of class 'card' } \description{ ARD functions for relocating columns and rows to the standard order. \itemize{ \item \code{tidy_ard_column_order()} relocates columns of the ARD to the standard order. \item \code{tidy_ard_row_order()} orders rows of ARD according to groups and strata (group 1, then group2, etc), while retaining the column order of the input ARD. } } \examples{ # order columns ard <- dplyr::bind_rows( ard_summary(mtcars, variables = "mpg"), ard_summary(mtcars, variables = "mpg", by = "cyl") ) tidy_ard_column_order(ard) |> tidy_ard_row_order() } cards/man/print.card.Rd0000644000176200001440000000251615050667010014460 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_fun'} \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_tabulate(ADSL, variables = AGEGR1) |> print() } \keyword{internal} cards/man/dot-check_dichotomous_value.Rd0000644000176200001440000000115415050667010020063 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate_value.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_tabulate_value(value)}. } \examples{ cards:::.check_dichotomous_value(mtcars, list(cyl = 4)) } \keyword{internal} cards/man/ard_tabulate.Rd0000644000176200001440000001167515050667010015051 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate.R \name{ard_tabulate} \alias{ard_tabulate} \alias{ard_tabulate.data.frame} \title{Tabulate ARD} \usage{ ard_tabulate(data, ...) \method{ard_tabulate}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ c("n", "p", "N"), denominator = "column", fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{fmt_fun}{(\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{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \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_tabulate()} 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 calculation for the proportion is \code{p = n/N}. However, it is sometimes necessary to provide a different \code{"N"} to use as the denominator in this calculation. For example, in a calculation of the rates of various observed adverse events, you may need to update the denominator to the number of enrolled subjects. In such cases, use the \code{denominator} argument to specify a new definition of \code{"N"}, and subsequently \code{"p"}. The argument expects one of the following inputs: \itemize{ \item a string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \itemize{ \item \code{"column"}, the default, returns percentages where the sum is equal to one within the variable after the data frame has been subset with \code{by}/\code{strata}. \item \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. This is well-defined for a single \code{by} or \code{strata} variable, and care must be taken when there are more to ensure the the results are as you expect. \item \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. } \item a data frame. Any columns in the data frame that overlap with the \code{by}/\code{strata} columns will be used to calculate the new \code{"N"}. \item an integer. This single integer will be used as the new \code{"N"} \item a structured data frame. The data frame will include columns from \code{by}/\code{strata}. The last column must be named \code{"...ard_N..."}. The integers in this column will be used as the updated \code{"N"} in the calculations. } When the \code{p} statistic is returned, the proportion is returned---bounded by \verb{[0, 1]}. The default function to format the statistic scales the proportion by 100 and the percentage is returned which matches the default statistic label of \code{'\%'}. To get the formatted values, pass the ARD to \code{apply_fmt_fun()}. } \examples{ ard_tabulate(ADSL, by = "ARM", variables = "AGEGR1") ADSL |> dplyr::group_by(ARM) |> ard_tabulate( variables = "AGEGR1", statistic = everything() ~ "n" ) } cards/man/label_round.Rd0000644000176200001440000000143315027040570014677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fun.R \name{label_round} \alias{label_round} \title{Generate Formatting Function} \usage{ label_round(digits = 1, scale = 1, width = NULL) } \arguments{ \item{digits}{(\code{integer})\cr a non-negative integer specifying the number of decimal places round statistics to} \item{scale}{(\code{numeric})\cr a scalar real number. Before rounding, the input will be scaled by this quantity} \item{width}{(\code{integer})\cr a non-negative integer specifying the minimum width of the returned formatted values} } \value{ a function } \description{ Returns a function with the requested rounding and scaling schema. } \examples{ label_round(2)(pi) label_round(1, scale = 100)(pi) label_round(2, width = 5)(pi) } cards/man/print_ard_conditions.Rd0000644000176200001440000000171115050667010016623 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_ard_conditions.R \name{print_ard_conditions} \alias{print_ard_conditions} \title{Print ARD Condition Messages} \usage{ print_ard_conditions(x, condition_type = c("inform", "identity")) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{condition_type}{(\code{string})\cr indicates how warnings and errors are returned. Default is \code{"inform"} where all are returned as messages. When \code{"identity"}, errors are returned as errors and warnings as warnings.} } \value{ returns invisible if check is successful, throws all condition messages if not. } \description{ Function parses the errors and warnings observed while calculating the statistics requested in the ARD and prints them to the console as messages. } \examples{ # passing a character variable for numeric summary ard_summary(ADSL, variables = AGEGR1) |> print_ard_conditions() } cards/man/maximum_variable_value.Rd0000644000176200001440000000116015050667010017124 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/maximum_variable_value.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. } \examples{ ADSL[c("AGEGR1", "BMIBLGR1")] |> maximum_variable_value() } cards/man/ard_strata.Rd0000644000176200001440000000407615051156120014537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_strata.R \name{ard_strata} \alias{ard_strata} \title{Stratified ARD} \usage{ ard_strata(.data, .by = NULL, .strata = NULL, .f, ...) } \arguments{ \item{.data}{(\code{data.frame})\cr a data frame} \item{.by, .strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for calculation. Arguments are similar, but with an important distinction: \code{.by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{.strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. These argument \emph{should not} include any columns that appear in the \code{.f} argument.} \item{.f}{(\code{function}, \code{formula})\cr a function or a formula that can be coerced to a function with \code{rlang::as_function()} (similar to \code{purrr::map(.f)})} \item{...}{Additional arguments passed on to the \code{.f} function.} } \value{ an ARD data frame of class 'card' } \description{ General function for calculating ARD results within subgroups. While the examples below show use with other functions from the cards package, this function would primarily be used with the statistical functions in the cardx functions. } \examples{ # Example 1 ---------------------------------- ard_strata( ADSL, .by = ARM, .f = ~ ard_summary(.x, variables = AGE) ) # Example 2 ---------------------------------- df <- data.frame( USUBJID = 1:12, PARAMCD = rep(c("PARAM1", "PARAM2"), each = 6), AVALC = c( "Yes", "No", "Yes", # PARAM1 "Yes", "Yes", "No", # PARAM1 "Low", "Medium", "High", # PARAM2 "Low", "Low", "Medium" # PARAM2 ) ) ard_strata( df, .strata = PARAMCD, .f = \(.x) { lvls <- switch(.x[["PARAMCD"]][1], "PARAM1" = c("Yes", "No"), "PARAM2" = c("Zero", "Low", "Medium", "High") ) .x |> dplyr::mutate(AVALC = factor(AVALC, levels = lvls)) |> ard_tabulate(variables = AVALC) } ) } cards/man/ard_stack.Rd0000644000176200001440000000466215113466401014354 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, .by_stats = TRUE ) } \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}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} support for \code{.shuffle = TRUE} has been removed.} \item{.by_stats}{(\code{logical})\cr logical indicating whether to include overall stats of the \code{by} variables in the returned ARD.} } \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_tabulate(variables = "AGEGR1"), ard_summary(variables = "AGE"), .by = "ARM", .overall = TRUE, .attributes = TRUE ) ard_stack( data = ADSL, ard_tabulate(variables = "AGEGR1"), ard_summary(variables = "AGE"), .by = "ARM" ) } cards/man/dot-create_list_for_attributes.Rd0000644000176200001440000000132215050667010020604 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") cards:::.create_list_for_attributes(ard, c("group1", "group1_level"), 1) } \keyword{internal} cards/man/ard_identity.Rd0000644000176200001440000000175515004315232015072 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_identity.R \name{ard_identity} \alias{ard_identity} \title{ARD Identity} \usage{ ard_identity(x, variable, context = "identity") } \arguments{ \item{x}{(named \code{list}/\code{data.frame})\cr named list of results or a data frame. Names are the statistic names, and the values are the statistic values. These comprise the \code{"stat_name"} and \code{"stat"} columns in the returned ARD.} \item{variable}{(\code{string})\cr string of a variable name that is assigned to the \code{"variable"} column in the ARD.} \item{context}{(\code{string})\cr string to be added to the \code{"context"} column. Default is \code{"identity"}.} } \value{ a ARD } \description{ Function ingests pre-calculated statistics and returns the identical results, but in an ARD format. } \examples{ t.test(formula = AGE ~ 1, data = ADSL)[c("statistic", "parameter", "p.value")] |> ard_identity(variable = "AGE", context = "onesample_t_test") } cards/man/alias_as_fmt_fun.Rd0000644000176200001440000000231515027040570015703 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fun.R \name{alias_as_fmt_fun} \alias{alias_as_fmt_fun} \title{Convert Alias to Function} \usage{ alias_as_fmt_fun(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_fun(1) alias_as_fmt_fun("xx.x") } cards/man/summary_functions.Rd0000644000176200001440000000252715050667010016203 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_summary( ADSL, variables = "AGE", statistic = ~ continuous_summary_fns(c("N", "median")) ) } cards/man/rename_ard_groups.Rd0000644000176200001440000000163015050667010016104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_ard_groups.R \name{rename_ard_groups} \alias{rename_ard_groups} \alias{rename_ard_groups_shift} \alias{rename_ard_groups_reverse} \title{Rename ARD Group Columns} \usage{ rename_ard_groups_shift(x, shift = -1) rename_ard_groups_reverse(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'.} \item{shift}{(\code{integer})\cr an integer specifying how many values to shift the group IDs, e.g. \code{shift=-1} renames \code{group2} to \code{group1}.} } \value{ an ARD data frame of class 'card' } \description{ Functions for renaming group columns names in ARDs. } \examples{ ard <- ard_summary(ADSL, by = c(SEX, ARM), variables = AGE) # Example 1 ---------------------------------- rename_ard_groups_shift(ard, shift = -1) # Example 2 ---------------------------------- rename_ard_groups_reverse(ard) } cards/man/sort_ard_hierarchical.Rd0000644000176200001440000000610315066623216016732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sort_ard_hierarchical.R \name{sort_ard_hierarchical} \alias{sort_ard_hierarchical} \title{Sort Stacked Hierarchical ARDs} \usage{ sort_ard_hierarchical(x, sort = everything() ~ "descending") } \arguments{ \item{x}{(\code{card})\cr a stacked hierarchical ARD of class \code{'card'} created using \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} or \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}.} \item{sort}{(\code{\link[=syntax]{formula-list-selector}}, \code{string})\cr a named list, a list of formulas, a single formula where the list element is a named list of functions (or the RHS of a formula), or a single string specifying the types of sorting to perform at each hierarchy variable level. If the sort method for any variable is not specified then the method will default to \code{"descending"}. If a single unnamed string is supplied it is applied to all variables. For each variable, the value specified must be one of: \itemize{ \item \code{"alphanumeric"} - at the specified hierarchy level of the ARD, groups are ordered alphanumerically (i.e. A to Z) by \code{variable_level} text. \item \code{"descending"} - within each variable group of the ARD at the specified hierarchy level, count sums are calculated for each group and groups are sorted in descending order by sum. When \code{sort} is \code{"descending"} for a given variable and \code{n} is included in \code{statistic} for the variable then \code{n} is used to calculate variable group sums, otherwise \code{p} is used. If neither \code{n} nor \code{p} are present in \code{x} for the variable, an error will occur. } Defaults to \code{everything() ~ "descending"}.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr This function is used to sort stacked hierarchical ARDs. For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the combination of all their variable levels, but excluding any \code{by} variables. } \note{ If overall data is present in \code{x} (i.e. the ARD was created with \code{ard_stack_hierarchical(overall=TRUE)}), the overall data will be sorted last within each variable group (i.e. after any other rows with the same combination of variable levels). } \examples{ \dontshow{if ((identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true"))) withAutoprint(\{ # examplesIf} ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, id = USUBJID ) |> sort_ard_hierarchical(AESOC ~ "alphanumeric") ard_stack_hierarchical_count( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL ) |> sort_ard_hierarchical(sort = list(AESOC ~ "alphanumeric", AEDECOD ~ "descending")) \dontshow{\}) # examplesIf} } \seealso{ \code{\link[=filter_ard_hierarchical]{filter_ard_hierarchical()}} } cards/man/as_card.Rd0000644000176200001440000000070615003556603014012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_card.R \name{as_card} \alias{as_card} \title{Data Frame as ARD} \usage{ as_card(x) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} } \value{ an ARD data frame of class 'card' } \description{ Convert data frames to ARDs of class 'card'. } \examples{ data.frame( stat_name = c("N", "mean"), stat_label = c("N", "Mean"), stat = c(10, 0.5) ) |> as_card() } cards/man/dot-table_as_df.Rd0000644000176200001440000000233215050667010015417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate.R \name{.table_as_df} \alias{.table_as_df} \title{Results from \code{table()} as Data Frame} \usage{ .table_as_df( data, variable = NULL, by = NULL, strata = NULL, useNA = c("no", "always"), count_column = "...ard_n..." ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variable}{(\code{string})\cr a string indicating a column in data} \item{by}{(\code{character})\cr a character vector indicating columns in data} \item{strata}{(\code{character})\cr a character vector indicating columns in data} \item{useNA}{(\code{string})\cr one of \code{"no"} and \code{"always"}. Will be passed to \code{table(useNA)}.} } \value{ data frame } \description{ Takes the results from \code{\link[=table]{table()}} and returns them as a data frame. After the \code{\link[=table]{table()}} results are made into a data frame, all the variables are made into character columns, and the function also restores the column types to their original classes. For \code{strata} columns, only observed combinations are returned. } \examples{ cards:::.table_as_df(ADSL, variable = "ARM", by = "AGEGR1", strata = NULL) } \keyword{internal} cards/man/cards.options.Rd0000644000176200001440000000231115027040570015173 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{cards.options} \alias{cards.options} \title{Options in \{cards\}} \description{ See below for options available in the \{cards\} package } \section{cards.round_type}{ There are two types of rounding types in the \{cards\} package that are implemented in \code{label_round()}, \code{alias_as_fmt_fun()}, and \code{apply_fmt_fun()} functions. \itemize{ \item \code{'round-half-up'} (\emph{default}): rounding method where values exactly halfway between two numbers are rounded to the larger in magnitude number. Rounding is implemented via \code{\link[=round5]{round5()}}. \item \code{'round-to-even'}: base R's default IEC 60559 rounding standard. See \code{\link[=round]{round()}} for details. } To change the default rounding to use IEC 60559, this option must be set \strong{both} when the ARDs are created and when \code{apply_fmt_fun()} is run. This ensures that any \emph{default} formatting functions created with \code{label_round()} utilize the specified rounding method and the method is used what aliases are converted into functions (which occurs in \code{apply_fmt_fun()} when it calls \code{alias_as_fmt_fun()}). } cards/man/dot-check_var_nms.Rd0000644000176200001440000000120015031355363015773 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.Rd0000644000176200001440000000422215050667010014520 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_fun} \alias{update_ard_stat_label} \title{Update ARDs} \usage{ update_ard_fmt_fun( x, variables = everything(), stat_names, fmt_fun, filter = TRUE, fmt_fn = deprecated() ) 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_fun}{(\code{function})\cr a function or alias recognized by \code{alias_as_fmt_fun()}.} \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{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} \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_summary(ADSL, variables = AGE) |> update_ard_fmt_fun(stat_names = c("mean", "sd"), fmt_fun = 8L) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> apply_fmt_fun() # same as above, but only apply update to the Placebo level ard_summary( ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean")) ) |> update_ard_fmt_fun(stat_names = "mean", fmt_fun = 8L, filter = group1_level == "Placebo") |> apply_fmt_fun() } cards/man/process_selectors.Rd0000644000176200001440000001272115003556603016157 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/process_selectors.R \name{process_selectors} \alias{process_selectors} \alias{process_formula_selectors} \alias{fill_formula_selectors} \alias{process_selectors.data.frame} \alias{process_formula_selectors.data.frame} \alias{fill_formula_selectors.data.frame} \alias{compute_formula_selector} \alias{check_list_elements} \alias{cards_select} \title{Process tidyselectors} \usage{ process_selectors(data, ...) process_formula_selectors(data, ...) fill_formula_selectors(data, ...) \method{process_selectors}{data.frame}(data, ..., env = caller_env()) \method{process_formula_selectors}{data.frame}( data, ..., env = caller_env(), include_env = FALSE, allow_empty = TRUE ) \method{fill_formula_selectors}{data.frame}(data, ..., env = caller_env()) compute_formula_selector( data, x, arg_name = caller_arg(x), env = caller_env(), strict = TRUE, include_env = FALSE, allow_empty = TRUE ) check_list_elements( x, predicate, error_msg = NULL, arg_name = rlang::caller_arg(x) ) cards_select(expr, data, ..., arg_name = NULL) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr named arguments where the value of the argument is processed with tidyselect. \itemize{ \item \code{process_selectors()}: the values are tidyselect-compatible selectors \item \code{process_formula_selectors()}: the values are named lists, list of formulas a combination of both, or a single formula. Users may pass \code{~value} as a shortcut for \code{everything() ~ value}. \item \code{check_list_elements()}: named arguments where the name matches an existing list in the \code{env} environment, and the value is a predicate function to test each element of the list, e.g. each element must be a string or a function. }} \item{env}{(\code{environment})\cr env to save the results to. Default is the calling environment.} \item{include_env}{(\code{logical})\cr whether to include the environment from the formula object in the returned named list. Default is \code{FALSE}} \item{allow_empty}{(\code{logical})\cr Logical indicating whether empty result is acceptable while process formula-list selectors. Default is \code{TRUE}.} \item{x}{\itemize{ \item \code{compute_formula_selector()}: (\code{\link[=syntax]{formula-list-selector}})\cr a named list, list of formulas, or a single formula that will be converted to a named list. \item \code{check_list_elements()}: (named \code{list})\cr a named list }} \item{arg_name}{(\code{string})\cr the name of the argument being processed. Used in error messaging. Default is \code{caller_arg(x)}.} \item{strict}{(\code{logical})\cr whether to throw an error if a variable doesn't exist in the reference data (passed to \code{\link[tidyselect:eval_select]{tidyselect::eval_select()}})} \item{predicate}{(\code{function})\cr a predicate function that returns \code{TRUE} or \code{FALSE}} \item{error_msg}{(\code{character})\cr a character vector that will be used in error messaging when mis-specified arguments are passed. Elements \code{"{arg_name}"} and \code{"{variable}"} are available using glue syntax for messaging.} \item{expr}{(\code{expression})\cr Defused R code describing a selection according to the tidyselect syntax.} } \value{ \code{process_selectors()}, \code{fill_formula_selectors()}, \code{process_formula_selectors()} and \code{check_list_elements()} return NULL. \code{compute_formula_selector()} returns a named list. } \description{ Functions process tidyselect arguments passed to functions in the cards package. The processed values are saved to the calling environment, by default. \itemize{ \item \code{process_selectors()}: the arguments will be processed with tidyselect and converted to a vector of character column names. \item \code{process_formula_selectors()}: for arguments that expect named lists or lists of formulas (where the LHS of the formula is a tidyselector). This function processes these inputs and returns a named list. If a name is repeated, the last entry is kept. \item \code{fill_formula_selectors()}: when users override the default argument values, it can be important to ensure that each column from a data frame is assigned a value. This function checks that each column in \code{data} has an assigned value, and if not, fills the value in with the default value passed here. \item \code{compute_formula_selector()}: used in \code{process_formula_selectors()} to evaluate a single argument. \item \code{check_list_elements()}: used to check the class/type/values of the list elements, primarily those processed with \code{process_formula_selectors()}. \item \code{cards_select()}: wraps \code{tidyselect::eval_select() |> names()}, and returns better contextual messaging when errors occur. } } \examples{ example_env <- rlang::new_environment() process_selectors(ADSL, variables = starts_with("TRT"), env = example_env) get(x = "variables", envir = example_env) fill_formula_selectors(ADSL, env = example_env) process_formula_selectors( ADSL, statistic = list(starts_with("TRT") ~ mean, TRTSDT = min), env = example_env ) get(x = "statistic", envir = example_env) check_list_elements( get(x = "statistic", envir = example_env), predicate = function(x) !is.null(x), error_msg = c( "Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", "i" = "Value must be a named list of functions." ) ) # process one list compute_formula_selector(ADSL, x = starts_with("U") ~ 1L) } cards/man/filter_ard_hierarchical.Rd0000644000176200001440000002045315066623216017234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filter_ard_hierarchical.R \name{filter_ard_hierarchical} \alias{filter_ard_hierarchical} \title{Filter Stacked Hierarchical ARDs} \usage{ filter_ard_hierarchical( x, filter, var = NULL, keep_empty = FALSE, quiet = FALSE ) } \arguments{ \item{x}{(\code{card})\cr a stacked hierarchical ARD of class \code{'card'} created using \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} or \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}.} \item{filter}{(\code{expression})\cr an expression that is used to filter variable groups of the hierarchical ARD. See the Details section below.} \item{var}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr hierarchy variable from \code{x} to perform filtering on. If \code{NULL}, the last hierarchy variable from \code{x} (\code{dplyr::last(attributes(x)$args$variables)}) will be used.} \item{keep_empty}{(scalar \code{logical})\cr Logical argument indicating whether to retain summary rows corresponding to hierarchy sections that have had all rows filtered out. Default is \code{FALSE}.} \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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr This function is used to filter stacked hierarchical ARDs. For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the combination of all their variable levels, but excluding any \code{by} variables. } \details{ The \code{filter} argument can be used to filter out variable groups of a hierarchical ARD which do not meet the requirements provided as an expression. Variable groups can be filtered on the values of any of the possible statistics (\code{n}, \code{p}, and \code{N}) provided they are included at least once in the ARD, as well as the values of any \code{by} variables. Additionally, filters can be applied on individual levels of the \code{by} variable via the \code{n_XX}, \code{N_XX}, and \code{p_XX} statistics, where each \code{XX} represents the index of the \code{by} variable level to select the statistic from. For example, \code{filter = n_1 > 5} will check whether \code{n} values for the first level of \code{by} are greater than 5 in each row group. Overall statistics for each row group can be used in filters via the \code{n_overall}, \code{N_overall}, and \code{p_overall} statistics. If the ARD is created with parameter \code{overall=TRUE}, then these overall statistics will be extracted directly from the ARD, otherwise the statistics will be derived where possible. If \code{overall=FALSE}, then \code{n_overall} can only be derived if the \code{n} statistic is present in the ARD for the filter variable, \code{N_overall} if the \code{N} statistic is present for the filter variable, and \code{p_overall} if both the \code{n} and \code{N} statistics are present for the filter variable. By default, filters will be applied at the level of the innermost hierarchy variable, i.e. the last variable supplied to \code{variables}. If filters should instead be applied at the level of one of the outer hierarchy variables, the \code{var} parameter can be used to select a different variable to filter on. When \code{var} is set to a different (outer) variable and a level of the variable does not meet the filtering criteria then the section corresponding to that variable level and all sub-sections within that section will be removed. To illustrate how the function works, consider the typical example below where the AE summaries are provided by treatment group. \if{html}{\out{
}}\preformatted{ADAE |> dplyr::filter(AESOC == "GASTROINTESTINAL DISORDERS", AEDECOD \%in\% c("VOMITING", "DIARRHOEA")) |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, id = USUBJID ) }\if{html}{\out{
}}\tabular{lrrr}{ \strong{SOC} / AE \tab Placebo \tab Xanomeline High Dose \tab Xanomeline Low Dose \cr \strong{GASTROINTESTINAL DISORDERS} \tab 11 (13\%) \tab 10 (12\%) \tab 8 (9.5\%) \cr DIARRHOEA \tab 9 (10\%) \tab 4 (4.8\%) \tab 5 (6.0\%) \cr VOMITING \tab 3 (3.5\%) \tab 7 (8.3\%) \tab 3 (3.6\%) \cr } Filters are applied to the summary statistics of the innermost variable in the hierarchy by default---\code{AEDECOD} in this case. If we wanted to filter based on SOC rates instead of AE rates we could specify \code{var = AESOC} instead. If any of the summary statistics meet the filter requirement for any of the treatment groups, the entire row is retained. For example, if \code{filter = n >= 9} were passed, the criteria would be met for DIARRHOEA as the Placebo group observed 9 AEs and as a result the summary statistics for the other treatment groups would be retained as well. Conversely, no treatment groups' summary statistics satisfy the filter requirement for VOMITING so all rows associated with this AE would be removed. In addition to filtering on individual statistic values, filters can be applied across the treatment groups (i.e. across all \code{by} variable values) by using aggregate functions such as \code{sum()} and \code{mean()}. For simplicity, it is suggested to use the \code{XX_overall} statistics in place of \code{sum(XX)} in equivalent scenarios. For example, \code{n_overall} is equivalent to \code{sum(n)}. A value of \code{filter = sum(n) >= 18} (or \code{filter = n_overall >= 18}) retains AEs where the sum of the number of AEs across the treatment groups is greater than or equal to 18. If \code{filter = n_overall >= 18} and \code{var = AESOC} then all rows corresponding to an SOC with an overall rate less than 18 - including all AEs within that SOC - will be removed. If \code{ard_stack_hierarchical(overall=TRUE)} was run, the overall column is \strong{not} considered in any filtering except for \code{XX_overall} statistics, if specified. If \code{ard_stack_hierarchical(over_variables=TRUE)} was run, any overall statistics are kept regardless of filtering. Some examples of possible filters: \itemize{ \item \code{filter = n > 5}: keep AEs where one of the treatment groups observed more than 5 AEs \item \code{filter = n == 2 & p < 0.05}: keep AEs where one of the treatment groups observed exactly 2 AEs \emph{and} one of the treatment groups observed a proportion less than 5\% \item \code{filter = n_overall >= 4}: keep AEs where there were 4 or more AEs observed across the treatment groups \item \code{filter = mean(n) > 4 | n > 3}: keep AEs where the mean number of AEs is 4 or more across the treatment groups \emph{or} one of the treatment groups observed more than 3 AEs \item \code{filter = n_2 > 2}: keep AEs where the \code{"Xanomeline High Dose"} treatment group (second \code{by} variable level) observed more than 2 AEs } } \examples{ \dontshow{if ((identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true"))) withAutoprint(\{ # examplesIf} # create a base AE ARD ard <- ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, id = USUBJID, overall = TRUE ) # Example 1 ---------------------------------- # Keep AEs from TRTA groups where more than 3 AEs are observed across the group filter_ard_hierarchical(ard, sum(n) > 3) # Example 2 ---------------------------------- # Keep AEs where at least one level in the TRTA group has more than 3 AEs observed filter_ard_hierarchical(ard, n > 3) # Example 3 ---------------------------------- # Keep AEs that have an overall prevalence of greater than 5\% filter_ard_hierarchical(ard, sum(n) / sum(N) > 0.05) # Example 4 ---------------------------------- # Keep AEs that have a difference in prevalence of greater than 3\% between reference group with # `TRTA = "Xanomeline High Dose"` and comparison group with `TRTA = "Xanomeline Low Dose"` filter_ard_hierarchical(ard, abs(p_2 - p_3) > 0.03) # Example 5 ---------------------------------- # Keep AEs from SOCs that have an overall prevalence of greater than 20\% filter_ard_hierarchical(ard, p_overall > 0.20, var = AESOC) \dontshow{\}) # examplesIf} } \seealso{ \code{\link[=sort_ard_hierarchical]{sort_ard_hierarchical()}} } cards/man/eval_capture_conditions.Rd0000644000176200001440000000705015003556603017320 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval_capture_conditions.R \name{eval_capture_conditions} \alias{eval_capture_conditions} \alias{captured_condition_as_message} \alias{captured_condition_as_error} \title{Evaluate and Capture Conditions} \usage{ eval_capture_conditions(expr, data = NULL, env = caller_env()) captured_condition_as_message( x, message = c("The following {type} occured:", x = "{condition}"), type = c("error", "warning"), envir = rlang::current_env() ) captured_condition_as_error( x, message = c("The following {type} occured:", x = "{condition}"), type = c("error", "warning"), call = get_cli_abort_call(), envir = rlang::current_env() ) } \arguments{ \item{expr}{An \link[rlang:topic-defuse]{expression} or \link[rlang:topic-quosure]{quosure} to evaluate.} \item{data}{A data frame, or named list or vector. Alternatively, a data mask created with \code{\link[rlang:as_data_mask]{as_data_mask()}} or \code{\link[rlang:new_data_mask]{new_data_mask()}}. Objects in \code{data} have priority over those in \code{env}. See the section about data masking.} \item{env}{The environment in which to evaluate \code{expr}. This environment is not applicable for quosures because they have their own environments.} \item{x}{(\code{captured_condition})\cr a captured condition created by \code{eval_capture_conditions()}.} \item{message}{(\code{character})\cr message passed to \code{cli::cli_inform()} or \code{cli::cli_abort()}. The condition being printed is saved in an object named \code{condition}, which should be included in this message surrounded by curly brackets.} \item{type}{(\code{string})\cr the type of condition to return. Must be one of \code{'error'} or \code{'warning'}.} \item{envir}{Environment to evaluate the glue expressions in.} \item{call}{(\code{environment})\cr Execution environment of currently running function. Default is \code{get_cli_abort_call()}.} } \value{ a named list } \description{ \strong{\code{eval_capture_conditions()}} Evaluates an expression while also capturing error and warning conditions. Function always returns a named list \code{list(result=, warning=, error=)}. If there are no errors or warnings, those elements will be \code{NULL}. If there is an error, the result element will be \code{NULL}. Messages are neither saved nor printed to the console. Evaluation is done via \code{\link[rlang:eval_tidy]{rlang::eval_tidy()}}. If errors and warnings are produced using the \code{{cli}} package, the messages are processed with \code{cli::ansi_strip()} to remove styling from the message. \strong{\code{captured_condition_as_message()}/\code{captured_condition_as_error()}} These functions take the result from \code{eval_capture_conditions()} and return errors or warnings as either messages (via \code{cli::cli_inform()}) or errors (via \code{cli::cli_abort()}). These functions handle cases where the condition messages may include curly brackets, which would typically cause issues when processed with the \verb{cli::cli_*()} functions. Functions return the \code{"result"} from \code{eval_capture_conditions()}. } \examples{ # function executes without error or warning eval_capture_conditions(letters[1:2]) # an error is thrown res <- eval_capture_conditions(stop("Example Error!")) res captured_condition_as_message(res) # if more than one warning is returned, all are saved eval_capture_conditions({ warning("Warning 1") warning("Warning 2") letters[1:2] }) # messages are not printed to the console eval_capture_conditions({ message("A message!") letters[1:2] }) } cards/man/dot-check_no_ard_columns.Rd0000644000176200001440000000137715050667010017343 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.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-calculate_stats_as_ard.Rd0000644000176200001440000000171715050667010017666 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.R \name{.calculate_stats_as_ard} \alias{.calculate_stats_as_ard} \title{Calculate Continuous Statistics} \usage{ .calculate_stats_as_ard( df_nested, variables, statistic, by, strata, data, new_col_name = "...ard_all_stats..." ) } \arguments{ \item{df_nested}{(\code{data.frame})\cr a nested data frame} \item{variables}{(\code{character})\cr character vector of variables} \item{statistic}{(named \code{list})\cr named list of statistical functions} } \value{ an ARD data frame of class 'card' } \description{ Calculate statistics and return in an ARD format } \examples{ data_nested <- ADSL |> nest_for_ard( by = "ARM", strata = NULL, key = "...ard_nested_data..." ) cards:::.calculate_stats_as_ard( df_nested = data_nested, variables = "AGE", statistic = list(mean = "mean"), by = "ARM", strata = NULL, data = ADSL ) } \keyword{internal} cards/man/ard_stack_hierarchical.Rd0000644000176200001440000001503315113466401017044 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, by_stats = TRUE ) 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, by_stats = TRUE ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Specifies the nested/hierarchical structure of the data. The variables that are specified here and in the \code{include} argument will have summary statistics calculated.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform tabulations by. All combinations of the variables specified here appear in results. Default is \code{dplyr::group_vars(data)}.} \item{id}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr argument used to subset \code{data} to identify rows in \code{data} to calculate event rates in \code{ard_stack_hierarchical()}. See details below.} \item{denominator}{(\code{data.frame}, \code{integer})\cr used to define the denominator and enhance the output. The argument is required for \code{ard_stack_hierarchical()} and optional for \code{ard_stack_hierarchical_count()}. \itemize{ \item the univariate tabulations of the \code{by} variables are calculated with \code{denominator}, when a data frame is passed, e.g. tabulation of the treatment assignment counts that may appear in the header of a table. \item the \code{denominator} argument must be specified when \code{id} is used to calculate the event rates. \item if \code{total_n=TRUE}, the \code{denominator} argument is used to return the total N }} \item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Specify the subset a columns indicated in the \code{variables} argument for which summary statistics will be returned. Default is \code{everything()}.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{overall}{(scalar \code{logical})\cr logical indicating whether overall statistics should be calculated (i.e. repeat the operations with \code{by=NULL} in \emph{most cases}, see below for details). Default is \code{FALSE}.} \item{over_variables}{(scalar \code{logical})\cr logical indicating whether summary statistics should be calculated over or across the columns listed in the \code{variables} argument. Default is \code{FALSE}.} \item{attributes}{(scalar \code{logical})\cr logical indicating whether to include the results of \code{ard_attributes()} for all variables represented in the ARD. Default is \code{FALSE}.} \item{total_n}{(scalar \code{logical})\cr logical indicating whether to include of \code{ard_total_n(denominator)} in the returned ARD.} \item{shuffle}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} support for \code{.shuffle = TRUE} has been removed.} \item{by_stats}{(\code{logical})\cr logical indicating whether to include overall stats of the \code{by} variables in the returned ARD.} } \value{ an ARD data frame of class 'card' } \description{ Use these functions to calculate multiple summaries of nested or hierarchical data in a single call. \itemize{ \item \code{ard_stack_hierarchical()}: Calculates \emph{rates} of events (e.g. adverse events) utilizing the \code{denominator} and \code{id} arguments to identify the rows in \code{data} to include in each rate calculation. \item \code{ard_stack_hierarchical_count()}: Calculates \emph{counts} of events utilizing all rows for each tabulation. } } \section{Subsetting Data for Rate Calculations}{ To calculate event rates, the \code{ard_stack_hierarchical()} function identifies rows to include in the calculation. First, the primary data frame is sorted by the columns identified in the \code{id}, \code{by}, and \code{variables} arguments. As the function cycles over the variables specified in the \code{variables} argument, the data frame is grouped by \code{id}, \code{intersect(by, names(denominator))}, and \code{variables} utilizing the last row within each of the groups. For example, if the call is \code{ard_stack_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), id = USUBJID)}, then we'd first subset ADAE to be one row within the grouping \code{c(USUBJID, AESOC, AEDECOD)} to calculate the event rates in \code{'AEDECOD'}. We'd then repeat and subset ADAE to be one row within the grouping \code{c(USUBJID, AESOC)} to calculate the event rates in \code{'AESOC'}. } \section{Overall Argument}{ When we set \code{overall=TRUE}, we wish to re-run our calculations removing the stratifying columns. For example, if we ran the code below, we results would include results with the code chunk being re-run with \code{by=NULL}. \if{html}{\out{
}}\preformatted{ard_stack_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, id = USUBJID, 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, id = USUBJID, overall = TRUE ) }\if{html}{\out{
}} } \examples{ ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL, id = USUBJID ) ard_stack_hierarchical_count( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL ) } cards/man/get_ard_statistics.Rd0000644000176200001440000000216615050667010016274 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_tabulate(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.Rd0000644000176200001440000000137615003556603016716 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.Rd0000644000176200001440000000103615003556603017121 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.Rd0000644000176200001440000000206215003556603014446 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexports.R \docType{import} \name{reexports} \alias{reexports} \alias{\%>\%} \alias{starts_with} \alias{ends_with} \alias{contains} \alias{matches} \alias{num_range} \alias{all_of} \alias{any_of} \alias{everything} \alias{where} \alias{last_col} \alias{one_of} \alias{vars} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{contains}}, \code{\link[dplyr:reexports]{ends_with}}, \code{\link[dplyr:reexports]{everything}}, \code{\link[dplyr:reexports]{last_col}}, \code{\link[dplyr:reexports]{matches}}, \code{\link[dplyr:reexports]{num_range}}, \code{\link[dplyr:reexports]{one_of}}, \code{\link[dplyr:reexports]{starts_with}}, \code{\link[dplyr]{vars}}, \code{\link[dplyr:reexports]{where}}} }} cards/man/unlist_ard_columns.Rd0000644000176200001440000000243015050667010016313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unlist_ard_columns.R \name{unlist_ard_columns} \alias{unlist_ard_columns} \title{Unlist ARD Columns} \usage{ unlist_ard_columns( x, columns = c(where(is.list), -any_of(c("warning", "error", "fmt_fun"))), fill = NA, fct_as_chr = TRUE ) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card' or any data frame} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to unlist. Default is \code{c(where(is.list), -any_of(c("warning", "error", "fmt_fun")))}.} \item{fill}{(scalar)\cr scalar to fill NULL values with before unlisting (if they are present). Default is \code{NA}.} \item{fct_as_chr}{(scalar \code{logical})\cr When \code{TRUE}, factor elements will be converted to character before unlisting. When the column being unlisted contains mixed types of classes, the factor elements are often converted to the underlying integer value instead of retaining the label. Default is \code{TRUE}.} } \value{ a data frame } \description{ Unlist ARD Columns } \examples{ ADSL |> ard_tabulate(by = ARM, variables = AGEGR1) |> apply_fmt_fun() |> unlist_ard_columns() ADSL |> ard_summary(by = ARM, variables = AGE) |> apply_fmt_fun() |> unlist_ard_columns() } cards/man/add_calculated_row.Rd0000644000176200001440000000317315050667010016214 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_fun = NULL, fmt_fn = deprecated() ) } \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_fun}{(\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_fun()}.} \item{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \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_summary(mtcars, variables = mpg) |> add_calculated_row(expr = max - min, stat_name = "range") ard_summary(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.Rd0000644000176200001440000000054615003556603016421 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.Rd0000644000176200001440000000246715050667010017155 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_summary( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> replace_null_statistic(rows = !is.null(error)) } cards/man/ard_summary.Rd0000644000176200001440000000622115050667010014734 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.R \name{ard_summary} \alias{ard_summary} \alias{ard_summary.data.frame} \title{Univariate ARD Statistics} \usage{ ard_summary(data, ...) \method{ard_summary}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ continuous_summary_fns(), fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for summary statistic calculation. Arguments are similar, but with an important distinction: \code{by}: results are calculated for \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are calculated for \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) mean(x)))}. The value assigned to each variable must also be a named list, where the names are used to reference a function and the element is the function object. Typically, this function will return a scalar statistic, but a function that returns a named list of results is also acceptable, e.g. \code{list(conf.low = -1, conf.high = 1)}. However, when errors occur, the messaging will be less clear in this setting.} \item{fmt_fun}{(\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")}.} \item{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ an ARD data frame of class 'card' } \description{ Compute Analysis Results Data (ARD) for simple continuous summary statistics. } \examples{ ard_summary(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_summary( variables = "AGE", statistic = ~ list(conf.int = \(x) t.test(x)[["conf.int"]] |> as.list() |> setNames(c("conf.low", "conf.high"))) ) } cards/man/dot-lst_results_as_df.Rd0000644000176200001440000000166015050667010016716 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.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.Rd0000644000176200001440000000272115066623216015106 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} (\href{https://orcid.org/0009-0000-8738-5561}{ORCID}) \item Malan Bosman \email{malanbos@gmail.com} (\href{https://orcid.org/0000-0002-3020-195X}{ORCID}) } Other contributors: \itemize{ \item F. Hoffmann-La Roche AG [copyright holder, funder] \item GlaxoSmithKline Research & Development Limited [copyright holder] } } \keyword{internal} cards/man/figures/0000755000176200001440000000000015056037207013572 5ustar liggesuserscards/man/figures/lifecycle-questioning.svg0000644000176200001440000000244415003556603020617 0ustar liggesusers lifecycle: questioning lifecycle questioning cards/man/figures/lifecycle-stable.svg0000644000176200001440000000247215003556603017525 0ustar liggesusers lifecycle: stable lifecycle stable cards/man/figures/lifecycle-experimental.svg0000644000176200001440000000245015003556603020744 0ustar liggesusers lifecycle: experimental lifecycle experimental cards/man/figures/lifecycle-deprecated.svg0000644000176200001440000000244015003556603020346 0ustar liggesusers lifecycle: deprecated lifecycle deprecated cards/man/figures/lifecycle-superseded.svg0000644000176200001440000000244015003556603020411 0ustar liggesusers lifecycle: superseded lifecycle superseded cards/man/figures/logo.png0000644000176200001440000013111315027256543015244 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.svg0000644000176200001440000000243015003556603020032 0ustar liggesusers lifecycle: archived lifecycle archived cards/man/figures/lifecycle-defunct.svg0000644000176200001440000000242415003556603017700 0ustar liggesusers lifecycle: defunct lifecycle defunct cards/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000246615003556603021327 0ustar liggesusers lifecycle: soft-deprecated lifecycle soft-deprecated cards/man/figures/lifecycle-maturing.svg0000644000176200001440000000243015003556603020073 0ustar liggesusers lifecycle: maturing lifecycle maturing cards/man/check_ard_structure.Rd0000644000176200001440000000155515050667010016441 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_summary(ADSL, variables = "AGE") |> dplyr::select(-warning, -error) |> check_ard_structure() } cards/man/ard_formals.Rd0000644000176200001440000000237015003556603014706 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_formals.R \name{ard_formals} \alias{ard_formals} \title{Argument Values ARD} \usage{ ard_formals(fun, arg_names, passed_args = list(), envir = parent.frame()) } \arguments{ \item{fun}{(\code{function})\cr a \link{function} passed to \code{formals(fun)}} \item{arg_names}{(\code{character})\cr character vector of argument names to return} \item{passed_args}{(named \code{list})\cr a named list of user-passed arguments. Default is \code{list()}, which returns all default values from a function} \item{envir}{(\code{environment})\cr an environment passed to \code{formals(envir)}} } \value{ an partial ARD data frame of class 'card' } \description{ Place default and passed argument values to a function into an ARD structure. } \examples{ # Example 1 ---------------------------------- # add the `mcnemar.test(correct)` argument to an ARD structure ard_formals(fun = mcnemar.test, arg_names = "correct") # Example 2 ---------------------------------- # S3 Methods need special handling to access the underlying method ard_formals( fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.90) ) } cards/man/dot-process_nested_list_as_df.Rd0000644000176200001440000000153115050667010020403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") cards:::.process_nested_list_as_df(ard, NULL, "new_col") } \keyword{internal} cards/man/bind_ard.Rd0000644000176200001440000000364515050667010014162 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{TRUE}. 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") bind_ard(ard, ard, .update = TRUE) } cards/man/dot-one_row_ard_to_nested_list.Rd0000644000176200001440000000117615050667010020576 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_summary(mtcars, variables = mpg) |> dplyr::filter(dplyr::row_number() \%in\% 1L) |> apply_fmt_fun() |> cards:::.one_row_ard_to_nested_list() } \keyword{internal} cards/man/as_cards_fn.Rd0000644000176200001440000000321215050667010014650 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_summary()} or \code{ard_mvsummary()} 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_summary( 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_summary( 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_summary( mtcars, variables = mpg, statistic = ~ list(ttest = \(x) { t.test(x)[c("statistic", "p.value")] stop("Intentional Error") }) ) } cards/man/adam.Rd0000644000176200001440000000151515034313244013313 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} \alias{ADLB} \title{Example ADaM Data} \format{ An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 254 rows and 49 columns. An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 1191 rows and 56 columns. An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 254 rows and 26 columns. An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 5784 rows and 46 columns. } \usage{ ADSL ADAE ADTTE ADLB } \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.Rd0000644000176200001440000000136615050667010020054 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_ard_conditions.R \name{.cli_condition_messaging} \alias{.cli_condition_messaging} \title{Print Condition Messages Saved in an ARD} \usage{ .cli_condition_messaging(x, msg_type, condition_type) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{msg_type}{(\code{string})\cr message type. Options are \code{"warning"} and \code{"error"}.} } \value{ returns invisible if check is successful, throws warning/error messages if not. } \description{ Print Condition Messages Saved in an ARD } \examples{ ard <- ard_summary( ADSL, by = ARM, variables = AGE ) cards:::.cli_condition_messaging(ard, msg_type = "error") } \keyword{internal} cards/man/dot-derive_overall_labels.Rd0000644000176200001440000000174615041734160017531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.derive_overall_labels} \alias{.derive_overall_labels} \title{Derive overall labels} \usage{ .derive_overall_labels(x, cur_col = dplyr::cur_column()) } \arguments{ \item{x}{(character) content of target (current) column} \item{cur_col}{(character) name of current column} } \value{ a character vector } \description{ Transform the \code{"..cards_overall.."} and \code{"..hierarchical_overall.."} labels into \code{"Overall "} and \code{"Any "} respectively. Also it ensures the labels are unique (in case they already exist) with \code{make.unique()} which appends a sequence number. } \examples{ data <- dplyr::tibble( ARM = c("..cards_overall..", "Overall ARM", NA, "BB", NA), TRTA = c(NA, NA, "..hierarchical_overall..", "C", "C") ) data |> dplyr::mutate( dplyr::across( ARM:TRTA, cards:::.derive_overall_labels ) ) } \keyword{internal} cards/man/ard_hierarchical.Rd0000644000176200001440000001043715027040570015661 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_fun = NULL, stat_label = everything() ~ default_stat_labels(), id = NULL, fmt_fn = deprecated(), ... ) \method{ard_hierarchical_count}{data.frame}( data, variables, by = dplyr::group_vars(data), fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform the nested/hierarchical tabulations within.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform tabulations by. All combinations of the variables specified here appear in results. Default is \code{dplyr::group_vars(data)}.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{data.frame}, \code{integer})\cr used to define the denominator and enhance the output. The argument is required for \code{ard_hierarchical()} and optional for \code{ard_hierarchical_count()}. \itemize{ \item the univariate tabulations of the \code{by} variables are calculated with \code{denominator}, when a data frame is passed, e.g. tabulation of the treatment assignment counts that may appear in the header of a table. \item the \code{denominator} argument must be specified when \code{id} is used to calculate the event rates. }} \item{fmt_fun}{(\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.} \item{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ an ARD data frame of class 'card' } \description{ \emph{Functions \code{ard_hierarchical()} and \code{ard_hierarchical_count()} are primarily helper functions for \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} and \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}, meaning that it will be rare a user needs to call \code{ard_hierarchical()}/\code{ard_hierarchical_count()} directly.} Performs hierarchical or nested tabulations, e.g. tabulates AE terms nested within AE system organ class. \itemize{ \item \code{ard_hierarchical()} includes summaries for the last variable listed in the \code{variables} argument, nested within the other variables included. \item \code{ard_hierarchical_count()} includes summaries for \emph{all} variables listed in the \code{variables} argument each summary nested within the preceding variables, e.g. \code{variables=c(AESOC, AEDECOD)} summarizes \code{AEDECOD} nested in \code{AESOC}, and also summarizes the counts of \code{AESOC}. } } \examples{ ard_hierarchical( data = ADAE |> dplyr::slice_tail(n = 1L, by = c(USUBJID, TRTA, AESOC, AEDECOD)), variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL ) ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA ) } cards/man/ard_tabulate_value.Rd0000644000176200001440000001237315050667010016241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate_value.R \name{ard_tabulate_value} \alias{ard_tabulate_value} \alias{ard_tabulate_value.data.frame} \title{Tabulate Value ARD} \usage{ ard_tabulate_value(data, ...) \method{ard_tabulate_value}{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_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \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 values to tabulate. Default is \code{maximum_variable_value(data)}, which returns the largest/last value after a sort.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{fmt_fun}{(\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{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ an ARD data frame of class 'card' } \description{ Tabulate an Analysis Results Data (ARD) for dichotomous or a specified value. } \section{Denominators}{ By default, the \code{ard_tabulate()} 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 calculation for the proportion is \code{p = n/N}. However, it is sometimes necessary to provide a different \code{"N"} to use as the denominator in this calculation. For example, in a calculation of the rates of various observed adverse events, you may need to update the denominator to the number of enrolled subjects. In such cases, use the \code{denominator} argument to specify a new definition of \code{"N"}, and subsequently \code{"p"}. The argument expects one of the following inputs: \itemize{ \item a string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \itemize{ \item \code{"column"}, the default, returns percentages where the sum is equal to one within the variable after the data frame has been subset with \code{by}/\code{strata}. \item \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. This is well-defined for a single \code{by} or \code{strata} variable, and care must be taken when there are more to ensure the the results are as you expect. \item \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. } \item a data frame. Any columns in the data frame that overlap with the \code{by}/\code{strata} columns will be used to calculate the new \code{"N"}. \item an integer. This single integer will be used as the new \code{"N"} \item a structured data frame. The data frame will include columns from \code{by}/\code{strata}. The last column must be named \code{"...ard_N..."}. The integers in this column will be used as the updated \code{"N"} in the calculations. } When the \code{p} statistic is returned, the proportion is returned---bounded by \verb{[0, 1]}. The default function to format the statistic scales the proportion by 100 and the percentage is returned which matches the default statistic label of \code{'\%'}. To get the formatted values, pass the ARD to \code{apply_fmt_fun()}. } \examples{ ard_tabulate_value(mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4)) mtcars |> dplyr::group_by(vs) |> ard_tabulate_value( variables = c(cyl, am), value = list(cyl = 4), statistic = ~"p" ) } cards/man/dot-fill_grps_from_variables.Rd0000644000176200001440000000140415003556603020232 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.Rd0000644000176200001440000000071115003556603016010 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.Rd0000644000176200001440000000411015051153170015047 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, include_by_and_strata = FALSE ) } \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}.} \item{include_by_and_strata}{(\code{logical})\cr When \code{TRUE}, the \code{by} and \code{strata} variables are included in the nested data frames.} } \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/dot-rename_last_group_as_variable.Rd0000644000176200001440000000135315003556603021237 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_hierarchical.R \name{.rename_last_group_as_variable} \alias{.rename_last_group_as_variable} \title{Rename Last Group to Variable} \usage{ .rename_last_group_as_variable(df_result, by, variables) } \arguments{ \item{df_result}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \value{ an ARD data frame of class 'card' } \description{ In the \verb{ard_hierarchical*()} functions, the last grouping variable is renamed to \code{variable} and \code{variable_level} before being returned. } \examples{ data <- data.frame(x = 1, y = 2, group1 = 3, group2 = 4) cards:::.rename_last_group_as_variable(data, by = "ARM", variables = "AESOC") } \keyword{internal} cards/man/dot-default_fmt_fun.Rd0000644000176200001440000000101115050667010016327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_summary.R \name{.default_fmt_fun} \alias{.default_fmt_fun} \title{Add Default Formatting Functions} \usage{ .default_fmt_fun(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_tabulate(ADSL, by = "ARM", variables = "AGEGR1") |> dplyr::mutate(fmt_fun = NA) cards:::.default_fmt_fun(ard) } \keyword{internal} cards/man/dot-nesting_rename_ard_columns.Rd0000644000176200001440000000253315003556603020566 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.Rd0000644000176200001440000000127115050667010014776 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), ard_tabulate(ADSL, variables = "ARM") ) |> shuffle_ard(trim = FALSE) ard |> cards:::.trim_ard() } \keyword{internal} cards/man/dot-fill_overall_grp_values.Rd0000644000176200001440000000236415041734160020103 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 \code{"Overall "} or \code{"Any "}where relevant. Specifically, it will modify grouping values from rows with likely overall calculations present (e.g. non-missing variable/variable_level, missing group variables, and evidence that the \code{variable} has been computed by group in other rows). \code{"Overall"} values will be populated only for grouping variables that have been used in other calculations of the same variable and statistics. \code{"Any"} will be used if it is likely to be a hierarchical calculation. } \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.Rd0000644000176200001440000000536715050667010013751 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_summary(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_summary(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_summary(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_summary(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_summary(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_summary(statistic = ~list(N = \\(x) length(x))) ard_summary(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_summary(statistic = c(everything(), -age) ~ list(N = \\(x) length(x))) }\if{html}{\out{
}} } } \keyword{internal} cards/man/as_nested_list.Rd0000644000176200001440000000115515050667010015412 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_summary(mtcars, by = "cyl", variables = c("mpg", "hp")) |> as_nested_list() } cards/man/tidy_as_ard.Rd0000644000176200001440000000561115050667010014675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_as_ard.R \name{tidy_as_ard} \alias{tidy_as_ard} \title{Build ARD from Tidier} \usage{ tidy_as_ard( lst_tidy, tidy_result_names, fun_args_to_record = character(0L), formals = list(), passed_args = list(), lst_ard_columns ) } \arguments{ \item{lst_tidy}{(named \code{list})\cr list of tidied results constructed with \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}, e.g. \code{eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())}.} \item{tidy_result_names}{(\code{character})\cr character vector of column names expected by the tidier method. This is used to construct blank results in the event of an error.} \item{fun_args_to_record}{(\code{character})\cr character vector of function argument names that are added to the ARD.} \item{formals}{(\code{pairlist})\cr the results from \code{formals()}, e.g. \code{formals(fisher.test)}. This is used to get the default argument values from unspecified arguments.} \item{passed_args}{(named \code{list})\cr named list of additional arguments passed to the modeling function.} \item{lst_ard_columns}{(named \code{list})\cr named list of values that will be added to the ARD data frame.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}}\cr \emph{Function is questioning because we think a better solution may be \code{ard_summary()} + \code{ard_formals()}.} Function converts a model's one-row tidy data frame into an ARD structure. The tidied data frame must have been constructed with \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}. This function is primarily for developers and few consistency checks have been included. } \examples{ # example how one may create a fisher.test() ARD function my_ard_fishertest <- function(data, by, variable, ...) { # perform fisher test and format results ----------------------------------- lst_tidy_fisher <- eval_capture_conditions( # this manipulation is similar to `fisher.test(...) |> broom::tidy()` stats::fisher.test(x = data[[variable]], y = data[[by]], ...)[c("p.value", "method")] |> as.data.frame() ) # build ARD ------------------------------------------------------------------ tidy_as_ard( lst_tidy = lst_tidy_fisher, tidy_result_names = c("p.value", "method"), fun_args_to_record = c( "workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B" ), formals = formals(stats::fisher.test), passed_args = dots_list(...), lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest") ) } my_ard_fishertest(mtcars, by = "am", variable = "vs") } \keyword{internal} cards/man/dot-process_denominator.Rd0000644000176200001440000000300115050667010017243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate.R \name{.process_denominator} \alias{.process_denominator} \title{Process \code{denominator} Argument} \usage{ .process_denominator(data, variables, denominator, by, strata) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} } \value{ a data frame } \description{ Function takes the \code{ard_tabulate(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.Rd0000644000176200001440000000144215050667010016130 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_tabulate(variables = "AGEGR1"), ard_summary(variables = "AGE") ) } \keyword{internal} cards/man/deprecated.Rd0000644000176200001440000000516215113466401014515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R, R/shuffle_ard.R \name{deprecated} \alias{deprecated} \alias{ard_continuous} \alias{ard_categorical} \alias{ard_complex} \alias{ard_dichotomous} \alias{ard_continuous.data.frame} \alias{ard_categorical.data.frame} \alias{ard_complex.data.frame} \alias{ard_dichotomous.data.frame} \alias{apply_fmt_fn} \alias{alias_as_fmt_fn} \alias{update_ard_fmt_fn} \alias{shuffle_ard} \title{Deprecated functions} \usage{ ard_continuous(data, ...) ard_categorical(data, ...) ard_complex(data, ...) ard_dichotomous(data, ...) \method{ard_continuous}{data.frame}(data, ...) \method{ard_categorical}{data.frame}(data, ...) \method{ard_complex}{data.frame}(data, ...) \method{ard_dichotomous}{data.frame}(data, ...) apply_fmt_fn(...) alias_as_fmt_fn(...) update_ard_fmt_fn(...) shuffle_ard(x, trim = TRUE) } \arguments{ \item{data, ...}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} \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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}\cr Some functions have been deprecated and are no longer being actively supported. \strong{Renamed functions} \itemize{ \item \code{ard_categorical()} to \code{ard_tabulate()} \item \code{ard_continuous()} to \code{ard_summary()} \item \code{ard_complex()} to \code{ard_mvsummary()} \item \code{apply_fmt_fn()} to \code{apply_fmt_fun()} \item \code{alias_as_fmt_fn()} to \code{alias_as_fmt_fun()} \item \code{update_ard_fmt_fn()} to \code{update_ard_fmt_fun()} } \strong{Deprecated functions} \itemize{ \item \code{shuffle_ard()} } \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}\cr 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_tabulate(ADSL, by = "ARM", variables = "AGEGR1"), ard_tabulate(ADSL, variables = "ARM") ) |> shuffle_ard() } cards/man/mock.Rd0000644000176200001440000000501215027040570013337 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_fun() 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_fun(variables = c("AGE", "BMIBL"), stat_names = "sd", fmt_fun = \(x) "xx.xx") |> apply_fmt_fun() } cards/man/dot-calculate_tabulation_statistics.Rd0000644000176200001440000000361315050667010021630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_tabulate.R \name{.calculate_tabulation_statistics} \alias{.calculate_tabulation_statistics} \title{Calculate Tabulation Statistics} \usage{ .calculate_tabulation_statistics( data, variables, by, strata, denominator, statistic ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} } \value{ an ARD data frame of class 'card' } \description{ Function takes the summary instructions from the \code{statistic = list(variable_name = list(tabulation=c("n", "N", "p")))} argument, and returns the tabulations in an ARD structure. } \examples{ cards:::.calculate_tabulation_statistics( ADSL, variables = "ARM", by = NULL, strata = NULL, denominator = "cell", statistic = list(ARM = list(tabulation = c("N"))) ) } \keyword{internal} cards/man/round5.Rd0000644000176200001440000000150615003556603013631 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/round5.R \name{round5} \alias{round5} \title{Rounding of Numbers} \usage{ round5(x, digits = 0) } \arguments{ \item{x}{(\code{numeric})\cr a numeric vector} \item{digits}{(\code{integer})\cr integer indicating the number of decimal places} } \value{ a numeric vector } \description{ Rounds the values in its first argument to the specified number of decimal places (default 0). Importantly, \code{round5()} \strong{does not} use Base R's "round to even" default. Standard rounding methods are implemented, for example, \code{cards::round5(0.5) = 1}, whereas \code{base::round(0.5) = 0}. } \details{ Function inspired by \code{janitor::round_half_up()}. } \examples{ x <- 0:4 / 2 round5(x) |> setNames(x) # compare results to Base R round(x) |> setNames(x) } cards/man/ard_attributes.Rd0000644000176200001440000000262215003556603015431 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.Rd0000644000176200001440000000154715027040570016514 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fun.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/ard_mvsummary.Rd0000644000176200001440000000752315050667010015305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_mvsummary.R \name{ard_mvsummary} \alias{ard_mvsummary} \alias{ard_mvsummary.data.frame} \title{Multivariate ARD Summaries} \usage{ ard_mvsummary(data, ...) \method{ard_mvsummary}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic, fmt_fun = NULL, stat_label = everything() ~ default_stat_labels(), fmt_fn = deprecated(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for summary statistic calculation. Arguments are similar, but with an important distinction: \code{by}: results are calculated for \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are calculated for \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr The form of the statistics argument is identical to \code{ard_summary(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_fun}{(\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")}.} \item{fmt_fn}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ an ARD data frame of class 'card' } \description{ Function is similar to \code{\link[=ard_summary]{ard_summary()}}, but allows for more complex, multivariate summaries. While \code{ard_summary(statistic)} only allows for a univariable function, \code{ard_mvsummary(statistic)} can handle more complex data summaries. } \examples{ # example how to mimic behavior of `ard_summary()` ard_mvsummary( 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_mvsummary( variables = "AGE", statistic = list(AGE = list(means = grand_mean)) ) } cards/man/dot-detect_msgs.Rd0000644000176200001440000000147615050667010015505 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.detect_msgs} \alias{.detect_msgs} \title{Detect Columns with Non-Null Contents} \usage{ .detect_msgs(x, ...) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr columns to search within} } \description{ Function looks for non-null contents in requested columns and notifies user before removal. Specifically used for detecting messages. } \examples{ ard <- ard_summary( 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/man/apply_fmt_fun.Rd0000644000176200001440000000136115050667010015254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fun.R \name{apply_fmt_fun} \alias{apply_fmt_fun} \title{Apply Formatting Functions} \usage{ apply_fmt_fun(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_fun]{alias_as_fmt_fun()}}. } \examples{ ard_summary(ADSL, variables = "AGE") |> apply_fmt_fun() } cards/DESCRIPTION0000644000176200001440000000442515113515064013062 0ustar liggesusersPackage: cards Title: Analysis Results Data Version: 0.7.1 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", comment = c(ORCID = "0009-0000-8738-5561")), person("Malan", "Bosman", , "malanbos@gmail.com", role = "aut", comment = c(ORCID = "0000-0002-3020-195X")), 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.5), dplyr (>= 1.1.4), glue (>= 1.8.0), lifecycle (>= 1.0.4), rlang (>= 1.1.6), tidyr (>= 1.3.1), tidyselect (>= 1.2.1) Suggests: testthat (>= 3.2.3), withr (>= 3.0.0) Config/Needs/coverage: hms Config/Needs/website: rmarkdown, jsonlite, yaml, gtsummary, tfrmt, cardx, gt, fontawesome, insightsengineering/crane, insightsengineering/nesttemplate Config/testthat/edition: 3 Config/testthat/parallel: true Encoding: UTF-8 Language: en-US LazyData: true RoxygenNote: 7.3.3 NeedsCompilation: no Packaged: 2025-12-02 05:31:07 UTC; sjobergd Author: Daniel D. Sjoberg [aut, cre] (ORCID: ), Becca Krouse [aut], Emily de la Rua [aut] (ORCID: ), Malan Bosman [aut] (ORCID: ), F. Hoffmann-La Roche AG [cph, fnd], GlaxoSmithKline Research & Development Limited [cph] Maintainer: Daniel D. Sjoberg Repository: CRAN Date/Publication: 2025-12-02 07:50:12 UTC