group = model ~ term

Author: vincentarelbundock

R/modelsummary.R

@@ -70,11 +70,15 @@ globalVariables(c('.', 'term', 'part', 'estimate', 'conf.high', 'conf.low',
 #' * list of lists, each of which includes 3 elements named "raw", "clean", "fmt". Unknown statistics are omitted. See the 'Examples section below'.
 #' @param gof_omit string regular expression. Omits all matching gof statistics from
 #' the table (using `grepl(perl=TRUE)`).
-#' @param group a two-sided formula with three components: "term", "model", and
-#' a parameter group identifier (e.g., outcome levels of a multinomial logit
-#' model). Example: `term+groupid~model` The group identifier must be the name
-#' of a column in the data.frame produced by `get_estimates(model)`. The
-#' "term" component must be on the left-hand side of the formula.
+#' @param group a two-sided formula with two or three components which describes
+#' how groups of parameters should be displayed. The formula msut include both
+#' a "term" and a "model" component. In addition, a component can be used to
+#' identify groups of parameters (e.g., outcome levels of a multinomial logit
+#' model). This group identifier must be the name of a column in the
+#' data.frame produced by `get_estimates(model)`.
+#' * `term ~ model` displays coefficients as rows and models as columns
+#' * `model ~ term` displays models as rows and coefficients as columns
+#' * `response + term ~ model` displays response levels and coefficients as rows and models as columns.
 #' @param group_map named or unnamed character vector. Subset, rename, and
 #' reorder coefficient groups specified in the `group` argument. See `coef_map`.
 #' @param add_rows a data.frame (or tibble) with the same number of columns as
@@ -274,7 +278,7 @@ modelsummary <- function(
   coef_rename = NULL,
   gof_map     = NULL,
   gof_omit    = NULL,
-  group       = NULL,
+  group       = term ~ model,
   group_map   = NULL,
   add_rows    = NULL,
   align       = NULL,
@@ -368,7 +372,6 @@ modelsummary <- function(
 
   }
 
-
   term_order <- unique(unlist(lapply(est, function(x) x$term)))
   group_order <- unique(unlist(lapply(est, function(x) x$group)))
 
@@ -386,34 +389,43 @@ modelsummary <- function(
   est[is.na(est)] <- ""
 
   # sort rows using factor trick
-  if (!is.null(coef_map)) {
-    term_order <- coef_map
-    est$term <- factor(est$term, unique(term_order))
-  } else {
-    est$term <- factor(est$term, unique(term_order))
-  }
+  if ("term" %in% colnames(est)) {
+    if (!is.null(coef_map)) {
+        term_order <- coef_map
+        est$term <- factor(est$term, unique(term_order))
+    } else {
+        est$term <- factor(est$term, unique(term_order))
+    }
 
-  if (!is.null(group_map)) {
-    group_order <- group_map
-    est$group <- factor(est$term, group_order)
-  } else {
-    est$group <- factor(est$group, unique(est$group))
+    if (!is.null(group_map)) {
+        group_order <- group_map
+        est$group <- factor(est$term, group_order)
+    } else {
+        est$group <- factor(est$group, unique(est$group))
+    }
+
+  } else if ("model" %in% colnames(est)) {
+    est$model <- factor(est$model, model_names)
   }
 
   est <- est[do.call(order, as.list(est)), ]
 
   # character for binding
-  est$term <- as.character(est$term)
-  est$group <- as.character(est$group)
+  for (col in c("term", "group", "model")) {
+    if (col %in% colnames(est)) {
+      est[[col]] <- as.character(est[[col]])
+    }
+  }
 
   # group duplicates
-  idx <- paste(as.character(est$term), est$statistic)
-  if (is.null(group) && anyDuplicated(idx) > 0) {
-    warning('The table includes duplicate term names. This can sometimes happen when a model produces "grouped" terms, such as in a multinomial logit or a gamlss model. Consider using the the `group` argument.')
+  if ("term" %in% colnames(est)) {
+    idx <- paste(as.character(est$term), est$statistic)
+    if (is.null(group) && anyDuplicated(idx) > 0) {
+        warning('The table includes duplicate term names. This can sometimes happen when a model produces "grouped" terms, such as in a multinomial logit or a gamlss model. Consider using the the `group` argument.')
+    }
   }
 
 
-
   #####################
   #  goodness-of-fit  #
   #####################
@@ -440,7 +452,6 @@ modelsummary <- function(
   }
 
 
-
   ##################
   #  output table  #
   ##################
@@ -449,11 +460,11 @@ modelsummary <- function(
   tab[is.na(tab)] <- ''
 
   # interaction : becomes ×
-  if (is.null(coef_map)) {
-    if (output_format != 'rtf') {
-      idx <- tab$part != 'gof'
-      tab$term <- ifelse(idx, gsub(':', ' \u00d7 ', tab$term), tab$term)
-    }
+  if (is.null(coef_map) &&
+      "term" %in% colnames(tab) &&
+      output_format != 'rtf') {
+    idx <- tab$part != 'gof'
+    tab$term <- ifelse(idx, gsub(':', ' \u00d7 ', tab$term), tab$term)
   }
 
   # measure table
@@ -494,8 +505,8 @@ modelsummary <- function(
   }
 
   # only show group label if it is a row-property (lhs of the group formula)
-  if (is.null(group) ||
-    group$group_name %in% group$rhs) {
+  tmp <- setdiff(group$lhs, c("model", "term"))
+  if (length(tmp) == 0) {
     tab$group <- NULL
   } else if (output_format != "dataframe") {
     colnames(tab)[colnames(tab) == "group"] <- "        "
@@ -593,6 +604,7 @@ map_omit_gof <- function(gof, gof_omit, gof_map) {
 
   # row identifier
   gof$part <- "gof"
+
   gof <- gof[, unique(c("part", "term", names(gof)))]
 
   # omit
@@ -634,12 +646,28 @@ map_omit_gof <- function(gof, gof_omit, gof_map) {
 #' @noRd
 group_reshape <- function(estimates, lhs, rhs, group_name) {
 
-    if (is.null(lhs)) return(estimates)
-
     lhs[lhs == group_name] <- "group"
     rhs[rhs == group_name] <- "group"
 
-    if (all(c("term", "group") %in% lhs)) {
+    # term ~ model (standard)
+    if (is.null(lhs) ||
+        (length(lhs) == 1 && lhs == "term" &&
+         length(rhs) == 1 && rhs == "model")) {
+      return(estimates)
+
+    # model ~ term 
+    } else if (length(lhs) == 1 && lhs == "model" &&
+        length(rhs) == 1 && rhs == "term") {
+      out <- tidyr::pivot_longer(estimates,
+                                 cols = -c("group", "term", "statistic"),
+                                 names_to = "model")
+      out <- tidyr::pivot_wider(out, names_from = "term")
+
+      # order matters for sorting
+      out <- out[, unique(c("group", "model", "statistic", colnames(out)))]
+
+    # term + group ~ model
+    } else if (all(c("term", "group") %in% lhs)) {
         idx <- unique(c(lhs, colnames(estimates)))
         out <- estimates[, idx, drop = FALSE]
 
@@ -660,7 +688,7 @@ group_reshape <- function(estimates, lhs, rhs, group_name) {
     } else if (all(c("group", "model") %in% rhs)) {
         out <- estimates
         out <- tidyr::pivot_longer(out,
-                                   cols = !any_of(c("part", "group", "term", "statistic")),
+                                   cols = !tidyselect::any_of(c("part", "group", "term", "statistic")),
                                    names_to = "model")
         out$idx_col <- paste(out[[rhs[1]]], "/", out[[rhs[2]]])
         out$model <- out$group <- NULL

R/sanitize_group.R

@@ -3,21 +3,45 @@
 #' @noRd
 sanitize_group <- function(group) {
 
-    if (is.null(group)) return(group)
+  flag_error <- FALSE
 
-    checkmate::assert_formula(group, null.ok = TRUE)
+  checkmate::assert_formula(group)
 
-    rhs <- all.vars(stats::update(group, "0 ~ ."))
-    lhs <- all.vars(stats::update(group, ". ~ 0"))
+  rhs <- all.vars(stats::update(group, "0 ~ ."))
+  lhs <- all.vars(stats::update(group, ". ~ 0"))
+  variables <- c(rhs, lhs)
+
+  if (!all(c("model", "term") %in% c(lhs, rhs))) {
+    flag_error <- TRUE
+  }
+
+  if (length(variables) != length(unique(variables))) {
+    flag_error <- TRUE
+  }
+
+  if (length(variables) > 3) {
+    flag_error <- TRUE
+  } else if (length(variables) == 2) {
+    group_name <- NULL
+  } else {
     group_name <- setdiff(c(lhs, rhs), c("term", "model"))
+  }
+
+  if (flag_error == TRUE) {
+    stop('The `group` argument must be a two-sided formula with two or three components. The formula must include a component named "term", which represents the parameters of the model. The formula must include a component named "model", which represents the different models being summarized. For example,
+
+model ~ term
+
+displays models as rows and parameter estimates as columns. Inverting the formula would display models as columns and terms as rows.
+
+The formula can also include a third, optional, component: a group identifier. In contrast to the "term" and "model" components, the name of the group identifier is not fixed. It must correspond to the name of a column in the data.frame produced by `get_estimates(model)`. For example, applying the `get_estimates` function to a multinomial logit model returns a column called "response", which identifies the parameters that correspond to each value of the responde variable:
+
+model + response ~ term')
+  }
 
-    if (!all(c("term", "model") %in% c(lhs, rhs)) ||
-        length(unique(c(lhs, rhs))) != 3) {
-        stop('The `group` argument must be a two-sided formula with three components: "term", "model", and a group identifier. The group identifier must be the name of a column in the data.frame produced by `get_estimates(model)`. The "term" component must be on the left-hand side of the formula. ')
-    }
+  out <- list("lhs" = lhs,
+              "rhs" = rhs,
+              "group_name" = group_name)
 
-    out <- list("lhs" = lhs,
-                "rhs" = rhs,
-                "group_name" = group_name)
-    return(out)
+  return(out)
 }

man/modelsummary.Rd

@@ -9,6 +9,17 @@ models[['Multivariate']] <- lm(Girth ~ Height + Volume, data = trees)
 models[["GAMLSS"]] <- gamlss(y~pb(x),sigma.fo=~pb(x),family=BCT, data=abdom, method=mixed(1,20), trace=FALSE)
 
 
+test_that("flipped table (no groups)", {
+    mod = list(
+    lm(hp ~ mpg, mtcars),
+    lm(hp ~ mpg + drat, mtcars))
+    tab = modelsummary(mod,
+                    output = "data.frame",
+                    group = model ~ term)
+    expect_true("model" %in% colnames(tab))
+})
+
+
 test_that("group: nnet::multinom", {
     skip_if_not_installed("nnet")