R/style_bootstrap.R

In tinytable: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats

#' Internal styling function
#'
#' @inheritParams style_tt
#' @keywords internal
#' @noRd
setMethod(
  f = "style_eval",
  signature = "tinytable_bootstrap",
  definition = function(x,
                        i = NULL,
                        j = NULL,
                        bold = FALSE,
                        italic = FALSE,
                        monospace = FALSE,
                        underline = FALSE,
                        strikeout = FALSE,
                        color = NULL,
                        background = NULL,
                        fontsize = NULL,
                        align = NULL,
                        alignv = NULL,
                        line = NULL,
                        line_color = "black",
                        line_width = 0.1,
                        colspan = NULL,
                        rowspan = NULL,
                        indent = 0,
                        bootstrap_class = NULL,
                        bootstrap_css = NULL,
                        bootstrap_css_rule = NULL,
                        ...) {
    if (length(x@bootstrap_css_rule) == 1) {
      x@table_string <- bootstrap_setting(x@table_string, x@bootstrap_css_rule, component = "css")
    }

    sty <- x@style


    sty$alignv[which(sty$alignv == "t")] <- "top"
    sty$alignv[which(sty$alignv == "b")] <- "bottom"
    sty$alignv[which(sty$alignv == "m")] <- "middle"

    sty$align[which(sty$align == "l")] <- "left"
    sty$align[which(sty$align == "c")] <- "center"
    sty$align[which(sty$align == "d")] <- "center"
    sty$align[which(sty$align == "r")] <- "right"

    rec <- expand.grid(
      i = c(-(seq_len(x@nhead) - 1), seq_len(x@nrow)),
      j = seq_len(x@ncol)
    )
    css <- rep("", nrow(rec))

    for (row in seq_len(nrow(sty))) {
      # index: sty vs rec
      idx_i <- sty$i[row]
      if (is.na(idx_i)) idx_i <- unique(rec$i)
      idx_j <- sty$j[row]
      if (is.na(idx_j)) idx_j <- unique(rec$j)
      idx <- rec$i == idx_i & rec$j == idx_j

      if (isTRUE(sty[row, "bold"])) css[idx] <- paste(css[idx], "font-weight: bold;")
      if (isTRUE(sty[row, "italic"])) css[idx] <- paste(css[idx], "font-style: italic;")
      if (isTRUE(sty[row, "underline"])) css[idx] <- paste(css[idx], "text-decoration: underline;")
      if (isTRUE(sty[row, "strikeout"])) css[idx] <- paste(css[idx], "text-decoration: line-through;")
      if (isTRUE(sty[row, "monospace"])) css[idx] <- paste(css[idx], "font-family: monospace;")
      if (!is.na(sty[row, "color"])) css[idx] <- paste(css[idx], paste0("color: ", sty[row, "color"], ";"))
      if (!is.na(sty[row, "background"])) css[idx] <- paste(css[idx], paste0("background-color: ", sty[row, "background"], ";"))
      if (!is.na(sty[row, "fontsize"])) css[idx] <- paste(css[idx], paste0("font-size: ", sty[row, "fontsize"], "em;"))
      if (!is.na(sty[row, "alignv"])) css[idx] <- paste(css[idx], paste0("vertical-align: ", sty[row, "alignv"], ";"))
      if (!is.na(sty[row, "align"])) css[idx] <- paste(css[idx], paste0("text-align: ", sty[row, "align"], ";"))
      if (!is.na(sty[row, "indent"])) css[idx] <- paste(css[idx], paste0("padding-left: ", sty[row, "indent"], "em;"))
      if (!is.na(sty[row, "bootstrap_css"])) css[idx] <- paste(css[idx], sty[row, "bootstrap_css"])

      lin <- ""
      line <- sty$line[row]
      line_width <- sty$line_width[row]
      line_color <- sty$line_color[row]
      line_color <- if (is.na(line_color)) "black" else line_color
      line_width <- if (is.na(line_width)) 0.1 else line_width
      left <- grepl("l", line)
      right <- grepl("r", line)
      top <- grepl("t", line)
      bottom <- grepl("b", line)
      if (all(c(left, right, top, bottom))) {
        template <- "border: solid %s %sem;"
      } else if (any(c(left, right, top, bottom))) {
        template <- "border: solid %s %sem;"
        if (left) template <- "border-left: solid %s %sem;"
        if (right) template <- "border-right: solid %s %sem;"
        if (top) template <- "border-top: solid %s %sem;"
        if (bottom) template <- "border-bottom: solid %s %sem;"
      } else {
        template <- ""
      }
      if (template != "") {
        lin <- paste(lin, sprintf(template, line_color, line_width))
      }
      css[idx] <- paste(css[idx], lin)
    }

    css <- gsub(" +", " ", trimws(css))

    # JS 0-indexing
    rec$i <- rec$i - 1 + x@nhead
    rec$j <- rec$j - 1


    # spans: before styles because we return(x) if there is no style
    for (row in seq_len(nrow(sty))) {
      rowspan <- if (!is.na(sty$rowspan[row])) sty$rowspan[row] else 1
      colspan <- if (!is.na(sty$colspan[row])) sty$colspan[row] else 1
      if (rowspan > 1 || colspan > 1) {
        id <- get_id(stem = "spanCell_")
        listener <- "      window.addEventListener('load', function () { %s(%s, %s, %s, %s) })"
        listener <- sprintf(listener, id, sty$i[row], sty$j[row] - 1, rowspan, colspan)
        x@table_string <- lines_insert(x@table_string, listener, "tinytable span after", "after")
        # x@table_string <- bootstrap_setting(x@table_string, listener, component = "cell")
      }
    }


    rec$css_arguments <- css
    rec <- rec[rec$css_arguments != "", , drop = FALSE]
    if (nrow(rec) == 0) {
      return(x)
    }

    # Unique CSS arguments assigne by arrays
    css_table <- unique(rec[, c("css_arguments"), drop = FALSE])
    css_table$id_css <- sapply(seq_len(nrow(css_table)), function(i) get_id(stem = "tinytable_css_"))
    idx <- merge(rec[, c("i", "j", "css_arguments")], css_table, all.x = TRUE, sort = FALSE)
    # factor is important otherwise we split by a random value and the order can break snapshots
    idx$split_idx <- factor(idx$id_css, levels = unique(idx$id_css))
    if (nrow(idx) > 0) {
      idx <- split(idx, idx$split_idx)
      for (i in seq_along(idx)) {
        id_css <- idx[[i]]$id_css[1]
        arr <- sprintf("{ i: %s, j: %s }, ", idx[[i]]$i, idx[[i]]$j)
        arr <- c("          {", " positions: [ ", arr, " ],", " css_id: '", id_css, "',", "}, ")
        arr <- paste(arr, collapse = "")
        x@table_string <- lines_insert(x@table_string, arr, "tinytable style arrays after", "after")
        entry <- sprintf("      .table td.%s, .table th.%s { %s }", id_css, id_css, idx[[i]]$css_arguments[1])
        x@table_string <- lines_insert(x@table_string, entry, "tinytable css entries after", "after")
      }
    }

    return(x)
  })