R/rule_text_bold.R

In condformat: Conditional Formatting in Data Frames

#' Use bold text if a condition is met
#' @family rule
#' @inheritParams rule_fill_discrete
#' @param expression Condition that evaluates to `TRUE` for the rows where bold text should be applied.
#'                   When `columns` selects more than one column, the expression is
#'                   evaluated once per column, with the `.col` pronoun bound to that
#'                   column's own values. If omitted, it defaults to `.col`.
#'
#' @param na.bold If `TRUE`, make missing values bold.
#' @examples
#' data(iris)
#' cf <- condformat(iris[c(1:5, 51:55, 101:105),]) |>
#'   rule_text_bold(Species, expression = Species == "setosa")
#' \dontrun{
#' print(cf)
#' }
#' @export
rule_text_bold <- function(x, columns, expression,
                           na.bold = FALSE,
                           lockcells = FALSE) {
  columnsquo <- rlang::enquo(columns)
  expr <- rlang::enquo(expression)

  rule <- structure(list(columns = columnsquo,
                         expression = expr,
                         na.value = force(na.bold),
                         lockcells = force(lockcells)),
                    class = c("condformat_rule", "rule_text_bold"))

  x <- add_rule_to_condformat(x, rule)
  return(x)
}

rule_to_cf_field.rule_text_bold <- function(rule, xfiltered, xview, ...) {
  columns <- tidyselect::eval_select(expr = rule[["columns"]], data = xview)
  if (length(columns) == 0) {
    return(NULL)
  }
  if (rlang::quo_is_missing(rule[["expression"]])) {
    rule[["expression"]] <- rlang::sym(".col")
  }
  values_per_column <- eval_expression_per_column(rule[["expression"]], xfiltered, columns)

  bold_or_not_mat <- matrix(NA, nrow = nrow(xview), ncol = ncol(xview))
  colnames(bold_or_not_mat) <- colnames(xview)
  for (col_name in names(columns)) {
    bold_or_not <- values_per_column[[col_name]]
    stopifnot(identical(length(bold_or_not), nrow(xview)))
    col_values <- ifelse(bold_or_not, "bold", "normal")
    col_values[is.na(bold_or_not)] <- rule[["na.value"]]
    bold_or_not_mat[, col_name] <- col_values
  }

  cf_field <- structure(list(css_key = "font-weight",
                             css_values = bold_or_not_mat,
                             lock_cells = rule[["lockcells"]]),
                        class = c("cf_field_rule_text_bold",
                                  "cf_field_css", "cf_field"))
  return(cf_field)
}

#' @export
cf_field_to_latex.cf_field_rule_text_bold <- function(cf_field, xview, unlocked) {
  css_values <- cf_field[["css_values"]]
  to_lock <- !is.na(css_values)
  css_values[is.na(css_values) | !unlocked] <- ""
  before <- ifelse(css_values == "bold", "\\textbf{", "")
  after <- ifelse(css_values == "bold", "}", "")

  if (cf_field[["lock_cells"]]) {
    unlocked <- unlocked & !to_lock
  }
  list(before = before, after = after, unlocked = unlocked)
}

#' @export
cf_field_to_gtable.cf_field_rule_text_bold <- function(cf_field, xview, gridobj, unlocked, has_rownames, has_colnames) {
  css_values <- cf_field[["css_values"]]
  to_lock <- !is.na(css_values)
  css_values[is.na(css_values) | !unlocked] <- ""
  gpbold <- grid::gpar(fontface = "bold")

  row_col <- which(css_values == "bold", arr.ind = TRUE)
  for (tobold in seq_len(nrow(row_col))) {
    ind <- find_cell(gridobj,
                     as.integer(has_colnames) + row_col[tobold, 1],
                     as.integer(has_rownames) + row_col[tobold, 2],
                     name = "core-fg")
    gridobj$grobs[ind][[1]][["gp"]][["fontface"]] <- gpbold[["fontface"]]
    gridobj$grobs[ind][[1]][["gp"]][["font"]] <- gpbold[["font"]]
  }

  if (cf_field[["lock_cells"]]) {
    unlocked <- unlocked & !to_lock
  }
  list(gridobj = gridobj, unlocked = unlocked)
}