From fd2fb73b58f751adba3d6937fa6960fb653141fe Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Mon, 15 Jan 2024 21:35:02 -0500 Subject: [PATCH] major breakage --- R/group_tabularray.R | 4 +- R/sanity.R | 2 + R/style_tabularray.R | 127 +++++++++++++++++++++-- R/style_tt.R | 237 +++++++++++++------------------------------ R/tt_tabularray.R | 12 +-- 5 files changed, 195 insertions(+), 187 deletions(-) diff --git a/R/group_tabularray.R b/R/group_tabularray.R index db568387..e75d66a0 100644 --- a/R/group_tabularray.R +++ b/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) { diff --git a/R/sanity.R b/R/sanity.R index defff3fb..d1804d9e 100644 --- a/R/sanity.R +++ b/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)) diff --git a/R/style_tabularray.R b/R/style_tabularray.R index fe25c585..5df7c42e 100644 --- a/R/style_tabularray.R +++ b/R/style_tabularray.R @@ -1,12 +1,119 @@ 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) { + + if (meta(x, "output") != "latex") return(x) - m <- meta(x) - if (m$output != "latex") return(x) out <- x + ival <- if (is.null(i)) seq_len(meta(x, "nrows")) else i + jval <- if (is.null(j)) seq_len(meta(x, "ncols")) else i + + # 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[, "i", drop = FALSE]) + } else if (is.null(i)) { + settings <- unique(settings[, "j", drop = FALSE]) + } else if (is.null(j)) { + settings <- unique(settings[, "i", drop = FALSE]) + } + } + + 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) + } + + 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)) + } + + 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))) + } + + if (!is.null(tabularray_inner) || !is.null(tabularray_outer)) { + cal <- call("tabularray_insert", content = tabularray_inner, type = "inner") + out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal))) + cal <- call("tabularray_insert", content = tabularray_outer, type = "outer") + out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal))) + } + out <- tabularray_insert(out, content = inner, type = "inner") out <- tabularray_insert(out, content = outer, type = "outer") out <- tabularray_insert(out, content = body, type = "body") @@ -23,14 +130,14 @@ tabularray_insert <- function(x, content = NULL, type = "body") { m <- meta(x) out <- strsplit(x, "\n")[[1]] comment <- switch(type, - "body" = "% tabularray inner close", - "outer" = "% tabularray outer close", - "inner" = "% tabularray inner close") + "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 { diff --git a/R/style_tt.R b/R/style_tt.R index 0b67e1b3..076dc10f 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -72,52 +72,18 @@ style_tt <- function (x, jval <- j } } - ncells <- length(ival) * length(jval) - ncols <- length(jval) - nrows <- length(ival) + assert_style_tt( x = x, i = i, j = j, ival = ival, jval = jval, bold = bold, italic = italic, monospace = monospace, underline = underline, strikeout = strikeout, color = color, background = background, fontsize = fontsize, width = width, align = align, colspan = colspan, indent = indent, tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer, bootstrap_css = bootstrap_css, - bootstrap_css_rule = bootstrap_css_rule - ) - - - if (!is.null(colspan)) { - if (meta(x)$output == "html") { - warning("`colspan` is not available for HTML tables yet. You can follow progress here: https://github.com/vincentarelbundock/tinytable/issues/43", call. = FALSE ) - } - if (is.null(j) || is.null(i) || (!is.null(i) && length(ival) != 1) || (!is.null(j) && length(jval) != 1)) { - stop("`i` and `j` must be of length 1 when using `colspan`.", call. = FALSE) - } - assert_integerish(colspan, len = 1, lower = 1, upper = jval + meta(x)$ncols) - } + bootstrap_css_rule = bootstrap_css_rule) - settings <- expand.grid(i = ival, j = jval) + settings <- expand.grid(i = ival, j = jval, bootstrap = "", tabularray = "") if (is.null(i) && !is.null(j)) { settings <- settings[order(settings$i, settings$j), ] } - if (meta(x)$output == "latex") { - # 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[, "i", drop = FALSE]) - } else if (is.null(i)) { - settings <- unique(settings[, "j", drop = FALSE]) - } else if (is.null(j)) { - settings <- unique(settings[, "i", drop = FALSE]) - } - } - } - - settings$tabularray <- settings$bootstrap <- "" - - # do not style the header. JS 0-indexing - if (meta(x)$output == "latex" && "i" %in% colnames(settings)) { - settings$i <- settings$i + meta(x)$nhead - } - # settings have a different size for latex, so bootstrap breaks if (meta(x)$output == "html") { vectorize_bootstrap <- function(setting, userinput, string) { @@ -168,84 +134,16 @@ style_tt <- function (x, settings$bootstrap <- vectorize_bootstrap(settings$bootstrap, width, "width: %s;") } - # 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) - } - - 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("style_tabularray", body = b) - 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)) - } - - settings$tabularray <- trimws(gsub("cmd=,", "", settings$tabularray)) - settings$tabularray <- trimws(gsub("\\s+", "", settings$tabularray)) - settings$tabularray <- trimws(gsub(",+", ",", settings$tabularray)) + out <- style_tabularray( + x = x, i = i, j = j, bold = bold, italic = italic, monospace = monospace, underline = underline, strikeout = strikeout, + color = color, background = background, fontsize = fontsize, width = width, align = align, colspan = colspan, indent = indent, + tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer) for (k in seq_len(nrow(settings))) { out <- style_bootstrap(out, i = settings$i[k], j = settings$j[k], css = bootstrap_css) out <- style_bootstrap(out, i = settings$i[k], j = settings$j[k], css = settings$bootstrap[k]) } - span <- if (!is.null(colspan)) paste0("c=", colspan, ",") else "" - - if (meta(x)$output == "latex") { - 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("style_tabularray", inner = spec) - out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal))) - } - } - if (!is.null(tabularray_inner) || !is.null(tabularray_outer)) { - cal <- call("style_tabularray", inner = tabularray_inner, outer = tabularray_outer) - out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal))) - } if (!is.null(bootstrap_css) || !is.null(bootstrap_css_rule)) { cal <- call("style_bootstrap", i = ival, j = jval, css = bootstrap_css, css_rule = bootstrap_css_rule) out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal))) @@ -279,66 +177,67 @@ assert_style_tt <- function (x, m <- meta(x) - assert_integerish(ival, lower = 1 - meta(x)$nhead, upper = meta(x)$nrows, name = "i") - assert_integerish(jval, lower = 1, upper = meta(x)$ncols, name = "j") - assert_string(width, null.ok = TRUE) - assert_choice(align, c("c", "l", "r"), null.ok = TRUE) - assert_numeric(indent, len = 1, lower = 0) - assert_character(background, null.ok = TRUE) - assert_character(color, null.ok = TRUE) - assert_integerish(fontsize, null.ok = TRUE) - assert_logical(bold) - assert_logical(italic) - assert_logical(monospace) - assert_logical(underline) - assert_logical(strikeout) - assert_character(bootstrap_css, null.ok = TRUE) - assert_string(bootstrap_css_rule, null.ok = TRUE) - - # 1 - if (is.null(i) && is.null(j)) { - assert_length(color, len = 1, null.ok = TRUE) - assert_length(background, len = 1, null.ok = TRUE) - assert_length(fontsize, len = 1, null.ok = TRUE) - assert_length(bold, len = 1) - assert_length(italic, len = 1) - assert_length(monospace, len = 1) - assert_length(underline, len = 1) - assert_length(strikeout, len = 1) - - # 1 or #rows - } else if (!is.null(i) && is.null(j)) { - assert_length(color, len = c(1, length(ival)), null.ok = TRUE) - assert_length(background, len = c(1, length(ival)), null.ok = TRUE) - assert_length(fontsize, len = c(1, length(ival)), null.ok = TRUE) - assert_length(bold, len = c(1, length(ival))) - assert_length(italic, len = c(1, length(ival))) - assert_length(monospace, len = c(1, length(ival))) - assert_length(underline, len = c(1, length(ival))) - assert_length(strikeout, len = c(1, length(ival))) - - # 1 or #cols - } else if (is.null(i) && !is.null(j)) { - assert_length(color, len = c(1, length(jval)), null.ok = TRUE) - assert_length(background, len = c(1, length(jval)), null.ok = TRUE) - assert_length(fontsize, len = c(1, length(jval)), null.ok = TRUE) - assert_length(bold, len = c(1, length(jval))) - assert_length(italic, len = c(1, length(jval))) - assert_length(monospace, len = c(1, length(jval))) - assert_length(underline, len = c(1, length(jval))) - assert_length(strikeout, len = c(1, length(jval))) - - # 1 or #cells - } else if (!is.null(i) && !is.null(j)) { - assert_length(color, len = c(1, length(ival) * length(jval)), null.ok = TRUE) - assert_length(background, len = c(1, length(ival) * length(jval)), null.ok = TRUE) - assert_length(fontsize, len = c(1, length(ival) * length(jval)), null.ok = TRUE) - assert_length(bold, len = c(1, length(ival) * length(jval))) - assert_length(italic, len = c(1, length(ival) * length(jval))) - assert_length(monospace, len = c(1, length(ival) * length(jval))) - assert_length(underline, len = c(1, length(ival) * length(jval))) - assert_length(strikeout, len = c(1, length(ival) * length(jval))) - } + # assert_integerish(colspan, len = 1, lower = 1, null.ok = TRUE) + # assert_integerish(ival, lower = 1 - meta(x)$nhead, upper = meta(x)$nrows, name = "i") + # assert_integerish(jval, lower = 1, upper = meta(x)$ncols, name = "j") + # assert_string(width, null.ok = TRUE) + # assert_choice(align, c("c", "l", "r"), null.ok = TRUE) + # assert_numeric(indent, len = 1, lower = 0) + # assert_character(background, null.ok = TRUE) + # assert_character(color, null.ok = TRUE) + # assert_integerish(fontsize, null.ok = TRUE) + # assert_logical(bold) + # assert_logical(italic) + # assert_logical(monospace) + # assert_logical(underline) + # assert_logical(strikeout) + # assert_character(bootstrap_css, null.ok = TRUE) + # assert_string(bootstrap_css_rule, null.ok = TRUE) + # + # # 1 + # if (is.null(i) && is.null(j)) { + # assert_length(color, len = 1, null.ok = TRUE) + # assert_length(background, len = 1, null.ok = TRUE) + # assert_length(fontsize, len = 1, null.ok = TRUE) + # assert_length(bold, len = 1) + # assert_length(italic, len = 1) + # assert_length(monospace, len = 1) + # assert_length(underline, len = 1) + # assert_length(strikeout, len = 1) + # + # # 1 or #rows + # } else if (!is.null(i) && is.null(j)) { + # assert_length(color, len = c(1, length(ival)), null.ok = TRUE) + # assert_length(background, len = c(1, length(ival)), null.ok = TRUE) + # assert_length(fontsize, len = c(1, length(ival)), null.ok = TRUE) + # assert_length(bold, len = c(1, length(ival))) + # assert_length(italic, len = c(1, length(ival))) + # assert_length(monospace, len = c(1, length(ival))) + # assert_length(underline, len = c(1, length(ival))) + # assert_length(strikeout, len = c(1, length(ival))) + # + # # 1 or #cols + # } else if (is.null(i) && !is.null(j)) { + # assert_length(color, len = c(1, length(jval)), null.ok = TRUE) + # assert_length(background, len = c(1, length(jval)), null.ok = TRUE) + # assert_length(fontsize, len = c(1, length(jval)), null.ok = TRUE) + # assert_length(bold, len = c(1, length(jval))) + # assert_length(italic, len = c(1, length(jval))) + # assert_length(monospace, len = c(1, length(jval))) + # assert_length(underline, len = c(1, length(jval))) + # assert_length(strikeout, len = c(1, length(jval))) + # + # # 1 or #cells + # } else if (!is.null(i) && !is.null(j)) { + # assert_length(color, len = c(1, length(ival) * length(jval)), null.ok = TRUE) + # assert_length(background, len = c(1, length(ival) * length(jval)), null.ok = TRUE) + # assert_length(fontsize, len = c(1, length(ival) * length(jval)), null.ok = TRUE) + # assert_length(bold, len = c(1, length(ival) * length(jval))) + # assert_length(italic, len = c(1, length(ival) * length(jval))) + # assert_length(monospace, len = c(1, length(ival) * length(jval))) + # assert_length(underline, len = c(1, length(ival) * length(jval))) + # assert_length(strikeout, len = c(1, length(ival) * length(jval))) + # } } diff --git a/R/tt_tabularray.R b/R/tt_tabularray.R index d614f7b3..ac41a742 100644 --- a/R/tt_tabularray.R +++ b/R/tt_tabularray.R @@ -51,20 +51,20 @@ tt_tabularray <- function(x, caption, theme, width, notes) { if (!is.null(width)) { tabularray_cols <- rep("X[]", ncol(x)) spec <- sprintf("width={%s\\linewidth},", round(width, 4)) - out <- style_tabularray(out, inner = spec) + out <- tabularray_insert(out, content = spec, type = "inner") } else { tabularray_cols <- rep("Q[]", ncol(x)) } # colspec (we don't need rowspec) colspec <- sprintf("colspec={%s},", paste(tabularray_cols, collapse = "")) - out <- style_tabularray(out, inner = colspec) + out <- tabularray_insert(out, content = colspec, type = "inner") # themes if (theme == "grid") { - out <- style_tabularray(out, inner = "hlines={},vlines={},") + out <- tabularray_insert(out, content = "hlines={},vlines={},", type = "inner") } else if (theme == "striped") { - out <- style_tabularray(out, inner = "row{even}={bg=black!5!white},") + out <- tabularray_insert(out, content = "row{even}={bg=black!5!white},", type = "inner") } # notes @@ -72,7 +72,7 @@ tt_tabularray <- function(x, caption, theme, width, notes) { out <- sub("\\begin{tblr}", "\\begin{talltblr}", out, fixed = TRUE) out <- sub("\\end{tblr}", "\\end{talltblr}", out, fixed = TRUE) # otherwise an empty caption is created automatically - out <- style_tabularray(out, outer = "entry=none,label=none") + out <- tabularray_insert(out, content = "entry=none,label=none", type = "outer") if (is.null(names(notes))) { lab <- rep("", length(notes)) } else { @@ -81,7 +81,7 @@ tt_tabularray <- function(x, caption, theme, width, notes) { notes <- unlist(notes) for (k in seq_along(notes)) { spec <- sprintf("note{%s}={%s}", lab[k], notes[k]) - out <- style_tabularray(out, outer = spec) + out <- tabularray_insert(out, content = spec, type = "outer") } }