R/as_tibble.R

In ddsjoberg/gtsummary: Presentation-Ready Data Summary and Analytic Result Tables

#' Convert gtsummary object to a tibble
#'
#' Function converts a gtsummary object to a tibble.
#'
#' @inheritParams as_kable
#' @param col_labels Logical argument adding column labels to output tibble.
#' Default is `TRUE`.
#' @param fmt_missing Logical argument adding the missing value formats.
#' @param ... Not used
#' @return a [tibble][tibble::tibble-package]
#' @family gtsummary output types
#' @author Daniel D. Sjoberg
#' @name as_tibble.gtsummary
#' @examples
#' \donttest{
#' tbl <-
#'   trial %>%
#'   select(trt, age, grade, response) %>%
#'   tbl_summary(by = trt)
#'
#' as_tibble(tbl)
#'
#' # without column labels
#' as_tibble(tbl, col_labels = FALSE)
#' }
NULL

#' @export
#' @rdname as_tibble.gtsummary
as_tibble.gtsummary <- function(x, include = everything(), col_labels = TRUE,
                                return_calls = FALSE, fmt_missing = FALSE, ...) {
  check_dots_empty(error = function(e) inform(c(e$message, e$body)))

  # running pre-conversion function, if present --------------------------------
  x <- do.call(get_theme_element("pkgwide-fun:pre_conversion", default = identity), list(x))

  # converting row specifications to row numbers, and removing old cmds --------
  x <- .table_styling_expr_to_row_number(x)

  # creating list of calls to get formatted tibble -----------------------------
  tibble_calls <-
    table_styling_to_tibble_calls(
      x = x,
      col_labels = col_labels,
      fmt_missing = fmt_missing
    )

  # converting to character vector ---------------------------------------------
  include <-
    .select_to_varnames(
      select = {{ include }},
      var_info = names(tibble_calls),
      arg_name = "include"
    )

  # making list of commands to include -----------------------------------------
  # this ensures list is in the same order as names(x$kable_calls)
  include <- names(tibble_calls) %>% intersect(include)
  # user cannot exclude the first 'tibble' command
  include <- "tibble" %>% union(include)

  # return calls, if requested -------------------------------------------------
  if (return_calls == TRUE) {
    return(tibble_calls[include])
  }

  # taking each gt function call, concatenating them with %>% separating them
  .eval_list_of_exprs(tibble_calls[include])
}

#' @export
#' @rdname as_tibble.gtsummary
as.data.frame.gtsummary <- function(...) {
  res <- as_tibble(...)

  if (inherits(res, "data.frame"))
    return(as.data.frame(res))

  res
}


