R/bold_italicise_labels_levels.R

Defines functions .first_unhidden_column italicize_levels.tbl_cross italicize_labels.tbl_cross bold_levels.tbl_cross bold_labels.tbl_cross italicize_levels.gtsummary italicize_labels.gtsummary bold_levels.gtsummary bold_labels.gtsummary italicize_levels bold_levels italicize_labels bold_labels

Documented in bold_labels bold_labels.gtsummary bold_labels.tbl_cross bold_levels bold_levels.gtsummary bold_levels.tbl_cross italicize_labels italicize_labels.gtsummary italicize_labels.tbl_cross italicize_levels italicize_levels.gtsummary italicize_levels.tbl_cross

#' Bold or Italicize labels or levels in gtsummary tables
#'
#' @name bold_italicize_labels_levels
#' @param x Object created using gtsummary functions
#' @author Daniel D. Sjoberg
#' @family tbl_summary tools
#' @family tbl_regression tools
#' @family tbl_uvregression tools
#' @return Functions return the same class of gtsummary object supplied
#' @examples
#' # Example 1 ----------------------------------
#' tbl_bold_ital_ex1 <-
#'   trial[c("trt", "age", "grade")] %>%
#'   tbl_summary() %>%
#'   bold_labels() %>%
#'   bold_levels() %>%
#'   italicize_labels() %>%
#'   italicize_levels()
#' @section Example Output:
#'
#' \if{html}{Example 1}
#'
#' \if{html}{\out{
#' `r man_create_image_tag(file = "tbl_bold_ital_ex1.png", width = "50")`
#' }}
#'
NULL


#' @export
#' @rdname bold_italicize_labels_levels
bold_labels <- function(x) {
  UseMethod("bold_labels")
}

#' @export
#' @rdname bold_italicize_labels_levels
italicize_labels <- function(x) {
  UseMethod("italicize_labels")
}

#' @export
#' @rdname bold_italicize_labels_levels
bold_levels <- function(x) {
  UseMethod("bold_levels")
}


#' @export
#' @rdname bold_italicize_labels_levels
italicize_levels <- function(x) {
  UseMethod("italicize_levels")
}

#' @export
#' @rdname bold_italicize_labels_levels
bold_labels.gtsummary <- function(x) {
  updated_call_list <- c(x$call_list, list(bold_labels = match.call()))
  # input checks ---------------------------------------------------------------
  if (!"row_type" %in% x$table_styling$header$column) {
    cli::cli_alert_warning("{.code bold_labels()} cannot be used in this context.")
    return(x)
  }

  # bold labels ----------------------------------------------------------------
  x <-
    modify_table_styling(
      x,
      columns = .first_unhidden_column(x),
      rows = .data$row_type == "label",
      text_format = "bold"
    )

  x$call_list <- updated_call_list

  x
}

#' @export
#' @rdname bold_italicize_labels_levels
bold_levels.gtsummary <- function(x) {
  updated_call_list <- c(x$call_list, list(bold_levels = match.call()))
  # input checks ---------------------------------------------------------------
  if (!"row_type" %in% x$table_styling$header$column) {
    cli::cli_alert_warning("{.code bold_levels()} cannot be used in this context.")
    return(x)
  }

  # bold levels ----------------------------------------------------------------
  x <-
    modify_table_styling(
      x,
      columns = .first_unhidden_column(x),
      rows = .data$row_type != "label",
      text_format = "bold"
    )

  x$call_list <- updated_call_list

  x
}


#' @export
#' @rdname bold_italicize_labels_levels
italicize_labels.gtsummary <- function(x) {
  updated_call_list <- c(x$call_list, list(italicize_labels = match.call()))
  # input checks ---------------------------------------------------------------
  if (!"row_type" %in% x$table_styling$header$column) {
    cli::cli_alert_warning("{.code italicize_labels()} cannot be used in this context.")
    return(x)
  }

  # italicize labels -----------------------------------------------------------
  x <-
    modify_table_styling(
      x,
      columns = .first_unhidden_column(x),
      rows = .data$row_type == "label",
      text_format = "italic"
    )

  x$call_list <- updated_call_list

  x
}

