diff --git a/DESCRIPTION b/DESCRIPTION index ff427eaa6..293df1786 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,7 +19,7 @@ BugReports: https://github.com/insightsengineering/cardx/issues Depends: R (>= 4.1) Imports: - cards (>= 0.2.1.9003), + cards (>= 0.2.1.9006), cli (>= 3.6.1), dplyr (>= 1.1.2), glue (>= 1.6.2), diff --git a/NEWS.md b/NEWS.md index 0069df634..9b558d3b7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ * Added S3 method `ard_total_n.survey.design()` which returns an ARD with both the survey-weighted and unweighted total sample size. +* Added `warning` and `error` columns to `ard_regression()` output. (#148) + # cardx 0.2.0 ### Breaking Changes diff --git a/R/ard_regression.R b/R/ard_regression.R index f07fabc7d..37ea9063b 100644 --- a/R/ard_regression.R +++ b/R/ard_regression.R @@ -34,51 +34,84 @@ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_ check_not_missing(x) # summarize model ------------------------------------------------------------ - broom.helpers::tidy_plus_plus( - model = x, - tidy_fun = tidy_fun, - ... - ) |> + lst_results <- cards::eval_capture_conditions( + broom.helpers::tidy_plus_plus( + model = x, + tidy_fun = tidy_fun, + ... + ) + ) + + # final tidying up of cards data frame --------------------------------------- + .regression_final_ard_prep(lst_results) +} + +.regression_final_ard_prep <- function(lst_results) { + # saving the results in data frame ------------------------------------------- + df_card <- + if (!is.null(lst_results[["result"]])) { + lst_results[["result"]] |> + dplyr::mutate( + variable_level = dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label), + dplyr::across(-c("variable", "variable_level"), .fns = as.list) + ) |> + tidyr::pivot_longer( + cols = -c("variable", "variable_level"), + names_to = "stat_name", + values_to = "stat" + ) |> + dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |> + dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) + } else { # if there was an error return a shell of an ARD data frame + dplyr::tibble( + variable = "model_1", + stat_name = "estimate", + stat = list(NULL) + ) + } + + # final tidying up of ARD data frame --------------------------------------- + df_card |> dplyr::mutate( - variable_level = dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label), - dplyr::across(-c("variable", "variable_level"), .fns = as.list) + warning = lst_results["warning"], + error = lst_results["error"], + fmt_fn = lapply( + .data$stat, + function(x) { + switch(is.integer(x), + 0L + ) %||% switch(is.numeric(x), + 1L + ) + } + ), + context = "regression" ) |> - tidyr::pivot_longer( - cols = -c("variable", "variable_level"), - names_to = "stat_name", - values_to = "stat" + dplyr::left_join( + .df_regression_stat_labels(), + by = "stat_name" ) |> - dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |> - dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) |> - dplyr::mutate( - fmt_fn = - lapply( - .data$stat, - function(x) { - switch(is.integer(x), 0L) %||% # styler: off - switch(is.numeric(x), 1L) # styler: off - } - ), - context = "regression", - stat_label = - dplyr::case_when( - .data$stat_name %in% "var_label" ~ "Label", - .data$stat_name %in% "var_class" ~ "Class", - .data$stat_name %in% "var_type" ~ "Type", - .data$stat_name %in% "var_nlevels" ~ "N Levels", - .data$stat_name %in% "contrasts_type" ~ "Contrast Type", - .data$stat_name %in% "label" ~ "Level Label", - .data$stat_name %in% "n_obs" ~ "N Obs.", - .data$stat_name %in% "n_event" ~ "N Events", - .data$stat_name %in% "exposure" ~ "Exposure Time", - .data$stat_name %in% "estimate" ~ "Coefficient", - .data$stat_name %in% "std.error" ~ "Standard Error", - .data$stat_name %in% "p.value" ~ "p-value", - .data$stat_name %in% "conf.low" ~ "CI Lower Bound", - .data$stat_name %in% "conf.high" ~ "CI Upper Bound", - TRUE ~ .data$stat_name - ) - ) |> - cards::tidy_ard_column_order() %>% - {structure(., class = c("card", class(.)))} # styler: off + dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> + cards::as_card() |> + cards::tidy_ard_column_order() +} + +.df_regression_stat_labels <- function() { + dplyr::tribble( + ~stat_name, ~stat_label, + "var_label", "Label", + "var_class", "Class", + "var_type", "Type", + "var_nlevels", "N Levels", + "contrasts_type", "Contrast Type", + "label", "Level Label", + "n_obs", "N Obs.", + "n_event", "N Events", + "exposure", "Exposure Time", + "estimate", "Coefficient", + "std.error", "Standard Error", + "p.value", "p-value", + "conf.low", "CI Lower Bound", + "conf.high", "CI Upper Bound", + ) } diff --git a/tests/testthat/_snaps/ard_regression.md b/tests/testthat/_snaps/ard_regression.md index 5d9524bd2..cd57f0dbe 100644 --- a/tests/testthat/_snaps/ard_regression.md +++ b/tests/testthat/_snaps/ard_regression.md @@ -5,66 +5,78 @@ add_estimate_to_reference_rows = TRUE)), -context, -stat_label, -fmt_fn), stat = lapply( stat, function(x) ifelse(is.numeric(x), cards::round5(x, 3), x))) Output - variable variable_level stat_name stat - 1 ARM Placebo term ARMPlacebo - 2 ARM Placebo var_label Description of Planned Arm - 3 ARM Placebo var_class character - 4 ARM Placebo var_type categorical - 5 ARM Placebo var_nlevels 3 - 6 ARM Placebo contrasts contr.treatment - 7 ARM Placebo contrasts_type treatment - 8 ARM Placebo reference_row TRUE - 9 ARM Placebo label Placebo - 10 ARM Placebo n_obs 86 - 11 ARM Placebo estimate 0 - 12 ARM Xanomeline High Dose term ARMXanomeline High Dose - 13 ARM Xanomeline High Dose var_label Description of Planned Arm - 14 ARM Xanomeline High Dose var_class character - 15 ARM Xanomeline High Dose var_type categorical - 16 ARM Xanomeline High Dose var_nlevels 3 - 17 ARM Xanomeline High Dose contrasts contr.treatment - 18 ARM Xanomeline High Dose contrasts_type treatment - 19 ARM Xanomeline High Dose reference_row FALSE - 20 ARM Xanomeline High Dose label Xanomeline High Dose - 21 ARM Xanomeline High Dose n_obs 84 - 22 ARM Xanomeline High Dose estimate -0.828 - 23 ARM Xanomeline High Dose std.error 1.267 - 24 ARM Xanomeline High Dose statistic -0.654 - 25 ARM Xanomeline High Dose p.value 0.514 - 26 ARM Xanomeline High Dose conf.low -3.324 - 27 ARM Xanomeline High Dose conf.high 1.668 - 28 ARM Xanomeline Low Dose term ARMXanomeline Low Dose - 29 ARM Xanomeline Low Dose var_label Description of Planned Arm - 30 ARM Xanomeline Low Dose var_class character - 31 ARM Xanomeline Low Dose var_type categorical - 32 ARM Xanomeline Low Dose var_nlevels 3 - 33 ARM Xanomeline Low Dose contrasts contr.treatment - 34 ARM Xanomeline Low Dose contrasts_type treatment - 35 ARM Xanomeline Low Dose reference_row FALSE - 36 ARM Xanomeline Low Dose label Xanomeline Low Dose - 37 ARM Xanomeline Low Dose n_obs 84 - 38 ARM Xanomeline Low Dose estimate 0.457 - 39 ARM Xanomeline Low Dose std.error 1.267 - 40 ARM Xanomeline Low Dose statistic 0.361 - 41 ARM Xanomeline Low Dose p.value 0.719 - 42 ARM Xanomeline Low Dose conf.low -2.039 - 43 ARM Xanomeline Low Dose conf.high 2.953 + variable variable_level stat_name stat warning error + 1 ARM Placebo term ARMPlacebo NULL NULL + 2 ARM Placebo var_label Description of Planned Arm NULL NULL + 3 ARM Placebo var_class character NULL NULL + 4 ARM Placebo var_type categorical NULL NULL + 5 ARM Placebo var_nlevels 3 NULL NULL + 6 ARM Placebo contrasts contr.treatment NULL NULL + 7 ARM Placebo contrasts_type treatment NULL NULL + 8 ARM Placebo reference_row TRUE NULL NULL + 9 ARM Placebo label Placebo NULL NULL + 10 ARM Placebo n_obs 86 NULL NULL + 11 ARM Placebo estimate 0 NULL NULL + 12 ARM Xanomeline High Dose term ARMXanomeline High Dose NULL NULL + 13 ARM Xanomeline High Dose var_label Description of Planned Arm NULL NULL + 14 ARM Xanomeline High Dose var_class character NULL NULL + 15 ARM Xanomeline High Dose var_type categorical NULL NULL + 16 ARM Xanomeline High Dose var_nlevels 3 NULL NULL + 17 ARM Xanomeline High Dose contrasts contr.treatment NULL NULL + 18 ARM Xanomeline High Dose contrasts_type treatment NULL NULL + 19 ARM Xanomeline High Dose reference_row FALSE NULL NULL + 20 ARM Xanomeline High Dose label Xanomeline High Dose NULL NULL + 21 ARM Xanomeline High Dose n_obs 84 NULL NULL + 22 ARM Xanomeline High Dose estimate -0.828 NULL NULL + 23 ARM Xanomeline High Dose std.error 1.267 NULL NULL + 24 ARM Xanomeline High Dose statistic -0.654 NULL NULL + 25 ARM Xanomeline High Dose p.value 0.514 NULL NULL + 26 ARM Xanomeline High Dose conf.low -3.324 NULL NULL + 27 ARM Xanomeline High Dose conf.high 1.668 NULL NULL + 28 ARM Xanomeline Low Dose term ARMXanomeline Low Dose NULL NULL + 29 ARM Xanomeline Low Dose var_label Description of Planned Arm NULL NULL + 30 ARM Xanomeline Low Dose var_class character NULL NULL + 31 ARM Xanomeline Low Dose var_type categorical NULL NULL + 32 ARM Xanomeline Low Dose var_nlevels 3 NULL NULL + 33 ARM Xanomeline Low Dose contrasts contr.treatment NULL NULL + 34 ARM Xanomeline Low Dose contrasts_type treatment NULL NULL + 35 ARM Xanomeline Low Dose reference_row FALSE NULL NULL + 36 ARM Xanomeline Low Dose label Xanomeline Low Dose NULL NULL + 37 ARM Xanomeline Low Dose n_obs 84 NULL NULL + 38 ARM Xanomeline Low Dose estimate 0.457 NULL NULL + 39 ARM Xanomeline Low Dose std.error 1.267 NULL NULL + 40 ARM Xanomeline Low Dose statistic 0.361 NULL NULL + 41 ARM Xanomeline Low Dose p.value 0.719 NULL NULL + 42 ARM Xanomeline Low Dose conf.low -2.039 NULL NULL + 43 ARM Xanomeline Low Dose conf.high 2.953 NULL NULL # ard_regression() works specifying custom tidier Code - dplyr::mutate(dplyr::filter(dplyr::select(as.data.frame(ard_regression(lme4::lmer( - mpg ~ hp + (1 | cyl), data = mtcars), tidy_fun = broom.mixed::tidy)), - -context, -stat_label, -fmt_fn), map_lgl(stat, is.numeric)), stat = lapply(stat, - function(x) ifelse(is.numeric(x), cards::round5(x, 3), x))) + dplyr::mutate(dplyr::filter(dplyr::select(as.data.frame(ard_regression(lme4::lmer(mpg ~ + hp + (1 | cyl), data = mtcars), tidy_fun = broom.mixed::tidy)), -context, -stat_label, + -fmt_fn), map_lgl(stat, is.numeric)), stat = lapply(stat, function(x) ifelse(is.numeric(x), + cards::round5(x, 3), x))) Output - variable variable_level stat_name stat - 1 hp n_obs 32 - 2 hp estimate -0.03 - 3 hp std.error 0.015 - 4 hp statistic -2.088 - 5 hp conf.low -0.059 - 6 hp conf.high -0.002 - 7 cyl.sd__(Intercept) cyl.sd__(Intercept) estimate 4.023 - 8 Residual.sd__Observation Residual.sd__Observation estimate 3.149 + variable variable_level stat_name stat warning error + 1 hp n_obs 32 NULL NULL + 2 hp estimate -0.03 NULL NULL + 3 hp std.error 0.015 NULL NULL + 4 hp statistic -2.088 NULL NULL + 5 hp conf.low -0.059 NULL NULL + 6 hp conf.high -0.002 NULL NULL + 7 cyl.sd__(Intercept) cyl.sd__(Intercept) estimate 4.023 NULL NULL + 8 Residual.sd__Observation Residual.sd__Observation estimate 3.149 NULL NULL + +# ard_regression() warnings and errors return correctly + + Code + as.data.frame(ard_regression(mod)) + Output + variable context stat_name stat_label stat fmt_fn + 1 model_1 regression estimate Coefficient NULL NULL + warning + 1 Could not access test statistic of model parameters., Could not access test statistic of model parameters. + error + 1 Error: ! Unable to tidy `x`. diff --git a/tests/testthat/_snaps/ard_regression_basic.md b/tests/testthat/_snaps/ard_regression_basic.md index 717ce00ee..7e0b6c346 100644 --- a/tests/testthat/_snaps/ard_regression_basic.md +++ b/tests/testthat/_snaps/ard_regression_basic.md @@ -3,17 +3,17 @@ Code dplyr::select(as.data.frame(ard), -fmt_fn) Output - variable variable_level context stat_name stat_label stat - 1 ARM Xanomeline High Dose regression estimate Coefficient -0.8283499 - 2 ARM Xanomeline High Dose regression std.error Standard Error 1.267394 - 3 ARM Xanomeline High Dose regression statistic statistic -0.653585 - 4 ARM Xanomeline High Dose regression p.value p-value 0.5139775 - 5 ARM Xanomeline High Dose regression conf.low CI Lower Bound -3.324433 - 6 ARM Xanomeline High Dose regression conf.high CI Upper Bound 1.667733 - 7 ARM Xanomeline Low Dose regression estimate Coefficient 0.4573643 - 8 ARM Xanomeline Low Dose regression std.error Standard Error 1.267394 - 9 ARM Xanomeline Low Dose regression statistic statistic 0.3608698 - 10 ARM Xanomeline Low Dose regression p.value p-value 0.7185003 - 11 ARM Xanomeline Low Dose regression conf.low CI Lower Bound -2.038718 - 12 ARM Xanomeline Low Dose regression conf.high CI Upper Bound 2.953447 + variable variable_level context stat_name stat_label stat warning error + 1 ARM Xanomeline High Dose regression estimate Coefficient -0.8283499 NULL NULL + 2 ARM Xanomeline High Dose regression std.error Standard Error 1.267394 NULL NULL + 3 ARM Xanomeline High Dose regression statistic statistic -0.653585 NULL NULL + 4 ARM Xanomeline High Dose regression p.value p-value 0.5139775 NULL NULL + 5 ARM Xanomeline High Dose regression conf.low CI Lower Bound -3.324433 NULL NULL + 6 ARM Xanomeline High Dose regression conf.high CI Upper Bound 1.667733 NULL NULL + 7 ARM Xanomeline Low Dose regression estimate Coefficient 0.4573643 NULL NULL + 8 ARM Xanomeline Low Dose regression std.error Standard Error 1.267394 NULL NULL + 9 ARM Xanomeline Low Dose regression statistic statistic 0.3608698 NULL NULL + 10 ARM Xanomeline Low Dose regression p.value p-value 0.7185003 NULL NULL + 11 ARM Xanomeline Low Dose regression conf.low CI Lower Bound -2.038718 NULL NULL + 12 ARM Xanomeline Low Dose regression conf.high CI Upper Bound 2.953447 NULL NULL diff --git a/tests/testthat/_snaps/construction_helpers.md b/tests/testthat/_snaps/construction_helpers.md index 28b251036..3d316217e 100644 --- a/tests/testthat/_snaps/construction_helpers.md +++ b/tests/testthat/_snaps/construction_helpers.md @@ -5,13 +5,13 @@ mtcars, `M P G` = mpg), formula = reformulate2(c("M P G", "cyl"), response = "hp"), method = "lm"))), stat_name %in% c("term", "estimate", "p.value")) Output - variable context stat_name stat_label stat fmt_fn - 1 M P G regression term term `M P G` NULL - 2 M P G regression estimate Coefficient -2.774769 1 - 3 M P G regression p.value p-value 0.2125285 1 - 4 cyl regression term term cyl NULL - 5 cyl regression estimate Coefficient 23.97863 1 - 6 cyl regression p.value p-value 0.002814958 1 + variable context stat_name stat_label stat fmt_fn warning error + 1 M P G regression term term `M P G` NULL NULL NULL + 2 M P G regression estimate Coefficient -2.774769 1 NULL NULL + 3 M P G regression p.value p-value 0.2125285 1 NULL NULL + 4 cyl regression term term cyl NULL NULL NULL + 5 cyl regression estimate Coefficient 23.97863 1 NULL NULL + 6 cyl regression p.value p-value 0.002814958 1 NULL NULL # construct_model() messaging diff --git a/tests/testthat/test-ard_regression.R b/tests/testthat/test-ard_regression.R index e5fb7658e..a547481f0 100644 --- a/tests/testthat/test-ard_regression.R +++ b/tests/testthat/test-ard_regression.R @@ -1,6 +1,8 @@ skip_if_not(is_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx")) test_that("ard_regression() works", { + withr::local_options(list(width = 90)) + expect_snapshot( lm(AGE ~ ARM, data = cards::ADSL) |> ard_regression(add_estimate_to_reference_rows = TRUE) |> @@ -23,6 +25,8 @@ test_that("ard_regression() works", { test_that("ard_regression() works specifying custom tidier", { skip_if_not(is_pkg_installed(pkg = c("lme4", "broom.mixed"), reference_pkg = "cardx")) + withr::local_options(list(width = 90)) + expect_snapshot( lme4::lmer(mpg ~ hp + (1 | cyl), data = mtcars) |> ard_regression(tidy_fun = broom.mixed::tidy) |> @@ -38,3 +42,14 @@ test_that("ard_regression() works specifying custom tidier", { test_that("ard_regression() does not produce `variable_level` column where not applicable", { expect_true(!"variable_level" %in% names(lm(mpg ~ hp, mtcars) |> ard_regression())) }) + +test_that("ard_regression() warnings and errors return correctly", { + mod <- lm(AGE ~ ARM, data = cards::ADSL) + mod$coefficients <- NULL + + expect_snapshot( + mod |> + ard_regression() |> + as.data.frame() + ) +}) diff --git a/tests/testthat/test-ard_regression_basic.R b/tests/testthat/test-ard_regression_basic.R index 487426348..e9de71ffc 100644 --- a/tests/testthat/test-ard_regression_basic.R +++ b/tests/testthat/test-ard_regression_basic.R @@ -1,6 +1,8 @@ skip_if_not(do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))) test_that("ard_regression_basic() works", { + withr::local_options(list(width = 100)) + expect_error( ard <- lm(AGE ~ ARM, data = cards::ADSL) |> ard_regression_basic(),