table_styling_to_tibble_calls <- function(x, col_labels = TRUE, fmt_missing = FALSE) {
  tibble_calls <- list()

  # tibble ---------------------------------------------------------------------
  tibble_calls[["tibble"]] <- expr(x$table_body)

  # ungroup --------------------------------------------------------------------
  if ("groupname_col" %in% x$table_styling$header$column) {
    tibble_calls[["ungroup"]] <-
      list(
        expr(group_by(.data$groupname_col)),
        expr(mutate(groupname_col = ifelse(dplyr::row_number() == 1,
          as.character(.data$groupname_col),
          NA_character_
        ))),
        expr(ungroup())
      )
  }

  # fmt (part 1) ---------------------------------------------------------------
  # this needs to be called in as_tibble() before the bolding and italic function,
  # but the bolding and italic code needs to executed on pre-formatted data
  # (e.g. `bold_p()`) this holds its place for when it is finally run
  tibble_calls[["fmt"]] <- list()

  # cols_merge -----------------------------------------------------------------
  tibble_calls[["cols_merge"]] <-
    map(
      seq_len(nrow(x$table_styling$cols_merge)),
      ~ expr(
        mutate(
          !!x$table_styling$cols_merge$column[.x] :=
            ifelse(
              dplyr::row_number() %in% !!x$table_styling$cols_merge$rows[[.x]],
              glue::glue(!!x$table_styling$cols_merge$pattern[.x]) %>% as.character(),
              !!rlang::sym(x$table_styling$cols_merge$column[.x])
            )
        )
      )
    )

  # tab_style_bold -------------------------------------------------------------
  df_bold <- x$table_styling$text_format %>% filter(.data$format_type == "bold")

  tibble_calls[["tab_style_bold"]] <-
    map(
      seq_len(nrow(df_bold)),
      ~ expr(mutate_at(
        gt::vars(!!!syms(df_bold$column[[.x]])),
        ~ ifelse(row_number() %in% !!df_bold$row_numbers[[.x]],
          paste0("__", ., "__"), .
        )
      ))
    )

  # tab_style_italic -------------------------------------------------------------
  df_italic <- x$table_styling$text_format %>% filter(.data$format_type == "italic")

  tibble_calls[["tab_style_italic"]] <-
    map(
      seq_len(nrow(df_italic)),
      ~ expr(mutate_at(
        gt::vars(!!!syms(df_italic$column[[.x]])),
        ~ ifelse(row_number() %in% !!df_italic$row_numbers[[.x]],
          paste0("_", ., "_"), .
        )
      ))
    )

  # fmt (part 2) ---------------------------------------------------------------
  tibble_calls[["fmt"]] <-
    map(
      seq_len(nrow(x$table_styling$fmt_fun)),
      ~ expr((!!expr(!!eval(parse_expr("gtsummary:::.apply_fmt_fun"))))(
        columns = !!x$table_styling$fmt_fun$column[[.x]],
        row_numbers = !!x$table_styling$fmt_fun$row_numbers[[.x]],
        fmt_fun = !!x$table_styling$fmt_fun$fmt_fun[[.x]],
        update_from = !!x$table_body
      ))
    )

  # fmt_missing ----------------------------------------------------------------
  if (isTRUE(fmt_missing)) {
    tibble_calls[["fmt_missing"]] <-
      map(
        seq_len(nrow(x$table_styling$fmt_missing)),
        ~ expr(
          ifelse(
            dplyr::row_number() %in% !!x$table_styling$fmt_missing$row_numbers[[.x]] & is.na(!!sym(x$table_styling$fmt_missing$column[.x])),
            !!x$table_styling$fmt_missing$symbol[.x],
            !!sym(x$table_styling$fmt_missing$column[.x])
          )
        )
      ) %>%
      rlang::set_names(x$table_styling$fmt_missing$column) %>%
      {
        expr(dplyr::mutate(!!!.))
      } %>%
      list()
  } else {
    tibble_calls[["fmt_missing"]] <- list()
  }

  # cols_hide ------------------------------------------------------------------
  # cols_to_keep object created above in fmt section
  tibble_calls[["cols_hide"]] <-
    expr(dplyr::select(any_of("groupname_col"), !!!syms(.cols_to_show(x))))

  # cols_label -----------------------------------------------------------------
  if (col_labels) {
    df_col_labels <-
      dplyr::filter(x$table_styling$header, .data$hide == FALSE)

    tibble_calls[["cols_label"]] <-
      expr(rlang::set_names(!!df_col_labels$label))
  }

  tibble_calls
}

.apply_fmt_fun <- function(data, columns, row_numbers, fmt_fun, update_from) {
  # apply formatting functions
  df_updated <-
    update_from[row_numbers, columns, drop = FALSE] %>%
    purrr::map_dfc(~ fmt_fun(.x))

  # convert underlying column to character if updated col is character
  for (v in columns) {
    if (is.character(df_updated[[v]]) && !is.character(data[[v]])) {
      data[[v]] <- as.character(data[[v]])
    }
  }

  # udpate data and return
  data[row_numbers, columns, drop = FALSE] <- df_updated

  data
}