style_tabularray refactor

R/group_tabularray.R

@@ -102,14 +102,14 @@ group_tabularray_row <- function(x, i, indent, ...) {
     ""
   )
   cellspec <- paste(cellspec, collapse = "")
-  tab <- style_tabularray(tab, inner = cellspec)
+  tab <- tabularray_insert(tab, content = cellspec, type = "inner")
 
   # we also want to indent the header
   i <- idx$new[!is.na(idx$old)] + m$nhead 
   if (m$nhead > 0) i <- c(1:m$nhead, i)
   cellspec <- sprintf("cell{%s}{%s}={%s},", i, 1, sprintf("preto={\\hspace{%sem}}", indent))
   cellspec <- paste(cellspec, collapse = "")
-  tab <- style_tabularray(tab, inner = cellspec)
+  tab <- tabularray_insert(tab, content = cellspec, type = "inner")
 
   dots <- list(...)
   if (length(dots) > 0) {

R/sanity.R

@@ -116,7 +116,9 @@ check_integerish <- function(x, len = NULL, lower = NULL, upper = NULL, null.ok
 
 
 assert_integerish <- function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
+  if (isTRUE(null.ok) && is.null(x)) return(invisible())
   msg <- sprintf("`%s` must be integer-ish", name)
+  if (is.null(x) && !isTRUE(null.ok)) stop(sprintf("%s should not be NULL.", name), call. = FALSE)
   if (!isTRUE(check_integerish(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
     if (!is.numeric(x)) msg <- paste0(msg, "; it is not numeric")
     if (!is.null(len) && length(x) != len) msg <- paste0(msg, sprintf("; its length must be %s", len))

R/style_tabularray.R

@@ -1,62 +1,148 @@
 style_tabularray <- function(x,
-                             inner = NULL,
-                             outer = NULL,
-                             body = NULL) {
+                             i = NULL,
+                             j = NULL,
+                             header = FALSE,
+                             bold = FALSE,
+                             italic = FALSE,
+                             monospace = FALSE,
+                             underline = FALSE,
+                             strikeout = FALSE,
+                             color = NULL,
+                             background = NULL,
+                             fontsize = NULL,
+                             width = NULL,
+                             align = NULL,
+                             colspan = NULL,
+                             indent = 0,
+                             tabularray_inner = NULL,
+                             tabularray_outer = NULL) {
 
-  m <- meta(x)
-  if (m$output != "latex") return(x)
+  if (meta(x, "output") != "latex") return(x)
 
-  if (is.null(inner) && is.null(outer) && is.null(body)) return(x)
+  out <- x
 
-  assert_string(inner, null.ok = TRUE)
-  assert_string(outer, null.ok = TRUE)
+  ival <- if (is.null(i)) seq_len(meta(x, "nrows")) else i
+  jval <- if (is.null(j)) seq_len(meta(x, "ncols")) else j
 
-  att <- attributes(x)    
-  out <- strsplit(x, "\n")[[1]]
+  # order may be important for recycling 
+  settings <- expand.grid(i = ival, j = jval, tabularray = "")
+  if (is.null(i) && !is.null(j)) {
+    settings <- settings[order(settings$i, settings$j), ]
+  }
 
+  # colspan requires cell level, so we keep the full settings DF
+  if (is.null(colspan)) {
+    if (is.null(i) && is.null(j)) {
+      settings <- unique(settings[, c("i", "tabularray"), drop = FALSE])
+    } else if (is.null(i)) {
+      settings <- unique(settings[, c("j", "tabularray"), drop = FALSE])
+    } else if (is.null(j)) {
+      settings <- unique(settings[, c("i", "tabularray"), drop = FALSE])
+    }
+  }
 
-  if (!is.null(inner)) {
-    inner <- trimws(inner)
-    if (!grepl(",$", inner)) inner <- paste0(inner, ",")
-    idx <- grep("% tabularray inner close", out)
-    out <- c(
-      out[1:(idx - 1)],
-      # empty lines can break latex
-      inner,
-      out[idx:length(out)])
+  if (!isTRUE(header) && "i" %in% names(settings)) {
+    settings$i <- settings$i + meta(out, "nhead")
   }
 
-  if (!is.null(outer)) {
-    outer <- trimws(outer)
-    if (!grepl(",$", outer)) outer <- paste0(outer, ",")
-    idx <- grep("% tabularray outer close", out)
-    out <- c(
-      out[1:(idx - 1)],
-      # empty lines can break latex
-      outer,
-      out[idx:length(out)])
+  span <- if (!is.null(colspan)) paste0("c=", colspan, ",") else ""
+
+  # convert to tabularray now that we've filled the bootstrap settings
+  if (is.numeric(fontsize)) settings$tabularray <- sprintf("%s font=\\fontsize{%s}{%s}\\selectfont,", settings$tabularray, fontsize, fontsize + 2) 
+  if (!is.null(align)) settings$tabularray <- sprintf("%s halign=%s,", settings$tabularray, align)
+  if (!is.null(width)) settings$tabularray <- sprintf("%s wd={%s},", settings$tabularray, width)
+  if (indent > 0) settings$tabularary <- sprintf("%s preto={\\hspace{%sem}},", settings$tabularray, indent)
+
+  vectorize_tabularray <- function(z) {
+    if (is.null(z)) {
+      return(rep(FALSE, nrow(settings)))
+    }
+    if (check_flag(z))  {
+      return(rep(z, nrow(settings)))
+    }
+    return(z)
   }
 
-  if (!is.null(body)) {
-    idx <- grep("% tabularray inner close", out)
-    out <- c(
-      out[1:idx],
-      # empty lines can break latex
-      trimws(body),
-      out[(idx + 1):length(out)])
+  bold <- vectorize_tabularray(bold)
+  italic <- vectorize_tabularray(italic)
+  underline <- vectorize_tabularray(underline)
+  strikeout <- vectorize_tabularray(strikeout)
+  monospace <- vectorize_tabularray(monospace)
+  cmd <- rep("", nrow(settings))
+  cmd <- ifelse(bold, paste0(cmd, "\\bfseries"), cmd)
+  cmd <- ifelse(italic, paste0(cmd, "\\textit"), cmd)
+  cmd <- ifelse(underline, paste0(cmd, "\\tinytableTabularrayUnderline"), cmd)
+  cmd <- ifelse(strikeout, paste0(cmd, "\\tinytableTabularrayStrikeout"), cmd)
+  cmd <- ifelse(monospace, paste0(cmd, "\\texttt"), cmd)
+  settings$tabularray <- sprintf("%s, cmd=%s,", settings$tabularray, cmd)
+
+  # hex must be treated differently in LaTeX
+  cols <- c(color, background)
+  if (!is.null(cols)) {
+    hex <- cols[grepl("^#", cols)]
+    for (h in hex) {
+      b <- sprintf(
+        "\\tinytableDefineColor{%s}{HTML}{%s}",
+        sub("^#", "c", h), sub("^#", "", h))
+      cal <- call("insert_tabularray", content = b, type = "body")
+      out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal)))
+    }
+  }
+  if (!is.null(background)) {
+    settings$tabularray <- sprintf("%s bg=%s,", settings$tabularray, sub("^#", "c", background))
+  }
+  if (!is.null(color)) {
+    settings$tabularray <- sprintf("%s fg=%s,", settings$tabularray, sub("^#", "c", color))
   }
 
-  # rebuild
-  out <- paste(out, collapse = "\n")
-  attributes(out) <- att
-  class(out) <- class(x)
+  settings$tabularray <- trimws(gsub("cmd=,", "", settings$tabularray))
+  settings$tabularray <- trimws(gsub("\\s+", "", settings$tabularray))
+  settings$tabularray <- trimws(gsub(",+", ",", settings$tabularray))
+
+  for (k in seq_len(nrow(settings))) {
+    if (all(c("i", "j") %in% colnames(settings))) {
+      spec <- sprintf("cell{%s}{%s}={%s}{%s},", settings$i[k], settings$j[k], span, settings$tabularray[k])
+    } else if ("i" %in% colnames(settings)) {
+      spec <- sprintf("row{%s}={%s},", settings$i[k], settings$tabularray[k])
+    } else if ("j" %in% colnames(settings)) {
+      spec <- sprintf("column{%s}={%s},", settings$j[k], settings$tabularray[k])
+    } 
+    cal <- call("tabularray_insert", content = spec, type = "inner")
+    out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal)))
+  }
 
-  # important for group_tt()
-  out <- meta(out, "body", body)
+  out <- tabularray_insert(out, content = tabularray_inner, type = "inner")
+  out <- tabularray_insert(out, content = tabularray_outer, type = "outer")
 
   return(out)
 }  
 
+tabularray_insert <- function(x, content = NULL, type = "body") {
+  if (is.null(content)) return(x)
+
+  m <- meta(x)
+  out <- strsplit(x, "\n")[[1]]
+  comment <- switch(type,
+  "body" = "% tabularray inner close",
+  "outer" = "% tabularray outer close",
+  "inner" = "% tabularray inner close")
+  idx <- grep(comment, out)
+
+  content <- trimws(content)
+  if (!grepl(",$", content)) content <- paste0(content, ",")
+
+  if (type == "body") {
+    out <- c(out[1:idx], content, out[(idx + 1):length(out)])
+  } else {
+    out <- c(out[1:(idx - 1)], content, out[idx:length(out)])
+  }
+
+  out <- paste(out, collapse = "\n")
+  class(out) <- class(x)
+  attr(out, "tinytable_meta") <- m
+  return(out)
+}
+
 
 
 ## not longer used, but took a while to collect and might be useful in the future