|
| 1 | +#' Create a Publication-Ready Table for Pooled Model Results |
| 2 | +#' |
| 3 | +#' @description |
| 4 | +#' This function takes a pooled model object from the `mice` package and creates a |
| 5 | +#' publication-ready HTML table of the model's effect estimates (e.g., odds |
| 6 | +#' ratios, hazard ratios). |
| 7 | +#' |
| 8 | +#' It can produce two types of tables: |
| 9 | +#' 1. A **"fallacy-safe"** table (`fallacy_safe = TRUE`), which displays only the |
| 10 | +#' results for the main exposure variable and lists all adjustment |
| 11 | +#' variables in a footnote. This helps prevent the misinterpretation of |
| 12 | +#' statistics for covariates. |
| 13 | +#' 2. A **full table** (`fallacy_safe = FALSE`), which displays results for all |
| 14 | +#' variables in the model, grouped by variable name. |
| 15 | +#' |
| 16 | +#' @details |
| 17 | +#' The function processes a `mipo` object (the result of `mice::pool()`). It |
| 18 | +#' exponentiates the estimates, calculates 95% confidence intervals, and |
| 19 | +#' formats the results into a clean HTML table using `knitr::kable()` and |
| 20 | +#' `kableExtra`. P-values are formatted to three decimal places, with values |
| 21 | +#' less than 0.001 shown as "<0.001". |
| 22 | +#' |
| 23 | +#' @param pooled_model A `mipo` object resulting from `mice::pool()`. This contains |
| 24 | +#' the pooled results from analyses on multiply imputed datasets. |
| 25 | +#' @param main_exposure A character string specifying the name of the main exposure |
| 26 | +#' variable in the model. The function uses this to identify which variable's |
| 27 | +#' results to show in the "fallacy-safe" mode. |
| 28 | +#' @param adj_var_names A character vector of the names of all adjustment |
| 29 | +#' variables (covariates) included in the model. |
| 30 | +#' @param measure A character string for the column header of the effect |
| 31 | +#' measure (e.g., "OR", "HR", "RR"). Defaults to "OR". |
| 32 | +#' @param title A character string for the table's caption. |
| 33 | +#' @param fallacy_safe A logical value. If `TRUE` (the default), the function |
| 34 | +#' returns a table showing only the main exposure and lists covariates in a |
| 35 | +#' footnote. If `FALSE`, it returns a full table with all model terms. |
| 36 | +#' |
| 37 | +#' @return An HTML table object of class `kableExtra`. This object can be |
| 38 | +#' printed directly in R Markdown documents or saved. |
| 39 | +#' |
| 40 | +#' @importFrom dplyr select mutate case_when |
| 41 | +#' @importFrom stringr str_extract str_remove |
| 42 | +#' @importFrom knitr kable |
| 43 | +#' @importFrom kableExtra kable_styling pack_rows footnote |
| 44 | +#' |
| 45 | +#' @export |
| 46 | +#' |
| 47 | +#' @examples |
| 48 | +#' \dontrun{ |
| 49 | +#' # Load required packages for the example |
| 50 | +#' library(mice) |
| 51 | +#' library(dplyr) |
| 52 | +#' library(survey) |
| 53 | +#' library(NHANES) |
| 54 | +#' |
| 55 | +#' # --- 1. Data Preparation --- |
| 56 | +#' # We'll prepare a clean analytic dataset from the raw NHANES data. |
| 57 | +#' # Note: We convert the outcome 'Obese' to a numeric 0/1 variable for svyglm. |
| 58 | +#' data(NHANESraw, package = "NHANES") |
| 59 | +#' nhanes_analytic <- NHANESraw %>% |
| 60 | +#' filter(Age >= 20 & WTMEC2YR > 0) %>% |
| 61 | +#' mutate( |
| 62 | +#' Obese_numeric = ifelse(BMI >= 30, 1, 0), |
| 63 | +#' AgeCat = cut(Age, breaks = c(19, 39, 59, 80), labels = c("20-39", "40-59", "60-80")), |
| 64 | +#' Smoke100 = factor(Smoke100, levels = c("No", "Yes")) |
| 65 | +#' ) %>% |
| 66 | +#' select(Obese_numeric, AgeCat, Smoke100, Education, SDMVPSU, SDMVSTRA, WTMEC2YR) |
| 67 | +#' |
| 68 | +#' # --- 2. Perform Imputation and Pooled Analysis --- |
| 69 | +#' # Set survey option to handle lonely PSUs, a common issue with NHANES data. |
| 70 | +#' options(survey.lonely.psu = "adjust") |
| 71 | +#' |
| 72 | +#' # Impute the analytic dataset |
| 73 | +#' imputed_data <- mice(nhanes_analytic, m = 2, maxit = 2, seed = 123, printFlag = FALSE) |
| 74 | +#' |
| 75 | +#' # Use with() to run a survey-weighted GLM on each imputed dataset |
| 76 | +#' fit_imputed <- with(imputed_data, |
| 77 | +#' svyglm(Obese_numeric ~ Smoke100 + AgeCat + Education, |
| 78 | +#' design = svydesign(id = ~SDMVPSU, strata = ~SDMVSTRA, |
| 79 | +#' weights = ~WTMEC2YR, nest = TRUE, data = .data), |
| 80 | +#' family = quasibinomial()) |
| 81 | +#' ) |
| 82 | +#' |
| 83 | +#' # Pool the results from all models into a single 'mipo' object |
| 84 | +#' pooled_results <- pool(fit_imputed) |
| 85 | +#' |
| 86 | +#' # --- 3. Generate Tables with svypooled --- |
| 87 | +#' # Example A: Create a "fallacy-safe" table (default) |
| 88 | +#' svypooled( |
| 89 | +#' pooled_model = pooled_results, |
| 90 | +#' main_exposure = "Smoke100", |
| 91 | +#' adj_var_names = c("AgeCat", "Education"), |
| 92 | +#' measure = "OR", |
| 93 | +#' title = "Adjusted Odds of Obesity (Fallacy-Safe)" |
| 94 | +#' ) |
| 95 | +#' |
| 96 | +#' # Example B: Create a full table with all variables |
| 97 | +#' svypooled( |
| 98 | +#' pooled_model = pooled_results, |
| 99 | +#' main_exposure = "Smoke100", |
| 100 | +#' adj_var_names = c("AgeCat", "Education"), |
| 101 | +#' measure = "OR", |
| 102 | +#' title = "Adjusted Odds of Obesity (Full Table for Appendix)", |
| 103 | +#' fallacy_safe = FALSE |
| 104 | +#' ) |
| 105 | +#' } |
| 106 | +svypooled <- function(pooled_model, |
| 107 | + main_exposure, |
| 108 | + adj_var_names, |
| 109 | + measure = "OR", |
| 110 | + title = "Adjusted Model Results", |
| 111 | + fallacy_safe = TRUE) { |
| 112 | + |
| 113 | + # Ensure required packages are available |
| 114 | + if (!requireNamespace("dplyr", quietly = TRUE)) stop("Package 'dplyr' is required.") |
| 115 | + if (!requireNamespace("knitr", quietly = TRUE)) stop("Package 'knitr' is required.") |
| 116 | + if (!requireNamespace("kableExtra", quietly = TRUE)) stop("Package 'kableExtra' is required.") |
| 117 | + if (!requireNamespace("stringr", quietly = TRUE)) stop("Package 'stringr' is required.") |
| 118 | + |
| 119 | + # Get a summary data frame, removing the intercept |
| 120 | + summary_df <- summary(pooled_model, conf.int = TRUE, exponentiate = TRUE) |
| 121 | + summary_df <- summary_df[summary_df$term != "(Intercept)", ] |
| 122 | + |
| 123 | + # Combine all variable names for parsing |
| 124 | + all_vars <- c(main_exposure, adj_var_names) |
| 125 | + pattern <- paste(all_vars, collapse = "|") |
| 126 | + |
| 127 | + processed_results <- summary_df %>% |
| 128 | + dplyr::select(term, estimate, conf.low, conf.high, p.value) %>% |
| 129 | + dplyr::mutate( |
| 130 | + group = stringr::str_extract(term, pattern), |
| 131 | + Characteristic = stringr::str_remove(term, pattern), |
| 132 | + Estimate_CI = sprintf("%.2f (%.2f, %.2f)", estimate, conf.low, conf.high), |
| 133 | + p_value_formatted = dplyr::case_when( |
| 134 | + p.value < 0.001 ~ "<0.001", |
| 135 | + TRUE ~ sprintf("%.3f", p.value) |
| 136 | + ) |
| 137 | + ) %>% |
| 138 | + dplyr::select(group, Characteristic, Estimate_CI, p_value_formatted) |
| 139 | + |
| 140 | + # Conditionally filter for fallacy-safe output |
| 141 | + if (fallacy_safe) { |
| 142 | + if (!main_exposure %in% processed_results$group) { |
| 143 | + stop(paste("Main exposure '", main_exposure, "' not found in model terms.", sep = "")) |
| 144 | + } |
| 145 | + results_to_display <- processed_results %>% dplyr::filter(group == main_exposure) |
| 146 | + footnote_text <- paste("Adjusted for:", paste(adj_var_names, collapse = ", ")) |
| 147 | + } else { |
| 148 | + results_to_display <- processed_results |
| 149 | + } |
| 150 | + |
| 151 | + # Create the final HTML table using a single pipe chain for robustness |
| 152 | + final_table <- knitr::kable( |
| 153 | + results_to_display[, -1], # Remove helper 'group' column |
| 154 | + col.names = c("Characteristic", paste(measure, "(95% CI)"), "p-value"), |
| 155 | + align = "lcc", |
| 156 | + caption = title, |
| 157 | + row.names = FALSE, |
| 158 | + format = "html" # Explicitly set format for kableExtra |
| 159 | + ) %>% |
| 160 | + kableExtra::kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) %>% |
| 161 | + { |
| 162 | + # Use curly braces for conditional piping logic |
| 163 | + if (!fallacy_safe) { |
| 164 | + # For the full table, group rows by variable name |
| 165 | + kableExtra::pack_rows(., index = table(factor(results_to_display$group, levels = all_vars))) |
| 166 | + } else { |
| 167 | + # For the fallacy-safe table, add a single header for the main exposure |
| 168 | + kableExtra::pack_rows(., main_exposure, 1, nrow(results_to_display)) |
| 169 | + } |
| 170 | + } %>% |
| 171 | + { |
| 172 | + if (fallacy_safe) { |
| 173 | + # Add footnote only in fallacy-safe mode |
| 174 | + kableExtra::footnote(., general = footnote_text, footnote_as_chunk = TRUE, general_title = " ") |
| 175 | + } else { |
| 176 | + . # Pass the table through unchanged if not fallacy_safe |
| 177 | + } |
| 178 | + } |
| 179 | + |
| 180 | + return(final_table) |
| 181 | +} |
0 commit comments