R/modelsummary_rbind.R

In vincentarelbundock/gtsummary: Summary Tables and Plots for Statistical Models and Data: Beautiful, Customizable, and Publication-Ready

#' Model summary tables, stacked in panels
#' 
#' Display the results from several statistical models in "panels": side-by-side
#' and stacked on top of each other. This function supports dozens of statistical
#' models, and it can produce tables in HTML, LaTeX, Word, Markdown, PDF,
#' PowerPoint, Excel, RTF, JPG, or PNG. The appearance of the tables can be
#' customized extensively by specifying the `output` argument, and by using
#' functions from one of the supported table customization packages:
#' `tinytable`, `kableExtra`, `gt`, `flextable`, `huxtable`, `DT`. For more information, see
#' the Details and Examples sections below, and the vignettes on the
#' `modelsummary` website:
#' https://modelsummary.com/
#' * [The `modelsummary` Vignette includes dozens of examples of tables with extensive customizations.](https://modelsummary.com/articles/modelsummary.html)
#' * [The Appearance Vignette shows how to modify the look of tables.](https://modelsummary.com/articles/appearance.html)
#'
#' @param panels a nested list of models
#' * Unnamed nested list with 2 panels: `list(list(model1, model2), list(model3, model4))`
#' * Named nested list with 2 panels: `list("Panel A" = list(model1, model2), "Panel B" = list(model3, model4))`
#' @inheritParams modelsummary
#' @keywords internal
#' @noRd
modelsummary_rbind <- function(
    panels,
    output      = "default",
    fmt         = 3,
    estimate    = "estimate",
    statistic   = "std.error",
    vcov        = NULL,
    conf_level  = 0.95,
    exponentiate = FALSE,
    stars       = FALSE,
    coef_map    = NULL,
    coef_omit   = NULL,
    coef_rename = FALSE,
    gof_map     = NULL,
    gof_omit    = NULL,
    gof_custom  = NULL,
    add_columns = NULL,
    add_rows    = NULL,
    align       = NULL,
    shape       = NULL,
    group_map   = NULL,
    notes       = NULL,
    title       = NULL,
    escape      = TRUE,
    ...) {

    settings_init(settings = list("function_called" = "modelsummary_rbind"))

    dots <- list(...)

    # sanity
    sanity_stars(stars)
    checkmate::assert_list(panels, min.len = 2)

    number_of_panels <- length(panels)

    for (i in seq_along(panels)) {
        panels[[i]] <- sanitize_models(panels[[i]], ...)
    }

    # need the settings for later -- before escape_string
    tmp <- sanitize_output(output)           # early
    output_format <- tmp$output_format
    output_factory <- tmp$output_factory
    output_file <- tmp$output_file
    sanitize_escape(escape)

    # panel names
    # model names dictionary: use unique names for manipulation
    if (is.null(names(panels))) {
        modelsummary_panel_labels <- getOption("modelsummary_panel_labels", default = "panel")
        checkmate::assert_choice(
            modelsummary_panel_labels,
            choices = c("panel", "arabic", "letters", "roman", "(arabic)", "(letters)", "(roman)"))
        if (modelsummary_panel_labels == "panel") {
            panel_names <- paste("Panel", LETTERS[1:number_of_panels])
        } else if (grepl("arabic", modelsummary_panel_labels)) {
            panel_names <- as.character(1:number_of_panels)
        } else if (grepl("letters", modelsummary_panel_labels)) {
            panel_names <- LETTERS[1:number_of_panels]
        } else if (grepl("roman", modelsummary_panel_labels)) {
            panel_names <- as.character(utils::as.roman(1:number_of_panels))
        }
        if (grepl("\\(", modelsummary_panel_labels)) {
            panel_names <- sprintf("(%s)", panel_names)
        }
    } else {
        panel_names <- names(panels)
    }
    panel_names <- pad(panel_names, output_format = output_format)

    # If there are no common model names but all the panels have the same number
    # of models, we make assumptions.
    len <- sapply(panels, length)
    if (isTRUE(length(unique(len)) == 1)) {
        int <- intersect(names(panels[[1]]), names(panels[[2]]))
        for (i in seq_along(panels)) {
            flag1 <- isTRUE(length(int) == 0)
            flag2 <- length(names(panels[[i]])) != length(names(panels[[i]]))
            if (flag1 || flag2) {
                names(panels[[i]]) <- sprintf("(%s)", seq_along(panels[[i]]))
            }
        }
    }

    # panel lists to tables
    panels_list <- list()
    for (i in seq_along(panels)) {
        # modelsummary(output="dataframe") changes the output format
        # reset for every call
        args <- utils::modifyList(
            dots,
            list(
                models = panels[[i]],
                output = "dataframe",
                fmt = fmt,
                estimate = estimate,
                statistic = statistic,
                vcov = vcov,
                conf_level = conf_level,
                exponentiate = exponentiate,
                stars = stars,
                coef_map = coef_map,
                coef_omit = coef_omit,
                coef_rename = coef_rename,
                shape = term + statistic ~ model,
                group_map = NULL,
                gof_map = gof_map,
                gof_omit = gof_omit,
                gof_custom = gof_custom,
                escape = escape
        ), keep.null = TRUE)
        tab <- do.call("modelsummary", args)
        panels_list[[i]] <- tab
    }

    # modelsummary(output="dataframe") re-inits this
    sanitize_output(output)

    # identical GOF rows should be combined and reported at the bottom
    # do not combine GOF if the model names are different in the different panels
    flag <- isTRUE(shape == "rcollapse")
    # panels are not all the same length
    if (length(unique(sapply(panels, length))) > 1) {
        for (i in 2:length(panels)) {
            if (!identical(names(panels[[i - 1]]), names(panels[[i]]))) {
                flag <- FALSE
            }
        }
    }

    if (flag) {

        # fixed effects should not be collapsed unless they are exactly identical across panels
        fe_collapse <- TRUE
        fe <- lapply(panels_list, subset, grepl("^FE: ", term))
        fe_n <- sapply(fe, nrow)
        if (fe_n[1] == 0 || length(unique(fe_n)) > 1) {
            fe_collapse <- FALSE
        } else {
            fe <- lapply(fe, function(x) x[order(x$term),])
            for (i in 2:length(fe)) {
                if (any(fe[[i]] != fe[[i - 1]])) {
                    fe_collapse <- FALSE
                }
            }
        }

        if (fe_collapse) {
            est <- lapply(panels_list, subset, part != "gof")
            gof <- lapply(panels_list, subset, part == "gof")
        } else {
            est <- lapply(panels_list, subset, part != "gof" | grepl("^FE: ", term))
            gof <- lapply(panels_list, subset, part == "gof" & !grepl("^FE: ", term))
        }

        gof_same <- lapply(gof, data.table::as.data.table)
        gof_same <- tryCatch(
            Reduce(data.table::fintersect, gof_same),
            error = function(e) NULL)

        if (!is.null(gof_same)) {
            for (i in seq_along(gof)) {
                gof[[i]] <- gof[[i]][!gof[[i]]$term %in% gof_same$term, , drop = FALSE]
                panels_list[[i]] <- rbind(est[[i]], gof[[i]])
            }
        }

        panels_list <- c(panels_list, list(gof_same))

    } else {
        gof_same <- NULL
    }

    panels_list <- Filter(function(x) !is.null(x), panels_list)

    panels_nrow <- sapply(panels_list, nrow)

    # only one hrule after the last data, before gof_same
    if (is.null(gof_same) || isTRUE(nrow(gof_same) == 0)) {
        hrule <- NULL
    } else {
        hrule <- sum(utils::head(panels_nrow, -1)) + 1
    }

    tab <- data.table::rbindlist(panels_list, fill = TRUE)

    tab$part <- tab$statistic <- NULL

    colnames(tab)[1] <- " "
    tab[is.na(tab)] <- ""

    # pad
    colnames(tab) <- pad(colnames(tab), output_format = output_format)

    # group rows by panel: kableExtra
    if (isTRUE(nrow(gof_same) > 0)) {
        panel_names <- c(panel_names, "Combined GOF")
    }

    end <- cumsum(panels_nrow)
    sta <- c(0, utils::head(end, -1)) + 1

    # Issue #626: add rows moves hgroup
    pos <- rev(sort(attr(add_rows, "position")))
    if (!is.null(pos)) {
        sta <- sta + sapply(sta, function(x) sum(pos <= x))
        end <- end + sapply(end, function(x) sum(pos <= x))
    }

    hgroup <- list()
    for (i in seq_along(panel_names)) {
        hgroup[[panel_names[i]]] <- c(sta[i], end[i])
    }

    # indent
    if (isTRUE(nrow(gof_same) > 0)) {
        hindent <- utils::tail(hgroup, 1)
        hgroup <- utils::head(hgroup, -1)
    } else {
        hindent <- NULL
    }

    # stars
    if (!isFALSE(stars) && !any(grepl("\\{stars\\}", c(estimate, statistic)))) {
        stars_note <- make_stars_note(stars, output_format = output_format, output_factory = output_factory)
        if (is.null(notes)) {
            notes <- stars_note
        } else {
            notes <- c(stars_note, notes)
        }
    }

    # align
    if (is.null(align)) {
        n_stub <- sum(grepl("^ *$", colnames(tab)))
        align <- paste0(strrep("l", n_stub), strrep("c", ncol(tab) - n_stub))
        if (isTRUE(checkmate::check_data_frame(add_columns))) {
            align <- paste0(align, strrep("c", ncol(add_columns)))
        }
    }

    ## build table
    out <- factory(
        tab,
        align    = align,
        fmt      = fmt,
        hrule    = hrule,
        hgroup = hgroup,
        hindent = hindent,
        notes    = notes,
        output   = output,
        title    = title,
        add_rows = add_rows,
        add_columns = add_columns,
        escape = escape,
        output_factory = output_factory,
        output_format = output_format,
        output_file = output_file,
        ...
    )

    # invisible return
    if (!is.null(output_file) ||
        isTRUE(output == "jupyter") ||
        (output == "default" && settings_equal("output_default", "jupyter"))) {
        settings_rm()
        return(invisible(out))
    # visible return
    } else {
        settings_rm()
        return(out)
    }

}