#' @export
#' @rdname bold_italicize_labels_levels
italicize_levels.gtsummary <- function(x) {
  updated_call_list <- c(x$call_list, list(italicize_levels = match.call()))
  # input checks ---------------------------------------------------------------
  if (!"row_type" %in% x$table_styling$header$column) {
    cli::cli_alert_warning("{.code italicize_levels()} cannot be used in this context.")
    return(x)
  }

  # italicize levels -----------------------------------------------------------
  x <-
    modify_table_styling(
      x,
      columns = .first_unhidden_column(x),
      rows = .data$row_type != "label",
      text_format = "italic"
    )

  x$call_list <- updated_call_list

  x
}

#' @export
#' @rdname bold_italicize_labels_levels
bold_labels.tbl_cross <- function(x) {
  # bold labels ----------------------------------------------------------------
  x <- bold_labels.gtsummary(x)

  cols_to_style <-
    select(x$table_body, all_stat_cols(FALSE)) %>%
    names()

  x$table_styling$header <-
    mutate(x$table_styling$header,
      spanning_header =
        case_when(
          .data$hide == FALSE & (.data$column %in% cols_to_style) ~
            paste0("**", spanning_header, "**"),
          TRUE ~ spanning_header
        )
    ) %>%
    mutate(label = case_when(
      .data$hide == FALSE & (.data$column %in% c("stat_0", "p.value")) ~
        paste0("**", label, "**"),
      TRUE ~ label
    ))

  x
}

#' @export
#' @rdname bold_italicize_labels_levels
bold_levels.tbl_cross <- function(x) {
  # bold levels ----------------------------------------------------------------
  x <- bold_levels.gtsummary(x)

  cols_to_style <- x$table_body %>%
    select(all_stat_cols(FALSE)) %>%
    names()

  x$table_styling$header <-
    mutate(x$table_styling$header,
      label =
        case_when(
          .data$hide == FALSE & (.data$column %in% cols_to_style) ~
            paste0("**", label, "**"),
          TRUE ~ label
        )
    )



  x
}

#' @export
#' @rdname bold_italicize_labels_levels
italicize_labels.tbl_cross <- function(x) {
  # italicize labels -----------------------------------------------------------
  x <- italicize_labels.gtsummary(x)

  cols_to_style <-
    select(x$table_body, all_stat_cols(FALSE)) %>%
    names()

  x$table_styling$header <-
    mutate(x$table_styling$header,
      spanning_header =
        case_when(
          .data$hide == FALSE & (.data$column %in% cols_to_style) ~
            paste0("*", spanning_header, "*"),
          TRUE ~ spanning_header
        )
    ) %>%
    mutate(label = case_when(
      .data$hide == FALSE & (.data$column %in% c("stat_0", "p.value")) ~
        paste0("*", label, "*"),
      TRUE ~ label
    ))

  x
}



#' @export
#' @rdname bold_italicize_labels_levels
italicize_levels.tbl_cross <- function(x) {
  x <- italicize_levels.gtsummary(x)

  # italicize levels ----------------------------------------------------------------
  cols_to_style <- x$table_body %>%
    select(all_stat_cols(FALSE)) %>%
    names()

  x$table_styling$header <-
    mutate(x$table_styling$header,
      label =
        case_when(
          .data$hide == FALSE & (.data$column %in% cols_to_style) ~
            paste0("*", label, "*"),
          TRUE ~ label
        )
    )
  x
}

.first_unhidden_column <- function(x) {
  x$table_styling$header %>%
    dplyr::filter(!.data$hide) %>%
    purrr::pluck("column", 1)
}

Try the gtsummary package in your browser

Any scripts or data that you put into this service are public.

gtsummary documentation built on July 26, 2023, 5:27 p.m.