R/style_typst.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_typst",
  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,
                        line = NULL,
                        line_color = "black",
                        line_width = 0.1,
                        colspan = NULL,
                        indent = 0,
                        midrule = FALSE, # undocumented, only used by `group_tt()`
                        ...) {
    sty <- x@style

    # gutters are used for group_tt(j) but look ugly with cell fill
    if (!all(is.na(sty$background))) {
      x@table_string <- lines_drop(x@table_string, "column-gutter:", fixed = TRUE)
    }

    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"

    sty$i <- sty$i - 1 + x@nhead
    sty$j <- sty$j - 1
    if (length(x@names) == 0) sty$i <- sty$i + 1

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

    insert_field <- function(x, name = "bold", value = "true") {
      old <- sprintf("%s: [^,]*,", name)
      new <- sprintf("%s: %s,", name, value)
      out <- ifelse(grepl(old, x),
        sub(old, new, x),
        sprintf("%s, %s", x, new)
      )
      return(out)
    }

    for (row in seq_len(nrow(sty))) {
      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] <- insert_field(css[idx], "bold", "true")
      if (isTRUE(sty[row, "italic"])) css[idx] <- insert_field(css[idx], "italic", "true")
      if (isTRUE(sty[row, "underline"])) css[idx] <- insert_field(css[idx], "underline", "true")
      if (isTRUE(sty[row, "strikeout"])) css[idx] <- insert_field(css[idx], "strikeout", "true")
      if (isTRUE(sty[row, "monospace"])) css[idx] <- insert_field(css[idx], "monospace", "true")
      if (!is.na(sty[row, "align"])) css[idx] <- insert_field(css[idx], "align", sty[row, "align"])

      fs <- sty[row, "indent"]
      if (!is.na(fs)) {
        css[idx] <- insert_field(css[idx], "indent", sprintf("%sem", fs))
      }

      fs <- sty[row, "fontsize"]
      if (!is.na(fs)) {
        css[idx] <- insert_field(css[idx], "fontsize", sprintf("%sem", fs))
      }

      col <- sty[row, "color"]
      if (!is.na(col)) {
        if (grepl("^#", col)) col <- sprintf('rgb("%s")', col)
        css[idx] <- insert_field(css[idx], "color", col)
      }

      bg <- sty[row, "background"]
      if (!is.na(bg)) {
        if (grepl("^#", bg)) bg <- sprintf('rgb("%s")', bg)
        css[idx] <- insert_field(css[idx], "background", bg)
      }
    }

    css <- gsub(" +", " ", trimws(css))
    css <- sub("^,", "", trimws(css))
    css <- gsub(",+", ",", trimws(css))
    rec$css <- css

    # TODO: spans before styles, as in bootstrap

    # Unique style arrays
    uni <- split(rec, rec$css)

    pairs <- sapply(uni, function(x) paste(sprintf("(%s, %s),", x$j, x$i), collapse = " "))
    styles <- sapply(uni, function(x) x$css[1])
    styles <- sprintf("(pairs: (%s), %s),", pairs, styles)

    for (s in styles) {
      x@table_string <- lines_insert(x@table_string, s, "tinytable cell style after", "after")
    }

    lin <- sty[grepl("b|t", sty$line), , drop = FALSE]
    if (nrow(lin) > 0) {
      lin <- split(lin, list(lin$i, lin$line, lin$line_color, lin$line_width))
      lin <- Filter(function(x) nrow(x) > 0, lin)
      lin <- lapply(lin, hlines)
      for (l in lin) {
        x@table_string <- lines_insert(x@table_string, l, "tinytable lines before", "before")
      }
    }

    lin <- sty[grepl("l|r", sty$line), , drop = FALSE]
    if (nrow(lin) > 0) {
      lin <- split(lin, list(lin$j, lin$line, lin$line_color, lin$line_width))
      lin <- Filter(function(x) nrow(x) > 0, lin)
      lin <- lapply(lin, vlines)
      for (l in lin) {
        x@table_string <- lines_insert(x@table_string, l, "tinytable lines before", "before")
      }
    }

    return(x)
  }
)


split_chunks <- function(x) {
  x <- sort(x)
  breaks <- c(0, which(diff(x) != 1), length(x))
  result <- list()
  for (i in seq_along(breaks)[-length(breaks)]) {
    chunk <- x[(breaks[i] + 1):breaks[i + 1]]
    result[[i]] <- c(min = min(chunk), max = max(chunk))
  }
  out <- data.frame(do.call(rbind, result))
  out$max <- out$max + 1
  return(out)
}


hlines <- function(k) {
  xmin <- split_chunks(k$j)$min
  xmax <- split_chunks(k$j)$max
  ymin <- k$i[1]
  ymax <- k$i[1] + 1
  line <- k$line[1]
  color <- if (is.na(k$line_color[1])) "black" else k$line_color[1]
  if (grepl("^#", color)) color <- sprintf('rgb("%s")', color)
  width <- if (is.na(k$line_width[1])) 0.1 else k$line_width[1]
  width <- sprintf("%sem", width)
  out <- ""
  if (grepl("t", line)) {
    tmp <- "table.hline(y: %s, start: %s, end: %s, stroke: %s + %s),"
    tmp <- sprintf(tmp, ymin, xmin, xmax, width, color)
    out <- paste(out, tmp)
  }
  if (grepl("b", line)) {
    tmp <- "table.hline(y: %s, start: %s, end: %s, stroke: %s + %s),"
    tmp <- sprintf(tmp, ymax, xmin, xmax, width, color)
    out <- paste(out, tmp)
  }
  return(out)
}



vlines <- function(k) {
  ymin <- split_chunks(k$i)$min
  ymax <- split_chunks(k$i)$max
  xmin <- k$j[1]
  xmax <- xmin + 1
  line <- k$line[1]
  color <- if (is.na(k$line_color[1])) "black" else k$line_color[1]
  width <- if (is.na(k$line_width[1])) 0.1 else k$line_width[1]
  width <- sprintf("%sem", width)
  out <- ""
  if (grepl("l", line)) {
    tmp <- "table.vline(x: %s, start: %s, end: %s, stroke: %s + %s),"
    tmp <- sprintf(tmp, xmin, ymin, ymax, width, color)
    out <- paste(out, tmp)
  }
  if (grepl("r", line)) {
    tmp <- "table.vline(x: %s, start: %s, end: %s, stroke: %s + %s),"
    tmp <- sprintf(tmp, xmax, ymin, ymax, width, color)
    out <- paste(out, tmp)
  }
  return(out)
}