Mice nnet

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gtsummary
 Title: Presentation-Ready Data Summary and Analytic Result
     Tables
-Version: 1.3.5.9006
+Version: 1.3.5.9007
 Authors@R: 
     c(person(given = "Daniel D.",
              family = "Sjoberg",
@@ -60,7 +60,7 @@ Depends:
     R (>= 3.4)
 Imports: 
     broom (>= 0.7.0),
-    broom.helpers  (>= 1.0.0),
+    broom.helpers  (>= 1.0.0.9000),
     dplyr (>= 1.0.1),
     forcats (>= 0.5.0),
     glue (>= 1.4.1),
@@ -84,6 +84,7 @@ Suggests:
     huxtable (>= 5.0.0),
     kableExtra,
     lme4,
+    mice,
     officer,
     parameters,
     pkgdown,

NAMESPACE

@@ -27,6 +27,9 @@ S3method(print,gtsummary)
 S3method(tbl_regression,default)
 S3method(tbl_regression,glmerMod)
 S3method(tbl_regression,lmerMod)
+S3method(tbl_regression,mipo)
+S3method(tbl_regression,mira)
+S3method(tbl_regression,multinom)
 S3method(tbl_regression,survreg)
 S3method(tbl_survfit,data.frame)
 S3method(tbl_survfit,list)
@@ -85,6 +88,7 @@ export(modify_table_body)
 export(modify_table_header)
 export(num_range)
 export(one_of)
+export(pool_and_tidy_mice)
 export(reset_gtsummary_theme)
 export(select)
 export(set_gtsummary_theme)

NEWS.md

@@ -1,5 +1,7 @@
 # gtsummary (development version)
 
+* Multiple imputation models created with {mice}, and multinomial regression models created with {nnet} are now supported in `tbl_regression()` (#645)
+
 * Added warning message to users when they pass a data frame to `tbl_uvregression(data=)` with column names containing spaces or special characters ( #686)
 
 * Updates to `add_global_p.tbl_regression()` allowing for variable names with spaces and special characters (#682)

R/custom_tidiers.R

@@ -18,11 +18,18 @@
 #' The tidier uses the output from `parameters::bootstrap_parameters(test = "p")`, and
 #' merely takes the result and puts it in `broom::tidy()` format.
 #'
+#' - `pool_and_tidy_mice()` tidier to report models resulting from multiply imputed data
+#' using the mice package. Pass the mice model object *before* the model results
+#' have been pooled. See example.
+#'
 #' Ensure your model type is compatible with the methods/functions used to estimate
 #' the model parameters before attempting to use the tidier with `tbl_regression()`
 #' @inheritParams broom::tidy.glm
 #' @inheritParams add_global_p.tbl_regression
+#' @param pool.args named list of arguments passed to `mice::pool()` in
+#' `pool_and_tidy_mice()`. Default is `NULL`
 #' @param ... arguments passed to method;
+#' - `pool_and_tidy_mice()`: `mice::tidy(x, ...)`
 #' - `tidy_standardize()`: `effectsize::standardize_parameters(x, ...)`
 #' - `tidy_bootstrap()`: `parameters::bootstrap_parameters(x, ...)`
 #'
@@ -50,8 +57,11 @@
 #'
 #'
 #' # Example 3 ----------------------------------
-#' tidy_bootstrap_ex3 <-
-#'   tbl_regression(mod, tidy_fun = tidy_bootstrap)
+#' # Multiple Imputation using the mice package
+#' pool_and_tidy_mice_ex3 <-
+#'   suppressWarnings(mice::mice(trial, m = 2)) %>%
+#'   with(lm(age ~ marker + grade)) %>%
+#'   tbl_regression() # mice method called that uses `pool_and_tidy_mice()` as tidier
 #'
 #' @section Example Output:
 #' \if{html}{Example 1}
@@ -64,19 +74,19 @@
 #'
 #' \if{html}{Example 3}
 #'
-#' \if{html}{\figure{tidy_bootstrap_ex3.png}{options: width=47\%}}
+#' \if{html}{\figure{pool_and_tidy_mice_ex3.png}{options: width=47\%}}
 
 tidy_standardize <- function(x, exponentiate = FALSE,
                              conf.level = 0.95,
                              conf.int = TRUE,
-                             quiet = FALSE, ...) {
+                             ..., quiet = FALSE) {
   assert_package("effectsize", "tidy_standardize")
   dots <- list(...)
 
   # calculating standardize coefs
   std_coef_expr <- expr(effectsize::standardize_parameters(model = x, ci = !!conf.level, !!!dots))
   if (quiet == FALSE)
-    inform(glue("tidy_standardize: Estimating standardized coefs with\n  `{deparse(std_coef_expr)}`"))
+    inform(glue("tidy_standardize: Estimating standardized coefs with\n  `{deparse(std_coef_expr, width.cutoff = 500L)}`"))
   std_coef <-
     expr(effectsize::standardize_parameters(model = !!x, ci = !!conf.level, !!!dots)) %>%
     eval()
@@ -109,7 +119,7 @@ tidy_bootstrap <- function(x, exponentiate = FALSE,
   # calculating bootstrapped coefs
   boot_coef_expr <- expr(parameters::bootstrap_parameters(model = x, ci = !!conf.level, test = "p", !!!dots))
   if (quiet == FALSE)
-    inform(glue("tidy_bootstrap: Estimating bootstrapped coefs with\n  `{deparse(boot_coef_expr)}`"))
+    inform(glue("tidy_bootstrap: Estimating bootstrapped coefs with\n  `{deparse(boot_coef_expr, width.cutoff = 500L)}`"))
   boot_coef <-
     expr(parameters::bootstrap_parameters(model = !!x, ci = !!conf.level, test = "p", !!!dots)) %>%
     eval()
@@ -130,3 +140,20 @@ tidy_bootstrap <- function(x, exponentiate = FALSE,
 
   tidy
 }
+
+#' @rdname custom_tidiers
+#' @export
+pool_and_tidy_mice <- function(x, pool.args = NULL, ..., quiet = FALSE) {
+  assert_package("mice", "pool_and_tidy_mice")
+  if(!inherits(x, "mira")) stop("Object `x=` must be of class 'mira'.", call. = FALSE)
+
+  dots <- list(...)
+
+  # printing code that will run
+  mice_expr <- expr(mice::pool(x, !!!pool.args) %>% mice::tidy(!!!dots))
+  if (quiet == FALSE)
+    inform(glue("pool_and_tidy_mice: Tidying mice model with\n  `{deparse(mice_expr, width.cutoff = 500L)}`"))
+
+  # evaluating tidy expression
+  expr(mice::pool(!!x, !!!pool.args) %>% mice::tidy(!!!dots)) %>% eval()
+}

R/tbl_regression.R

@@ -15,7 +15,7 @@
 #'
 #' - `"lmerMod"` or `"glmerMod"`: These mixed effects models use `broom.mixed::tidy(x, effects = "fixed")`
 #' - `"survreg"`: The scale parameter is removed, `broom::tidy(x) %>% dplyr::filter(term != "Log(scale)")`
-#' - `"multinom"`: This multinomial outcome is complex, and the returned object is a `tbl_stack()` object with the parameters for each outcome stacked into a final object
+#' - `"multinom"`: This multinomial outcome is complex, with one line per covariate per outcome (less the reference group)
 #'
 #' @section Note:
 #' The N reported in the output is the number of observations
@@ -193,7 +193,7 @@ tbl_regression.default <- function(x, label = NULL, exponentiate = FALSE,
   table_body <- table_body %>% filter(.data$variable %in% include)
 
   # model N
-  n <- table_body$N[1]
+  n <- pluck(table_body, "N", 1)
 
   # adding character CI
   if (all(c("conf.low", "conf.high") %in% names(table_body))) {

R/tbl_regression_methods.R

@@ -1,7 +1,7 @@
 #' @title Methods for tbl_regression
 #'
-#' @description Most regression models are handled by [tbl_regression.default],
-#' which uses [broom::tidy] to perform initial tidying of results. There are,
+#' @description Most regression models are handled by [tbl_regression.default()],
+#' which uses [broom::tidy()] to perform initial tidying of results. There are,
 #' however, some model types that have modified default printing behavior.
 #' Those methods are listed below.
 #'
@@ -31,3 +31,50 @@ tbl_regression.survreg <- function(
   x, tidy_fun = function(x, ...) broom::tidy(x, ...) %>% dplyr::filter(.data$term != "Log(scale)"), ...) {
   tbl_regression.default(x = x, tidy_fun = tidy_fun, ...)
 }
+
+#' @export
+#' @rdname tbl_regression_methods
+tbl_regression.mira <- function(x, tidy_fun = pool_and_tidy_mice, ...) {
+  tbl_regression.default(x = x, tidy_fun = tidy_fun, ...)
+}
+
+#' @export
+#' @rdname tbl_regression_methods
+tbl_regression.mipo <- function(x, ...) {
+  paste("Please pass the 'mice' model to {ui_code('tbl_regression()')} before ",
+        "models have been combined with {ui_code('mice::pool()')}.",
+        "The default tidier, {ui_code('pool_and_tidy_mice()')}, ","
+        will both pool and tidy the regression model.") %>%
+    stringr::str_wrap() %>%
+    usethis::ui_oops()
+  paste("\n\nmice::mice(trial, m = 2) %>%",
+        "with(lm(age ~ marker + grade)) %>%",
+        "tbl_regression()", sep = "\n") %>%
+    usethis::ui_code_block()
+}
+
+#' @export
+#' @rdname tbl_regression_methods
+tbl_regression.multinom <- function(x, ...) {
+  result <- tbl_regression.default(x = x, ...)
+
+  # adding a grouped header for the outcome levels
+  result$table_body <-
+    result$table_body %>%
+    mutate(groupname_col = .data$y.level) %>%
+    select(.data$groupname_col, everything()) %>%
+    group_by(.data$groupname_col)
+  result$table_header <-
+    table_header_fill_missing(result$table_header, result$table_body)
+
+  # warning about multi-nomial models
+  paste("Multinomial models have a different underlying structure than",
+        "the models gtsummary was designed for.",
+        "Other gtsummary functions designed to work with",
+        "{usethis::ui_field('tbl_regression')} objects may yield unexpected",
+        "results.") %>%
+    str_wrap() %>%
+    usethis::ui_info()
+
+  result
+}

R/utils-tbl_regression.R

@@ -96,17 +96,10 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label,
 gtsummary_model_frame <- function(x) {
   tryCatch(stats::model.frame(x),
   error = function(e) {
-    ui_oops(paste0(
-      "There was an error calling {ui_code('stats::model.frame(x)')}.\n\n",
-      "Most likely, this is because the argument passed in {ui_code('x =')} ",
-      "was\nmisspelled, does not exist, or is not a regression model.\n\n",
-      "Rarely, this error may occur if the model object was created within\na ",
-      "functional programming framework (e.g. using {ui_code('lappy()')}, ",
-      "{ui_code('purrr::map()')}, etc.).\n",
-      "Review the GitHub issue linked below for a possible solution.\n",
-      "The model N will not be available in the output."
-    ))
-    ui_code_block("https://github.com/ddsjoberg/gtsummary/issues/231")
+    paste("There was an error calling {usethis::ui_code('stats::model.frame(x)')},",
+          "and the model N will not be available in the output.") %>%
+      stringr::str_wrap() %>%
+      usethis::ui_oops()
     data.frame()
   }
   )
@@ -126,7 +119,6 @@ gtsummary_model_frame <- function(x) {
       hide = FALSE
     )
 
-
   # estimate -------------------------------------------------------------------
   if ("estimate" %in% names(x$table_body))
     x <- modify_table_header(