R/make_table.R

In gerasy1987/usefulr: Various Useful Custom Functions

#' Generate markdown or LaTeX table from list of analyses2() function outputs.
#'
#' @param .table_list List of estimate objects generated by \code{analyses2()} function.
#' @param .row_names Names of rows in output table.
#' @param .col_names Names of models in list of \code{analyses2()} outputs.
#' @param .type Character string. Either "html","markdown" or "latex" as specified in knitr::kable function.
#' @param .title Character string specifying the name of the table.
#' @param .label Character string specifying the label used to refer to table.
#' @param .print_status Logical. Whether to print status of the model.
#' @param .pad Integer number for output table padding
#' @param .col_print Number of columns to split by. Defaults to 6.
#' @param .model_stat_names Character vector of names for model states stored in \code{.table_list}
#' @param .group_means Matrix of group means with row names. Number of columns must coincide with the main table output
#' @param .hypotheses Matrix of directional hypotheses with row names. Number of columns must coincide with the main table output
#' @param .add_rows <atrix with other statistics to add to the main output. Number of columns must coincide with the main table output
#' @param .add_stars Nemed vector of significance levels
#' @param .add_modelspec Logical. Whether to add statistical significance stars
#' @param .round_digits Numeric. The rounding of report is done up to 10^{-.round_digits}.
#' param .latex_colwidth If .type = "latex", character string specifying column width and alignment. Defaults to ">{\\centering\\arraybackslash\\hsize=.5\\hsize}X".
#' param .latex_scalebox If .type = "latex", numeric value for latex table rescaling. Defaults to 0.9.
#' param .latex_size If .type = "latex", character string specifying font size for latex table. Defaults to "footnotesize".
#' param .latex_spacing If .type = "latex", character string specifying the latex code to be inserted between estimate and standard error in table. Defaults to "\\hspace{0.2in}"
#' param .latex_sanitize If .type = "latex", function specifying the text sanitizing function for table.
#' param .latex_floating If type="latex", first element of list, logical, defines whether the latex table will be floating, while the second element of list defines the floating environment. Defaults to list(TRUE, "table").
#' param .latex_placement If type="latex", character string specifying table floating placement. Defaults to "H".
#' @return Markdown or LaTeX table of estimated models.
#' @examples
#'
#' @import knitr
#' @import dplyr
#' @importFrom  tidyr pivot_wider pivot_longer
#' @export
make_table <- function(.table_list,
                      .row_names,
                      .col_names,
                      .title,
                      .label = NULL,
                      .print_status = FALSE,
                      .type = getOption("usefulr.type", "markdown"),
                      .pad = getOption("usefulr.html_pad", 0),
                      .col_print = getOption("usefulr.html_col", 6),
                      .model_stat_names = c("Observations", "Adj. R-squared"),
                      .group_means = NULL,
                      .hypotheses = NULL,
                      .add_rows = NULL,
                      .add_stars = c("+" = .15, "*" = .1, "**" = .05, "***" = .01),
                      .add_modelspec = FALSE,
                      .round_digits = 3 #,
                      # .latex_colwidth = getOption("usefulr.latex_colwidth",
                      #                             ">{\\centering\\arraybackslash\\hsize=.5\\hsize}X"),
                      # .latex_scalebox = getOption("usefulr.latex_scalebox", 1),
                      # .latex_size = getOption("usefulr.latex_size", "small"),
                      # .latex_spacing = getOption("usefulr.latex_spacing", "\\hspace{0.2in}"),
                      # .latex_sanitize = getOption("usefulr.latex_sanitize",
                      #                             function(str) { mgsub(pattern = c("_", " ["),
                      #                                                   replacement = c("\\_", paste("", .latex_spacing, "[")),
                      #                                                   x = str,
                      #                                                   fixed = TRUE)
                      #                               } ),
                      # .latex_floating = list(TRUE, "table"),
                      # .latex_placement = getOption("usefulr.latex_placement", "H")
                      ) {

  .type <- match.arg(arg = .type, choices = c("markdown", "html", "latex"))
  .pad <- suppressWarnings(as.integer(.pad))
  .col_print <- suppressWarnings(as.integer(.col_print))

  if (is.na(.pad)) stop("Padding should be integer")

  if (is.na(.col_print)) stop("Column splitting should be integer")

  # if (!is.function(.latex_sanitize))
  #   stop("Sanitize argument should be a function")

  if (is.null(dim(.table_list))) {

    .table_list <-
      matrix(.table_list,
             nrow = length(.table_list), byrow = FALSE,
             dimnames = list(names(.table_list), NULL))

    # if (length(.col_names) > 1)
    #   stop("Mismatch in length of col_names and number of columns in table_list")
    #
    # if (.add_stars) {
    #   .est_tab <-
    #     dplyr::mutate(.table_list$estimates,
    #                   printout =
    #                     ifelse(is.nan(estimate), "-- [--]",
    #                            ifelse(is.na(std.error),
    #                                   paste0(fround(estimate, digits = .round_digits),
    #                                          add_stars(p.value, type = .type),
    #                                          " [", fround(p.value, digits = .round_digits), "]"),
    #                                   paste0(fround(estimate, digits = .round_digits),
    #                                          add_stars(p.value, type = .type),
    #                                          " [", fround(std.error, digits = .round_digits), "]"))))
    # } else if (!.add_stars) {
    #   .est_tab <-
    #     dplyr::mutate(.table_list$estimates,
    #                   printout =
    #                     ifelse(is.nan(estimate), "-- [--]",
    #                            ifelse(is.na(std.error),
    #                                   paste0(fround(estimate, digits = .round_digits),
    #                                          " [", fround(p.value, digits = .round_digits), "]"),
    #                                   paste0(fround(estimate, digits = .round_digits),
    #                                          " [", fround(std.error, digits = .round_digits), "]"))))
    # }
    #
    # .est_tab <- .est_tab[, "printout"]
    #
    # .stat_tab <- unname(.table_list$stat[c(2,1)])
    # .spec_tab <- unname(.table_list$model_spec[c(1,3:5)])
    # # .status_tab <- unname(.table_list$model_status[1:3])
    # if (.type == "latex")
    #   .est_tab <- kableExtra::linebreak(gsub(.est_tab, pattern = " \\[", replacement = "\\\n["),
    #                                     align = "c", linebreaker = "\n")
    # .out_tab <- as.matrix(c(.est_tab, .stat_tab, .spec_tab))
  } # else {
  if (length(.col_names) != dim(.table_list)[2])
    stop("Mismatch in length of col_names and number of columns in table_list")

  .table_list["estimates", ] <-
    lapply(seq_along(.table_list["estimates", ]), function(i) {
      if (!is.null(.add_stars)) {
        x <-
          dplyr::mutate(
            .table_list["estimates", ][[i]],
            !!paste0("printest_", i) :=
              dplyr::if_else(is.nan(estimate), "--",
                             paste0(fround(estimate, digits = .round_digits),
                                    add_stars(p.value, type = .type, sign_levels = .add_stars))),
            !!paste0("printse_", i) :=
              dplyr::if_else(is.nan(estimate) | is.na(std.error), "[--]",
                             paste0("[", fround(std.error, digits = .round_digits), "]")))
      } else if (is.null(.add_stars)) {
        x <-
          dplyr::mutate(
            .table_list["estimates", ][[i]],
            !!paste0("printest_", i) :=
              dplyr::if_else(is.nan(estimate), "--",
                             fround(estimate, digits = .round_digits)),
            !!paste0("printse_", i) :=
              dplyr::if_else(is.nan(estimate) | is.na(std.error), "[--]",
                             paste0("[", fround(std.error, digits = .round_digits), "]")))
      }
      return(x)
    })

  .est_tab <- suppressWarnings(base::Reduce(
    f = function(dtf1, dtf2) dplyr::full_join(dtf1, dtf2, by = "term"),
    x = lapply(X = .table_list["estimates", ],
               FUN = function(x) dplyr::select(x, starts_with(c("term", "printest", "printse"))))))

  .est_tab <-
    tidyr::pivot_wider(
      data = tidyr::pivot_longer(
        data = .est_tab, cols = -term,
        names_to = c("type", "outcome"), names_pattern = "print(.*)_(.*)", values_to = "print"),
      names_from = outcome, values_from = print)

  .est_tab <-
    as.matrix(dplyr::select(.est_tab, -term, -type))

  .stat_tab <- unname(
    do.call("cbind",
            lapply(X = .table_list["stat", ],
                   FUN = function(x) x[c(2,1)])))

  if (.add_modelspec) {
    .spec_tab <- `rownames<-`(unname(
      do.call("cbind",
              lapply(X = .table_list["model_spec", ],
                     FUN = function(x) x[c(1, 3:5)]))),
      c("Model", "FE", "Clustered SE", "IPW"))
  } else {
    .spec_tab <- NULL
  }

  # .status_tab <- unname(base::Reduce(f = function(x, y) cbind(x,
  #     y), x = lapply(X = .table_list["model_status", ],
  #     FUN = function(x) x[1:3])))

  # if (.type == "latex") {
  #   .est_tab <- do.call(
  #     "cbind",
  #     tapply(
  #       X = .est_tab, INDEX = col(.est_tab),
  #       FUN = function(x) {
  #         kableExtra::linebreak(gsub(x, pattern = "\\$ \\$", replacement = "\\$\\\n\\$"),
  #                               align = "c", linebreaker = "\n")},
  #       simplify = FALSE
  #     ))
  # }

  if (!is.null(.add_rows)) {
    if (ncol(.est_tab) != ncol(.add_rows)) stop(".add_rows has wrong number of columns")
  }

  if (!is.null(.group_means)) {
    if (ncol(.est_tab) != ncol(.group_means)) stop(".group_means has wrong number of columns")
  }

  if (!is.null(.hypotheses)) {
    if (ncol(.est_tab) != ncol(.hypotheses)) stop(".hypotheses has wrong number of columns")
  }

  .out_tab <- unname(rbind(
    .est_tab, .stat_tab,
    .group_means, .hypotheses, .spec_tab, .add_rows))

  .row_names <- c(
    unlist(lapply(.row_names, function(x) c(x, ""))),
    .model_stat_names,
    rownames(.group_means), rownames(.hypotheses),
    rownames(.spec_tab), rownames(.add_rows))

  # }

  if (.type %in% c("markdown", "latex"))
    .col_names <- gsub(pattern = "\\\n", replacement = " ",
                       x = .col_names, fixed = TRUE)

  colnames(.out_tab) <- .col_names

  if (.type == "html")
    .out_tab <- gsub(x = .out_tab, pattern = " \\[", replacement = "\\\\\n[")

  if (.type == "latex") {
    .out_tab <- mgsub(x = .out_tab, pattern = c("_", "%"), replacement = c("\\_", "\\%"), fixed = TRUE)
    .row_names <- mgsub(x = .row_names, pattern = c("_", "%"), replacement = c("\\_", "\\%"), fixed = TRUE)
  }

  .out_tab <- apply(.out_tab, 2, function(x) dplyr::if_else(is.na(x), "", x))

  .list_out <- list()

  if (.type == "latex") {
    rownames(.out_tab) <- .row_names
    .list_out[[1]] <-
      knitr::kable(x = .out_tab, format = .type,
                   caption = .title,
                   label = .label,
                   align = rep("c", ncol(.out_tab)),
                   escape = FALSE,
                   booktabs = TRUE,
                   linesep = "")
  } else {
    .split_tab <- base::split(1:dim(.out_tab)[2], base::ceiling(1:dim(.out_tab)[2]/.col_print))
    for (i in 1:length(.split_tab)) {
      .temp <- cbind(.row_names,
                     .out_tab[, .split_tab[[i]]])
      colnames(.temp) <- c("", .col_names[.split_tab[[i]]])
      .list_out[[i]] <-
          knitr::kable(x = .temp, format = .type,
                       caption = ifelse(i == 1, .title, "Table continued"),
                       label = if (i == 1) .label,
                       align = c("l", rep("c", (ncol(.temp) - 1))), escape = TRUE,
                       padding = .pad)
    }

    return(structure(.list_out,
                     class = c("table_list", "knitr_kable"),
                     format = .type))

  }

}

#' @export
print.table_list <- function(table_list) {
  for (i in 1:length(table_list)) {
    print(table_list[[i]])
  }

}