R/shape_estimates.R

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

#' internal function to reshape grouped estimates
#'
#' @keywords internal
#' @noRd
shape_estimates <- function(estimates, shape, conf_level, statistic, estimate) {
  # default
  if (isTRUE(all.equal(shape$shape_formula, term + statistic ~ model))) {
    return(estimates)
  }

  shape_formula <- shape$shape_formula

  idx <- intersect(colnames(estimates), c("term", "statistic", "group", shape$group_name))

  # long
  out <- data.table::melt(data.table::data.table(estimates),
    id.vars = idx,
    variable.name = "model",
    value.name = "estimate")

  if ("statistic" %in% shape$rhs) {
    out$statistic <- rename_statistics(out$statistic, conf_level = conf_level, statistic = statistic, estimate = estimate)
  }

  # use factors to preserve order in `dcast`
  for (col in c("part", "model", "term", shape$group_name, "statistic")) {
    if (col %in% colnames(out)) {
      out[[col]] <- factor(out[[col]], unique(out[[col]]))
    }
  }

  # wide
  out <- data.table::dcast(eval(shape_formula),
    data = out,
    value.var = "estimate",
    sep = "||||")

  data.table::setDF(out)

  out[out == "NA"] <- ""
  out[is.na(out)] <- ""

  # empty columns
  idx <- sapply(out, function(x) !all(x == ""))
  out <- out[, idx, drop = FALSE]

  # empty rows
  idx <- setdiff(colnames(out), c("part", "term", "statistic", "model"))
  tmp <- out[, idx, drop = FALSE]
  idx <- apply(tmp, 1, function(x) !all(x == ""))
  out <- out[idx, ]

  return(out)
}