", jstring)
@@ -67,7 +69,8 @@ group_bootstrap_row <- function(x, i, j, indent = 1, ...) {
# 0-indexing
i[g] + x@nhead - 1,
ncol(x),
- names(i)[g])
+ names(i)[g]
+ )
out <- lines_insert(out, js, "tinytable span after", "after")
# out <- bootstrap_setting(out, new = js, component = "cell")
}
@@ -78,7 +81,8 @@ group_bootstrap_row <- function(x, i, j, indent = 1, ...) {
"insertSpanRow(",
paste0("insertSpanRow_", get_id(""), "("),
out,
- fixed = TRUE)
+ fixed = TRUE
+ )
idx <- insert_values(seq_len(nrow(x)), rep(NA, length(i)), i)
diff --git a/R/group_grid.R b/R/group_grid.R
index 08f32173..9e0e5729 100644
--- a/R/group_grid.R
+++ b/R/group_grid.R
@@ -9,7 +9,8 @@ setMethod(
x <- group_grid_row(x, i)
x <- group_grid_col(x, j)
return(x)
- })
+ }
+)
group_grid_col <- function(x, j, ...) {
diff --git a/R/group_tabularray.R b/R/group_tabularray.R
index a2a971de..1565b88e 100644
--- a/R/group_tabularray.R
+++ b/R/group_tabularray.R
@@ -9,7 +9,8 @@ setMethod(
x <- group_tabularray_col(x, j, ...)
x <- group_tabularray_row(x, i, indent)
return(x)
- })
+ }
+)
group_tabularray_col <- function(x, j, ihead, ...) {
@@ -38,7 +39,8 @@ group_tabularray_col <- function(x, j, ihead, ...) {
out[1:idx],
# empty lines can break latex
trimws(header),
- out[(idx + 1):length(out)])
+ out[(idx + 1):length(out)]
+ )
out <- paste(out, collapse = "\n")
# rebuild including meta before style_tt
@@ -54,7 +56,8 @@ group_tabularray_col <- function(x, j, ihead, ...) {
i = ihead,
j = z,
align = "c",
- colspan = cs)
+ colspan = cs
+ )
x <- do.call(style_tt, args)
}
diff --git a/R/group_tt.R b/R/group_tt.R
index 05cc0056..ce198c6b 100644
--- a/R/group_tt.R
+++ b/R/group_tt.R
@@ -11,15 +11,16 @@
#' @param ... Other arguments are ignored.
#' @return An object of class `tt` representing the table.
#' @param indent integer number of `pt` to use when indenting the non-labelled rows.
+#' @template limitations_word_markdown
#' @details
#' Warning: The `style_tt()` can normally be used to style the group headers, as expected, but that feature is not available for Markdown and Word tables.
#' @examples
#'
#' # vector of row labels
#' dat <- data.frame(
-#' label = c("a", "a", "a", "b", "b", "c", "a", "a"),
-#' x1 = rnorm(8),
-#' x2 = rnorm(8))
+#' label = c("a", "a", "a", "b", "b", "c", "a", "a"),
+#' x1 = rnorm(8),
+#' x2 = rnorm(8))
#' tt(dat[, 2:3]) |> group_tt(i = dat$label)
#'
#' # named lists of labels
@@ -51,7 +52,6 @@
#' group_tt(j = list("Hello" = 1:2, "World" = 3:4, "Hello" = 5:6)) |>
#' group_tt(j = list("Foo" = 1:3, "Bar" = 4:6))
#'
-
group_tt <- function(x, i = NULL, j = NULL, indent = 1, ...) {
# ... is important for ihead passing
@@ -78,7 +78,7 @@ group_tt <- function(x, i = NULL, j = NULL, indent = 1, ...) {
x@ngroupi <- length(i)
x@nrow <- x@nrow + x@ngroupi
x@group_i_idx <- as.numeric(i)
-
+
if (isTRUE(indent > 0)) {
idx_indent <- setdiff(seq_len(nrow(x)), i + seq_along(i) - 1)
x <- style_tt(x, i = idx_indent, j = 1, indent = indent)
diff --git a/R/group_typst.R b/R/group_typst.R
index 2118ff01..5948fdbe 100644
--- a/R/group_typst.R
+++ b/R/group_typst.R
@@ -16,7 +16,8 @@ setMethod(
}
return(out)
- })
+ }
+)
group_typst_row <- function(x, i, indent, ...) {
@@ -31,7 +32,8 @@ group_typst_row <- function(x, i, indent, ...) {
for (idx in rev(seq_along(i))) {
mid <- append(mid,
sprintf("table.cell(colspan: %s)[%s],", ncol(x), names(i)[idx]),
- after = i[idx] - 1)
+ after = i[idx] - 1
+ )
}
tab <- c(top, mid, bot)
tab <- paste(tab, collapse = "\n")
@@ -56,7 +58,8 @@ group_typst_col <- function(x, j, ihead, ...) {
col <- ifelse(
trimws(lab) == "",
sprintf("[%s],", lab),
- sprintf("table.cell(stroke: (bottom: .05em + black), colspan: %s, align: center)[%s],", len, lab))
+ sprintf("table.cell(stroke: (bottom: .05em + black), colspan: %s, align: center)[%s],", len, lab)
+ )
col <- paste(col, collapse = "")
out <- lines_insert(out, col, "repeat: true", "after")
if (!any(grepl("column-gutter", out))) {
diff --git a/R/last_style.R b/R/last_style.R
index d132560e..69a52d96 100644
--- a/R/last_style.R
+++ b/R/last_style.R
@@ -1,25 +1,27 @@
last_valid <- function(x) {
- x <- x[!is.na(x)]
- if (length(x) == 0) return(NA)
- return(utils::tail(x, 1))
+ x <- x[!is.na(x)]
+ if (length(x) == 0) {
+ return(NA)
+ }
+ return(utils::tail(x, 1))
}
last_style_vec <- function(x) {
- if (is.factor(x)) {
- x <- as.character(x)
- }
- if (is.logical(x) && !all(is.na(x))) {
- x <- any(sapply(x, isTRUE))
- } else {
- x <- last_valid(x)
- }
- return(x)
+ if (is.factor(x)) {
+ x <- as.character(x)
+ }
+ if (is.logical(x) && !all(is.na(x))) {
+ x <- any(sapply(x, isTRUE))
+ } else {
+ x <- last_valid(x)
+ }
+ return(x)
}
last_style <- function(sty) {
- sty <- split(sty, list(sty$i, sty$j))
- sty <- lapply(sty, function(k) lapply(k, last_style_vec))
- sty <- do.call(rbind, lapply(sty, data.frame))
- return(sty)
+ sty <- split(sty, list(sty$i, sty$j))
+ sty <- lapply(sty, function(k) lapply(k, last_style_vec))
+ sty <- do.call(rbind, lapply(sty, data.frame))
+ return(sty)
}
diff --git a/R/package.R b/R/package.R
index a133c157..e321b112 100644
--- a/R/package.R
+++ b/R/package.R
@@ -2,5 +2,5 @@
# 2012 hadley says "globalVariables is a hideous hack and I will never use it"
# 2014 hadley updates his own answer with globalVariables as one of "two solutions"
utils::globalVariables(c(
-"bootstrap"
+ "bootstrap"
))
diff --git a/R/plot_tt.R b/R/plot_tt.R
index 95066323..3c0b0209 100644
--- a/R/plot_tt.R
+++ b/R/plot_tt.R
@@ -102,7 +102,8 @@ plot_tt <- function(x,
xlim = xlim,
height = height,
images = images,
- assets = assets)
+ assets = assets
+ )
cal <- c(cal, list(...))
cal <- do.call(call, cal)
@@ -130,9 +131,9 @@ plot_tt_lazy <- function(x,
assert_dependency("ggplot2")
images <- NULL
- if(isTRUE(x@output == "html") && isTRUE(x@portable)) {
- path_full <- tempdir()
- assets <- tempdir()
+ if (isTRUE(x@output == "html") && isTRUE(x@portable)) {
+ path_full <- tempdir()
+ assets <- tempdir()
} else {
path_full <- file.path(x@output_dir, assets)
}
@@ -182,7 +183,7 @@ plot_tt_lazy <- function(x,
if (isTRUE(x@output == "latex")) {
cell <- "\\includegraphics[height=%sem]{%s}"
cell <- sprintf(cell, height, images)
- } else if(isTRUE(x@output == "html") && isTRUE(x@portable)) {
+ } else if (isTRUE(x@output == "html") && isTRUE(x@portable)) {
assert_dependency("base64enc")
http <- grepl("^http", trimws(images))
@@ -192,7 +193,8 @@ plot_tt_lazy <- function(x,
cell <- ifelse(
grepl("^http", trimws(images)),
'',
- '')
+ ''
+ )
cell <- sprintf(cell, images, height)
} else if (isTRUE(x@output == "markdown")) {
cell <- "{ height=%s }"
@@ -250,7 +252,7 @@ encode <- function(images) {
assert_dependency("base64enc")
ext <- tools::file_ext(images)
- if(any(ext == "")) stop("Empty image extensions are not allowed", call. = FALSE)
+ if (any(ext == "")) stop("Empty image extensions are not allowed", call. = FALSE)
encoded <- sapply(images, base64enc::base64encode)
sprintf("data:image/%s;base64, %s", ext, encoded)
diff --git a/R/print.R b/R/print.R
index 4a1b430c..4a5f0f8c 100644
--- a/R/print.R
+++ b/R/print.R
@@ -1,6 +1,7 @@
#' Print a tinytable object in knitr
#'
#' @keywords internal
+#' @rawNamespace S3method(knitr::knit_print, tinytable)
#' @return A string with class `knit_asis` to be printed in Rmarkdown or Quarto documents.
#' @export
knit_print.tinytable <- function(x,
@@ -77,7 +78,7 @@ print.tinytable <- function(x,
tinytable_print_rstudio <- getOption("tinytable_print_rstudio_notebook", default = "inline")
assert_choice(tinytable_print_rstudio, c("inline", "viewer"))
if (tinytable_print_rstudio == "inline") {
- tab = sprintf("\n```{=html}\n%s\n```\n`", tab)
+ tab <- sprintf("\n```{=html}\n%s\n```\n`", tab)
print(knitr::asis_output(tab))
return(invisible(x))
}
diff --git a/R/rbind2.R b/R/rbind2.R
index d704446c..510923e9 100644
--- a/R/rbind2.R
+++ b/R/rbind2.R
@@ -1,5 +1,5 @@
#' Combine `tinytable` objects by rows (vertically)
-#'
+#'
#' @details
#' `format_tt()` calls applied to `x` or `y` are evaluated before binding, to allow distinct formatting for each panel.
#'
@@ -25,55 +25,56 @@
#' @aliases rbind2
#' @examples
#' library(tinytable)
-#' x = tt(mtcars[1:3, 1:2], caption = "Combine two tiny tables.")
-#' y = tt(mtcars[4:5, 8:10])
-#'
+#' x <- tt(mtcars[1:3, 1:2], caption = "Combine two tiny tables.")
+#' y <- tt(mtcars[4:5, 8:10])
+#'
#' # rbind() does not support additional aarguments
#' # rbind2() supports additional arguments
-#'
+#'
#' # basic combination
#' rbind(x, y)
-#'
+#'
#' rbind(x, y) |> format_tt(replace = "")
-#'
+#'
#' # omit y header
#' rbind2(x, y, headers = FALSE)
-#'
+#'
#' # bind by position rather than column names
#' rbind2(x, y, use_names = FALSE)
-#'
+#'
#' @importFrom methods rbind2
#' @export
-setMethod("rbind2",
- signature = signature(x = "tinytable", y = "tinytable"),
- definition = function(x, y,
- use_names = TRUE,
- headers = TRUE,
- ...) {
+setMethod("rbind2",
+ signature = signature(x = "tinytable", y = "tinytable"),
+ definition = function(x, y,
+ use_names = TRUE,
+ headers = TRUE,
+ ...) {
+ assert_class(x, "tinytable")
+ assert_class(y, "tinytable")
+ assert_dependency("data.table")
+ assert_flag(use_names)
+ assert_flag(headers)
- assert_class(x, "tinytable")
- assert_class(y, "tinytable")
- assert_dependency("data.table")
- assert_flag(use_names)
- assert_flag(headers)
+ x_df <- print(x, output = "dataframe")
+ y_df <- print(y, output = "dataframe")
- x_df <- print(x, output = "dataframe")
- y_df <- print(y, output = "dataframe")
+ if (isTRUE(headers) && !is.null(colnames(y))) {
+ y_df <- base::rbind(colnames(y_df), y_df)
+ }
- if (isTRUE(headers) && !is.null(colnames(y))) {
- y_df <- base::rbind(colnames(y_df), y_df)
- }
+ out <- data.table::rbindlist(list(x_df, y_df),
+ fill = TRUE,
+ use.names = use_names
+ )
- out <- data.table::rbindlist(list(x_df, y_df),
- fill = TRUE,
- use.names = use_names)
+ out <- tt(out)
- out <- tt(out)
+ out@output <- x@output
+ out@notes <- c(x@notes, y@notes)
+ out@width <- x@width
+ out@caption <- x@caption
- out@output <- x@output
- out@notes <- c(x@notes, y@notes)
- out@width <- x@width
- out@caption <- x@caption
-
- return(out)
-})
+ return(out)
+ }
+)
diff --git a/R/sanity.R b/R/sanity.R
index cf267bb4..ff119a2f 100644
--- a/R/sanity.R
+++ b/R/sanity.R
@@ -1,14 +1,14 @@
usepackage_latex <- function(name, options = NULL, extra_lines = NULL) {
- assert_dependency("rmarkdown")
- invisible(knitr::knit_meta_add(list(rmarkdown::latex_dependency(name, options, extra_lines))))
+ assert_dependency("rmarkdown")
+ invisible(knitr::knit_meta_add(list(rmarkdown::latex_dependency(name, options, extra_lines))))
}
sanity_align <- function(align, i) {
- if (any(grepl("d", align)) && !is.null(i)) {
- msg <- "d column alignment can only be applied to entire columns. `i` must be `NULL`."
- stop(msg, call. = FALSE)
- }
+ if (any(grepl("d", align)) && !is.null(i)) {
+ msg <- "d column alignment can only be applied to entire columns. `i` must be `NULL`."
+ stop(msg, call. = FALSE)
+ }
}
@@ -31,78 +31,104 @@ sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) {
}
return(out)
}
+sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) {
+ if (is.character(i)) {
+ assert_choice(i, c("notes", "caption"))
+ return(i)
+ } else if (is.matrix(i) && is.logical(i)) {
+ return(i)
+ }
+ out <- seq_len(nrow(x))
+ assert_numeric(i, null.ok = TRUE, name = "i")
+ if (is.null(i) && isTRUE(lazy)) {
+ out <- NA
+ attr(out, "null") <- TRUE
+ attr(out, "body") <- seq_len(nrow(x))
+ attr(out, "head") <- integer()
+ } else {
+ if (!is.null(i)) {
+ out <- i
+ } else if (inherits(x, "tinytable")) {
+ out <- seq_len(nrow(x@table_dataframe))
+ }
+ attr(out, "null") <- FALSE
+ attr(out, "body") <- out[out > 0]
+ attr(out, "head") <- out[out < 1]
+ }
+ return(out)
+}
sanitize_j <- function(j, x) {
- # regex
- if (is.character(j) && length(j) == 1 && !is.null(colnames(x))) {
- out <- grep(j, colnames(x), perl = TRUE)
- # full names
- } else if (is.character(j) && length(j) > 1 && !is.null(colnames(x))) {
- bad <- setdiff(j, colnames(x))
- if (length(bad) > 0) {
- msg <- sprintf("Missing columns: %s", paste(bad, collapse = ", "))
- stop(msg, call. = FALSE)
- }
- out <- which(colnames(x) %in% j)
+ # regex
+ if (is.character(j) && length(j) == 1 && !is.null(colnames(x))) {
+ out <- grep(j, colnames(x), perl = TRUE)
+ # full names
+ } else if (is.character(j) && length(j) > 1 && !is.null(colnames(x))) {
+ bad <- setdiff(j, colnames(x))
+ if (length(bad) > 0) {
+ msg <- sprintf("Missing columns: %s", paste(bad, collapse = ", "))
+ stop(msg, call. = FALSE)
+ }
+ out <- which(colnames(x) %in% j)
+ } else {
+ assert_integerish(j, lower = 1, upper = ncol(x), null.ok = TRUE)
+ if (is.null(j)) {
+ out <- seq_len(ncol(x))
} else {
- assert_integerish(j, lower = 1, upper = ncol(x), null.ok = TRUE)
- if (is.null(j)) {
- out <- seq_len(ncol(x))
- } else {
- out <- j
- }
+ out <- j
}
- attr(out, "null") <- is.null(j)
- return(out)
+ }
+ attr(out, "null") <- is.null(j)
+ return(out)
}
sanitize_output <- function(output) {
- assert_choice(output, choice = c("tinytable", "markdown", "latex", "html", "typst", "dataframe", "gfm"), null.ok = TRUE)
-
- # default output format
- if (is.null(output) || isTRUE(output == "tinytable")) {
- has_viewer <- interactive() && !is.null(getOption("viewer"))
- out <- if (has_viewer) "html" else "markdown"
- } else {
- out <- output
- }
-
- if (isTRUE(check_dependency("knitr"))) {
- if (isTRUE(knitr::pandoc_to() %in% c("latex", "beamer"))) {
- flag <- getOption("tinytable_latex_preamble", default = TRUE)
- if (isTRUE(flag)) {
- usepackage_latex("float")
- usepackage_latex("tabularray", extra_lines = c(
- "\\usepackage[normalem]{ulem}",
- "\\usepackage{graphicx}",
- "\\UseTblrLibrary{booktabs}",
- "\\UseTblrLibrary{rotating}",
- "\\UseTblrLibrary{siunitx}",
- "\\NewTableCommand{\\tinytableDefineColor}[3]{\\definecolor{#1}{#2}{#3}}",
- "\\newcommand{\\tinytableTabularrayUnderline}[1]{\\underline{#1}}",
- "\\newcommand{\\tinytableTabularrayStrikeout}[1]{\\sout{#1}}"
- ))
- }
- if (is.null(output)) out <- "latex"
- } else if (isTRUE(knitr::pandoc_to() %in% c("html", "revealjs"))) {
- if (is.null(output)) out <- "html"
- } else if (isTRUE(knitr::pandoc_to() == "typst")) {
- if (is.null(output)) out <- "typst"
- if (isTRUE(check_dependency("quarto"))) {
- if (isTRUE(quarto::quarto_version() < "1.5.29")) {
- msg <- "Typst tables require version 1.5.29 or later of Quarto and version 0.11.0 or later of Typst. This software may (or may not) only be available in pre-release builds: https://quarto.org/docs/download"
- stop(msg, call. = FALSE)
- }
- }
- } else if (isTRUE(knitr::pandoc_to() == "docx")) {
- if (is.null(output)) out <- "markdown"
- } else {
- if (is.null(output)) out <- "markdown"
+ assert_choice(output, choice = c("tinytable", "markdown", "latex", "html", "typst", "dataframe", "gfm"), null.ok = TRUE)
+
+ # default output format
+ if (is.null(output) || isTRUE(output == "tinytable")) {
+ has_viewer <- interactive() && !is.null(getOption("viewer"))
+ out <- if (has_viewer) "html" else "markdown"
+ } else {
+ out <- output
+ }
+
+ if (isTRUE(check_dependency("knitr"))) {
+ if (isTRUE(knitr::pandoc_to() %in% c("latex", "beamer"))) {
+ flag <- getOption("tinytable_latex_preamble", default = TRUE)
+ if (isTRUE(flag)) {
+ usepackage_latex("float")
+ usepackage_latex("tabularray", extra_lines = c(
+ "\\usepackage[normalem]{ulem}",
+ "\\usepackage{graphicx}",
+ "\\UseTblrLibrary{booktabs}",
+ "\\UseTblrLibrary{rotating}",
+ "\\UseTblrLibrary{siunitx}",
+ "\\NewTableCommand{\\tinytableDefineColor}[3]{\\definecolor{#1}{#2}{#3}}",
+ "\\newcommand{\\tinytableTabularrayUnderline}[1]{\\underline{#1}}",
+ "\\newcommand{\\tinytableTabularrayStrikeout}[1]{\\sout{#1}}"
+ ))
+ }
+ if (is.null(output)) out <- "latex"
+ } else if (isTRUE(knitr::pandoc_to() %in% c("html", "revealjs"))) {
+ if (is.null(output)) out <- "html"
+ } else if (isTRUE(knitr::pandoc_to() == "typst")) {
+ if (is.null(output)) out <- "typst"
+ if (isTRUE(check_dependency("quarto"))) {
+ if (isTRUE(quarto::quarto_version() < "1.5.29")) {
+ msg <- "Typst tables require version 1.5.29 or later of Quarto and version 0.11.0 or later of Typst. This software may (or may not) only be available in pre-release builds: https://quarto.org/docs/download"
+ stop(msg, call. = FALSE)
}
+ }
+ } else if (isTRUE(knitr::pandoc_to() == "docx")) {
+ if (is.null(output)) out <- "markdown"
+ } else {
+ if (is.null(output)) out <- "markdown"
}
+ }
- return(out)
+ return(out)
}
@@ -110,315 +136,315 @@ sanitize_output <- function(output) {
#'
#' @noRd
check_dependency <- function(library_name) {
- flag <- requireNamespace(library_name, quietly = TRUE)
- if (isFALSE(flag)) {
- msg <- sprintf("Please install the `%s` package.", library_name)
- return(msg)
- } else {
- return(TRUE)
- }
+ flag <- requireNamespace(library_name, quietly = TRUE)
+ if (isFALSE(flag)) {
+ msg <- sprintf("Please install the `%s` package.", library_name)
+ return(msg)
+ } else {
+ return(TRUE)
+ }
}
assert_dependency <- function(library_name) {
- flag <- check_dependency(library_name)
- if (!isTRUE(flag)) stop(flag, call. = FALSE)
- return(invisible())
+ flag <- check_dependency(library_name)
+ if (!isTRUE(flag)) stop(flag, call. = FALSE)
+ return(invisible())
}
assert_choice <- function(x, choice, null.ok = FALSE, name = as.character(substitute(x))) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(TRUE)
- }
- if (is.character(x) && length(x) == 1 && x %in% choice) {
- return(TRUE)
- }
- msg <- sprintf(
- "`%s` must be one of: %s",
- name,
- paste(choice, collapse = ", ")
- )
- stop(msg, call. = FALSE)
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(TRUE)
+ }
+ if (is.character(x) && length(x) == 1 && x %in% choice) {
+ return(TRUE)
+ }
+ msg <- sprintf(
+ "`%s` must be one of: %s",
+ name,
+ paste(choice, collapse = ", ")
+ )
+ stop(msg, call. = FALSE)
}
check_string <- function(x, null.ok = FALSE) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(invisible(TRUE))
- }
- if (is.character(x) && length(x) == 1) {
- return(invisible(TRUE))
- }
- return(FALSE)
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(invisible(TRUE))
+ }
+ if (is.character(x) && length(x) == 1) {
+ return(invisible(TRUE))
+ }
+ return(FALSE)
}
assert_string <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- msg <- sprintf("`%s` must be a string.", name)
- if (!isTRUE(check_string(x, null.ok = null.ok))) {
- stop(msg, call. = FALSE)
- }
+ msg <- sprintf("`%s` must be a string.", name)
+ if (!isTRUE(check_string(x, null.ok = null.ok))) {
+ stop(msg, call. = FALSE)
+ }
}
check_flag <- function(x, null.ok = FALSE) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(TRUE)
- }
- if (is.logical(x) && length(x) == 1) {
- return(TRUE)
- }
- return(FALSE)
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(TRUE)
+ }
+ if (is.logical(x) && length(x) == 1) {
+ return(TRUE)
+ }
+ return(FALSE)
}
assert_flag <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- msg <- sprintf("`%s` must be a logical flag.", name)
- if (!isTRUE(check_flag(x, null.ok = null.ok))) {
- stop(msg, call. = FALSE)
- }
+ msg <- sprintf("`%s` must be a logical flag.", name)
+ if (!isTRUE(check_flag(x, null.ok = null.ok))) {
+ stop(msg, call. = FALSE)
+ }
}
check_function <- function(x, null.ok = FALSE) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(TRUE)
- }
- if (is.function(x)) {
- return(TRUE)
- }
- return(FALSE)
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(TRUE)
+ }
+ if (is.function(x)) {
+ return(TRUE)
+ }
+ return(FALSE)
}
assert_function <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- msg <- sprintf("`%s` must be a function.", name)
- if (!isTRUE(check_function(x, null.ok = null.ok))) {
- stop(msg, call. = FALSE)
- }
+ msg <- sprintf("`%s` must be a function.", name)
+ if (!isTRUE(check_function(x, null.ok = null.ok))) {
+ stop(msg, call. = FALSE)
+ }
}
assert_length <- function(x, len = 1, null.ok = FALSE, name = as.character(substitute(x))) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(invisible(TRUE))
- }
- msg <- sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", "))
- if (!length(x) %in% len) {
- stop(msg, call. = FALSE)
- }
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(invisible(TRUE))
+ }
+ msg <- sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", "))
+ if (!length(x) %in% len) {
+ stop(msg, call. = FALSE)
+ }
}
assert_logical <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(invisible(TRUE))
- }
- msg <- sprintf("`%s` must be a logical vector", name)
- if (!is.logical(x)) stop(msg, call. = FALSE)
+ if (is.null(x) && isTRUE(null.ok)) {
+ return(invisible(TRUE))
+ }
+ msg <- sprintf("`%s` must be a logical vector", name)
+ if (!is.logical(x)) stop(msg, call. = FALSE)
}
check_integerish <- function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(TRUE)
- }
- if (!is.numeric(x)) {
- return(FALSE)
- }
- x <- stats::na.omit(x)
- if (!is.null(len) && length(x) != len) {
- return(FALSE)
- }
- if (!is.null(lower) && any(x < lower)) {
- return(FALSE)
- }
- if (!is.null(upper) && any(x > upper)) {
- return(FALSE)
- }
- if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) {
- return(FALSE)
- }
+ if (is.null(x) && isTRUE(null.ok)) {
return(TRUE)
+ }
+ if (!is.numeric(x)) {
+ return(FALSE)
+ }
+ x <- stats::na.omit(x)
+ if (!is.null(len) && length(x) != len) {
+ return(FALSE)
+ }
+ if (!is.null(lower) && any(x < lower)) {
+ return(FALSE)
+ }
+ if (!is.null(upper) && any(x > upper)) {
+ return(FALSE)
+ }
+ if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) {
+ return(FALSE)
+ }
+ return(TRUE)
}
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))
- if (!is.null(lower) && any(x < lower)) msg <- paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
- if (!is.null(upper) && any(x > upper)) msg <- paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
- if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) msg <- paste0(msg, "; all values must be close to integers")
- stop(msg, call. = FALSE)
- }
+ 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))
+ if (!is.null(lower) && any(x < lower)) msg <- paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
+ if (!is.null(upper) && any(x > upper)) msg <- paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
+ if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) msg <- paste0(msg, "; all values must be close to integers")
+ stop(msg, call. = FALSE)
+ }
}
check_null <- function(x) {
- is.null(x)
+ is.null(x)
}
assert_null <- function(x, name = as.character(substitute(x))) {
- if (!isTRUE(check_null(x))) stop(sprintf("%s should be NULL.", name), call. = FALSE)
+ if (!isTRUE(check_null(x))) stop(sprintf("%s should be NULL.", name), call. = FALSE)
}
check_numeric <- function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) {
- if (is.null(x) && isTRUE(null.ok)) {
- return(TRUE)
- }
- if (!is.numeric(x)) {
- return(FALSE)
- }
- if (!is.null(len) && length(x) != len) {
- return(FALSE)
- }
- if (!is.null(lower) && any(x < lower)) {
- return(FALSE)
- }
- if (!is.null(upper) && any(x > upper)) {
- return(FALSE)
- }
+ if (is.null(x) && isTRUE(null.ok)) {
return(TRUE)
+ }
+ if (!is.numeric(x)) {
+ return(FALSE)
+ }
+ if (!is.null(len) && length(x) != len) {
+ return(FALSE)
+ }
+ if (!is.null(lower) && any(x < lower)) {
+ return(FALSE)
+ }
+ if (!is.null(upper) && any(x > upper)) {
+ return(FALSE)
+ }
+ return(TRUE)
}
assert_numeric <- function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
- msg <- sprintf("`%s` must be numeric", name)
- if (!isTRUE(check_numeric(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
- if (!is.null(len) && length(x) != len) msg <- paste0(msg, sprintf("; its length must be %s", len))
- if (!is.null(lower) && any(x < lower)) msg <- paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
- if (!is.null(upper) && any(x > upper)) msg <- paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
- stop(msg, call. = FALSE)
- }
+ msg <- sprintf("`%s` must be numeric", name)
+ if (!isTRUE(check_numeric(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) {
+ if (!is.null(len) && length(x) != len) msg <- paste0(msg, sprintf("; its length must be %s", len))
+ if (!is.null(lower) && any(x < lower)) msg <- paste0(msg, sprintf("; all values must be greater than or equal to %s", lower))
+ if (!is.null(upper) && any(x > upper)) msg <- paste0(msg, sprintf("; all values must be less than or equal to %s", upper))
+ stop(msg, call. = FALSE)
+ }
}
assert_data_frame <- function(x, min_rows = 0, min_cols = 0, name = as.character(substitute(x))) {
- msg <- sprintf("`%s` must be a data.frame.", name)
- if (!is.data.frame(x)) stop(msg, call. = FALSE)
- msg <- sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows)
- if (nrow(x) < min_rows) stop(msg, call. = FALSE)
- msg <- sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols)
- if (ncol(x) < min_cols) stop(msg, call. = FALSE)
+ msg <- sprintf("`%s` must be a data.frame.", name)
+ if (!is.data.frame(x)) stop(msg, call. = FALSE)
+ msg <- sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows)
+ if (nrow(x) < min_rows) stop(msg, call. = FALSE)
+ msg <- sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols)
+ if (ncol(x) < min_cols) stop(msg, call. = FALSE)
}
check_character <- function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
- if (isTRUE(null.ok) && is.null(x)) {
- return(TRUE)
- } else if (!is.character(x)) {
- msg <- sprintf("`%s` must be character.", name)
- return(msg)
- } else if (!is.null(len) && length(x) != len) {
- msg <- sprintf("`%s` must have length %s.", name, len)
- return(msg)
- }
+ if (isTRUE(null.ok) && is.null(x)) {
return(TRUE)
+ } else if (!is.character(x)) {
+ msg <- sprintf("`%s` must be character.", name)
+ return(msg)
+ } else if (!is.null(len) && length(x) != len) {
+ msg <- sprintf("`%s` must have length %s.", name, len)
+ return(msg)
+ }
+ return(TRUE)
}
assert_character <- function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
- flag <- check_character(x, len = len, null.ok = null.ok, name = name)
- if (!isTRUE(flag)) {
- stop(flag, call. = FALSE)
- } else {
- return(invisible(TRUE))
- }
+ flag <- check_character(x, len = len, null.ok = null.ok, name = name)
+ if (!isTRUE(flag)) {
+ stop(flag, call. = FALSE)
+ } else {
+ return(invisible(TRUE))
+ }
}
assert_list <- function(x, named = FALSE, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) {
- if (isTRUE(null.ok) && is.null(x)) {
- return(invisible(TRUE))
- }
- if (!is.list(x)) stop("Input is not a list.", call. = FALSE)
- if (isTRUE(named)) {
- if (is.null(names(x))) {
- stop(sprintf("`%s` should be named list.", name), call. = FALSE)
- }
+ if (isTRUE(null.ok) && is.null(x)) {
+ return(invisible(TRUE))
+ }
+ if (!is.list(x)) stop("Input is not a list.", call. = FALSE)
+ if (isTRUE(named)) {
+ if (is.null(names(x))) {
+ stop(sprintf("`%s` should be named list.", name), call. = FALSE)
}
- if (!is.null(len)) {
- if (length(x) != len) {
- stop(sprintf("`%s` must be of length %s.", name, len), call. = FALSE)
- }
+ }
+ if (!is.null(len)) {
+ if (length(x) != len) {
+ stop(sprintf("`%s` must be of length %s.", name, len), call. = FALSE)
}
+ }
}
assert_function <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- if (isTRUE(null.ok) && is.null(x)) {
- return(invisible(TRUE))
- }
- if (!is.function(x)) {
- msg <- sprintf("`%s` must be a function.", name)
- stop(msg, call. = FALSE)
- }
+ if (isTRUE(null.ok) && is.null(x)) {
+ return(invisible(TRUE))
+ }
+ if (!is.function(x)) {
+ msg <- sprintf("`%s` must be a function.", name)
+ stop(msg, call. = FALSE)
+ }
}
check_atomic_vector <- function(x, null.ok = FALSE, name = as.character(substitute(x))) {
- if (isTRUE(null.ok) && is.null(x)) {
- return(invisible(TRUE))
- }
- # doesn't work on glue::glue() output
- # flag <- is.atomic(x) && is.vector(x) && !is.list(x)
- flag <- is.atomic(x) && is.null(dim(x)) && length(x) > 0 && !is.list(x)
- if (flag) {
- out <- TRUE
- } else if (is.factor(x) && is.null(dim(x))) {
- out <- TRUE
- } else {
- out <- sprintf("`%s` must be an atomic vector.", name)
- }
- return(out)
+ if (isTRUE(null.ok) && is.null(x)) {
+ return(invisible(TRUE))
+ }
+ # doesn't work on glue::glue() output
+ # flag <- is.atomic(x) && is.vector(x) && !is.list(x)
+ flag <- is.atomic(x) && is.null(dim(x)) && length(x) > 0 && !is.list(x)
+ if (flag) {
+ out <- TRUE
+ } else if (is.factor(x) && is.null(dim(x))) {
+ out <- TRUE
+ } else {
+ out <- sprintf("`%s` must be an atomic vector.", name)
+ }
+ return(out)
}
assert_class <- function(x, classname) {
- if (!inherits(x, classname)) {
- msg <- sprintf("`x` must be of class `%s`.", classname)
- stop(msg, call. = FALSE)
- }
+ if (!inherits(x, classname)) {
+ msg <- sprintf("`x` must be of class `%s`.", classname)
+ stop(msg, call. = FALSE)
+ }
}
sanitize_notes <- function(notes) {
- if (is.character(notes) && length(notes) > 0) {
- notes <- as.list(notes)
- }
- assert_list(notes, null.ok = TRUE)
- for (idx in seq_along(notes)) {
- n <- notes[[idx]]
- bad <- FALSE
- if (is.list(n)) {
- if (is.null(names(notes)[idx])) {
- bad <- TRUE
- }
- if (!all(c("i", "j", "text") %in% names(n))) {
- bad <- TRUE
- }
- } else if (!is.character(n) || length(n) != 1) {
- bad <- TRUE
- }
- if (isTRUE(bad)) {
- stop("`notes` includes invalid elements. Please refer to the documentation for details.", call. = FALSE)
- }
- }
- return(notes)
+ if (is.character(notes) && length(notes) > 0) {
+ notes <- as.list(notes)
+ }
+ assert_list(notes, null.ok = TRUE)
+ for (idx in seq_along(notes)) {
+ n <- notes[[idx]]
+ bad <- FALSE
+ if (is.list(n)) {
+ if (is.null(names(notes)[idx])) {
+ bad <- TRUE
+ }
+ if (!all(c("i", "j", "text") %in% names(n))) {
+ bad <- TRUE
+ }
+ } else if (!is.character(n) || length(n) != 1) {
+ bad <- TRUE
+ }
+ if (isTRUE(bad)) {
+ stop("`notes` includes invalid elements. Please refer to the documentation for details.", call. = FALSE)
+ }
+ }
+ return(notes)
}
sanitize_replace <- function(replace) {
- if (isTRUE(replace)) {
- replace <- stats::setNames(list(NA), "")
- } else if (isFALSE(replace)) {
- replace <- stats::setNames(list(NULL), "")
- } else if (isTRUE(check_string(replace))) {
- replace <- stats::setNames(list(NA), replace)
- } else if (!is.list(replace) || is.null(names(replace))) {
- stop("`replace` should be TRUE/FALSE, a single string, or a named list.", call. = FALSE)
- }
- return(replace)
+ if (isTRUE(replace)) {
+ replace <- stats::setNames(list(NA), "")
+ } else if (isFALSE(replace)) {
+ replace <- stats::setNames(list(NULL), "")
+ } else if (isTRUE(check_string(replace))) {
+ replace <- stats::setNames(list(NA), replace)
+ } else if (!is.list(replace) || is.null(names(replace))) {
+ stop("`replace` should be TRUE/FALSE, a single string, or a named list.", call. = FALSE)
+ }
+ return(replace)
}
sanity_num_mark <- function(digits, num_mark_big, num_mark_dec) {
- if (is.null(digits)) {
- if (num_mark_big != "") stop("`num_mark_big` requires a `digits` value.", call. = FALSE)
- if (num_mark_dec != ".") stop("`num_mark_dec` requires a `digits` value.", call. = FALSE)
- }
+ if (is.null(digits)) {
+ if (num_mark_big != "") stop("`num_mark_big` requires a `digits` value.", call. = FALSE)
+ if (num_mark_dec != ".") stop("`num_mark_dec` requires a `digits` value.", call. = FALSE)
+ }
}
diff --git a/R/save_tt.R b/R/save_tt.R
index e68b5cb9..b11caee4 100644
--- a/R/save_tt.R
+++ b/R/save_tt.R
@@ -10,6 +10,9 @@
#' the images are included in the HTML as base64 encoded string instead of link to a local file.
#' @param overwrite A logical value indicating whether to overwrite an existing file.
#' @return A string with the table when `output` is a format, and the file path when `output` is a valid path.
+#' @template dependencies
+#' @template latex_preamble
+#' @template global_options
#' @export
#' @examples
#' library(tinytable)
@@ -23,7 +26,7 @@
#' tt(mtcars[1:4, 1:4]) |> save_tt(filename)
#'
save_tt <- function(x,
- output,
+ output,
overwrite = get_option("tinytable_save_overwrite", default = FALSE)) {
assert_class(x, "tinytable")
assert_string(output)
@@ -34,8 +37,8 @@ save_tt <- function(x,
}
if (isTRUE(getOption("tinytable_html_portable", default = FALSE))) {
- assert_dependency("base64enc")
- x@portable <- TRUE
+ assert_dependency("base64enc")
+ x@portable <- TRUE
}
if (identical(output, "html_portable")) {
@@ -97,7 +100,8 @@ save_tt <- function(x,
file = output,
selector = "body > div > table",
zoom = 4,
- quiet = TRUE)
+ quiet = TRUE
+ )
unlink(tmp)
} else if (file_ext == "pdf") {
assert_dependency("tinytex")
@@ -154,6 +158,7 @@ latex_standalone <- "
\\usepackage{rotating}
\\usepackage{float}
\\usepackage[normalem]{ulem}
+\\usepackage[x11names, svgnames]{xcolor}
\\UseTblrLibrary{booktabs}
\\UseTblrLibrary{siunitx}
\\newcommand{\\tinytableTabularrayUnderline}[1]{\\underline{#1}}
diff --git a/R/style_bootstrap.R b/R/style_bootstrap.R
index 7c0c023a..a557b4ee 100644
--- a/R/style_bootstrap.R
+++ b/R/style_bootstrap.R
@@ -29,122 +29,120 @@ setMethod(
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 (length(x@bootstrap_css_rule) == 1) {
+ x@table_string <- bootstrap_setting(x@table_string, x@bootstrap_css_rule, component = "css")
}
- if (template != "") {
- lin <- paste(lin, sprintf(template, line_color, line_width))
+
+ 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[idx] <- paste(css[idx], lin)
- }
- css <- gsub(" +", " ", trimws(css))
+ css <- gsub(" +", " ", trimws(css))
- # JS 0-indexing
- rec$i <- rec$i - 1 + x@nhead
- rec$j <- rec$j - 1
+ # 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")
+ # 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)
- if (nrow(idx) > 0) {
- idx <- split(idx, idx$id)
- for (i in seq_along(idx)) {
- id_css <- idx[[i]]$id[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")
+ rec$css_arguments <- css
+ rec <- rec[rec$css_arguments != "", , drop = FALSE]
+ if (nrow(rec) == 0) {
+ return(x)
}
- }
-
- 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)
+ if (nrow(idx) > 0) {
+ idx <- split(idx, idx$id)
+ for (i in seq_along(idx)) {
+ id_css <- idx[[i]]$id[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)
+ }
+)
diff --git a/R/style_grid.R b/R/style_grid.R
index ab213ee2..97c8e9fa 100644
--- a/R/style_grid.R
+++ b/R/style_grid.R
@@ -1,10 +1,10 @@
style_eval_grid <- function(x) {
-
-
out <- x@table_dataframe
sty <- x@style
- if (nrow(sty) == 0) return(x)
+ if (nrow(sty) == 0) {
+ return(x)
+ }
all_i <- seq_len(nrow(x))
idx_g <- x@group_i_idx + cumsum(rep(1, length(x@group_i_idx))) - 1
@@ -15,13 +15,17 @@ style_eval_grid <- function(x) {
alli <- data.frame(i = seq_len(nrow(x)))
alli <- merge(alli, sty[is.na(sty$i), colnames(sty) != "i"], all = TRUE)
sty <- rbind(sty, alli)
- sty <- sty[!is.na(sty$i),]
- sty <- sty[order(sty$i, sty$j),]
+ sty <- sty[!is.na(sty$i), ]
+ sty <- sty[order(sty$i, sty$j), ]
}
-
+
last <- function(k) {
- if (all(is.na(k))) return(NA)
- if (is.logical(k)) return(as.logical(max(k, na.rm = TRUE)))
+ if (all(is.na(k))) {
+ return(NA)
+ }
+ if (is.logical(k)) {
+ return(as.logical(max(k, na.rm = TRUE)))
+ }
return(utils::tail(stats::na.omit(k), 1))
}
sty <- do.call(rbind, by(sty, list(sty$i, sty$j), function(k) {
@@ -29,12 +33,14 @@ style_eval_grid <- function(x) {
}))
# TODO: style groups
- sty <- sty[which(!sty$i %in% idx_g),]
+ sty <- sty[which(!sty$i %in% idx_g), ]
- if (nrow(sty) == 0) return(x)
+ if (nrow(sty) == 0) {
+ return(x)
+ }
# user-supplied indices are post-groups
- # adjust indices to match original data rows since we only operate on those
+ # adjust indices to match original data rows since we only operate on those
for (g in rev(idx_g)) {
sty[sty$i > g, "i"] <- sty[sty$i > g, "i"] - 1
}
@@ -83,10 +89,10 @@ style_eval_grid <- function(x) {
#' tinytable S4 method
-#'
+#'
#' @keywords internal
setMethod(
- f = "style_eval",
- signature = "tinytable_grid",
- definition = style_eval_grid
+ f = "style_eval",
+ signature = "tinytable_grid",
+ definition = style_eval_grid
)
diff --git a/R/style_grid_dataframe.R b/R/style_grid_dataframe.R
index 7e59d869..03d336ce 100644
--- a/R/style_grid_dataframe.R
+++ b/R/style_grid_dataframe.R
@@ -1,25 +1,28 @@
#' tinytable S4 method
-#'
+#'
#' @keywords internal
-setMethod(f = "style_eval",
- signature = "tinytable_dataframe",
- definition = style_eval_grid
+setMethod(
+ f = "style_eval",
+ signature = "tinytable_dataframe",
+ definition = style_eval_grid
)
#' tinytable S4 method
-#'
+#'
#' @keywords internal
-setMethod(f = "group_eval",
- signature = "tinytable_dataframe",
- definition = identity
+setMethod(
+ f = "group_eval",
+ signature = "tinytable_dataframe",
+ definition = identity
)
#' tinytable S4 method
-#'
+#'
#' @keywords internal
-setMethod(f = "finalize",
- signature = "tinytable_dataframe",
- definition = identity
+setMethod(
+ f = "finalize",
+ signature = "tinytable_dataframe",
+ definition = identity
)
diff --git a/R/style_notes.R b/R/style_notes.R
new file mode 100644
index 00000000..e69de29b
diff --git a/R/style_string.R b/R/style_string.R
new file mode 100644
index 00000000..4e009fc7
--- /dev/null
+++ b/R/style_string.R
@@ -0,0 +1,108 @@
+style_string_html <- function(n, styles) {
+ if (isTRUE(styles[["italic"]])) {
+ n <- sprintf("%s", n)
+ }
+ if (isTRUE(styles[["strikeout"]])) {
+ n <- sprintf("%s", n)
+ }
+ if (isTRUE(styles[["underline"]])) {
+ n <- sprintf("%s", n)
+ }
+ if (isTRUE(styles[["bold"]])) {
+ n <- sprintf("%s", n)
+ }
+ if (isTRUE(styles[["monospace"]])) {
+ n <- sprintf("%s", n)
+ }
+ if (!is.null(styles[["color"]])) {
+ n <- sprintf("%s", styles[["color"]], n)
+ }
+ if (!is.null(styles[["fontsize"]])) {
+ n <- sprintf("%s", styles[["fontsize"]], n)
+ }
+ n
+}
+
+
+style_string_latex <- function(n, styles) {
+ if (isTRUE(styles[["italic"]])) {
+ n <- sprintf("\\textit{%s}", n)
+ }
+ if (isTRUE(styles[["strikeout"]])) {
+ n <- sprintf("\\sout{%s}", n)
+ }
+ if (isTRUE(styles[["underline"]])) {
+ n <- sprintf("\\underline{%s}", n)
+ }
+ if (isTRUE(styles[["bold"]])) {
+ n <- sprintf("\\textbf{%s}", n)
+ }
+ if (isTRUE(styles[["monospace"]])) {
+ n <- sprintf("\\texttt{%s}", n)
+ }
+ if (!is.null(styles[["color"]])) {
+ n <- sprintf("\\textcolor{%s}{%s}", styles[["color"]], n)
+ }
+ if (!is.null(styles[["fontsize"]])) {
+ n <- sprintf("{\\fontsize{%sem}{%sem}\\selectfont %s}", styles[["fontsize"]], styles[["fontsize"]], n)
+ }
+ n
+}
+
+
+style_string_typst <- function(n, styles) {
+ sty <- NULL
+ if (isTRUE(styles[["italic"]])) {
+ sty <- c(sty, 'style: "italic"')
+ }
+ if (isTRUE(styles[["bold"]])) {
+ sty <- c(sty, 'weight: "bold"')
+ }
+ if (isTRUE(styles[["strikeout"]])) {
+ # not sure how to do this
+ }
+ if (isTRUE(styles[["underline"]])) {
+ # not sure how to do this
+ }
+ if (!is.null(styles[["fontsize"]])) {
+ fs <- sprintf("size: %sem", styles[["fontsize"]])
+ sty <- c(sty, fs)
+ }
+ if (!is.null(styles[["color"]])) {
+ col <- styles[["color"]]
+ if (grepl("^#", col)) col <- sprintf('rgb("%s")', col)
+ col <- sprintf("fill: %s", col)
+ sty <- c(sty, col)
+ }
+ template <- paste0("text(", paste(sty, collapse = ", "), ", [%s])")
+ out <- sprintf(template, n)
+ out <- sub("text(, ", "text(", out, fixed = TRUE)
+ return(out)
+}
+
+
+style_notes <- function(x) {
+ fun <- switch(x@output,
+ "typst" = style_string_typst,
+ "html" = style_string_html,
+ "html_portable" = style_string_html,
+ "latex" = style_string_latex,
+ function(k, ...) identity(k)
+ )
+ x@notes <- lapply(x@notes, fun, x@style_notes)
+ return(x)
+}
+
+style_caption <- function(x) {
+ fun <- switch(x@output,
+ "typst" = style_string_typst,
+ "html" = style_string_html,
+ "html_portable" = style_string_html,
+ "latex" = style_string_latex,
+ function(k, ...) identity(k)
+ )
+ if (length(x@caption) > 0) {
+ x@caption <- fun(x@caption, x@style_caption)
+ }
+ return(x)
+}
diff --git a/R/style_tabularray.R b/R/style_tabularray.R
index 5d704178..150b9db9 100644
--- a/R/style_tabularray.R
+++ b/R/style_tabularray.R
@@ -95,7 +95,8 @@ setMethod(
if (!is.na(as.numeric(fontsize))) {
set[idx] <- sprintf(
"%s font=\\fontsize{%sem}{%sem}\\selectfont,",
- set[idx], fontsize, fontsize + 0.3)
+ set[idx], fontsize, fontsize + 0.3
+ )
}
halign <- sty$align[row]
@@ -173,7 +174,8 @@ setMethod(
rows <- unique(rec[
idx & rec$complete_row & !rec$complete_column,
c("i", "set", "span"),
- drop = FALSE])
+ drop = FALSE
+ ])
spec <- by(rows, list(rows$set, rows$span), function(k) {
sprintf("row{%s}={%s}{%s}", paste(k$i, collapse = ","), k$span, k$set)
})
@@ -193,9 +195,11 @@ setMethod(
# lines
rec$lin <- "solid, "
rec$lin <- ifelse(!is.na(rec$line_color),
- paste0(rec$lin, rec$line_color), rec$lin)
+ paste0(rec$lin, rec$line_color), rec$lin
+ )
rec$lin <- ifelse(!is.na(rec$line_width),
- paste0(rec$lin, sprintf(", %sem", rec$line_width)), rec$lin)
+ paste0(rec$lin, sprintf(", %sem", rec$line_width)), rec$lin
+ )
rec$lin[is.na(rec$line)] <- NA
# horizontal lines
@@ -238,7 +242,8 @@ setMethod(
return(x)
- })
+ }
+)
diff --git a/R/style_tt.R b/R/style_tt.R
index 742c4d00..4cec207d 100644
--- a/R/style_tt.R
+++ b/R/style_tt.R
@@ -3,14 +3,15 @@
#' @details
#' This function applies styling to a table created by `tt()`. It allows customization of text style (bold, italic, monospace), text and background colors, font size, cell width, text alignment, column span, and indentation. The function also supports passing native instructions to LaTeX (tabularray) and HTML (bootstrap) formats.
#'
-#' Note: Markdown and Word tables only support these styles: italic, bold, strikeout. Moreover, the `style_tt()` function cannot be used to style headers inserted by the `group_tt()` function; instead, you should style the headers directly in the header definition using markdown syntax: `group_tt(i = list("*italic header*" = 2))`. These limitations are due to the fact that there is no markdown syntax for the other options, and that we create Word documents by converting a markdown table to .docx via the Pandoc software.
-#'
#' @param x A table object created by `tt()`.
-#' @param i Row indices where the styling should be applied. Can be a single value, a vector, or a logical matrix with the same number of rows and columns as `x`. `i=0` is the header, and negative values are higher level headers. Row indices refer to rows *after* the insertion of row labels by `group_tt()`, when applicable.
+#' @param i Numeric vector, logical matrix, or string..
+#' - Numeric vector: Row indices where the styling should be applied. Can be a single value or a vector.
+#' - Logical matrix: A matrix with the same number of rows and columns as `x`. `i=0` is the header, and negative values are higher level headers. Row indices refer to rows *after* the insertion of row labels by `group_tt()`, when applicable.
+#' - String: "notes" or "caption".
#' @param j Column indices where the styling should be applied. Can be:
#' + Integer vectors indicating column positions.
#' + Character vector indicating column names.
-#' + A single string specifying a Perl-style regular expression used to match column names.
+#' + A single string specifying a Perl-style regular expression used to match column names.
#' @param bold Logical; if `TRUE`, text is styled in bold.
#' @param italic Logical; if `TRUE`, text is styled in italic.
#' @param monospace Logical; if `TRUE`, text is styled in monospace font.
@@ -24,7 +25,7 @@
#' - Hex code composed of # and 6 characters, ex: "#CC79A7". See the section below for instructions to add in LaTeX preambles.
#' - Keywords: black, blue, brown, cyan, darkgray, gray, green, lightgray, lime, magenta, olive, orange, pink, purple, red, teal, violet, white, yellow.
#' - Color blending using xcolor`, ex: `white!80!blue`, `green!20!red`.
-#' - Color names with luminance levels from [the `ninecolors` package](https://mirror.quantum5.ca/CTAN/macros/latex/contrib/ninecolors/ninecolors.pdf) (ex: "azure4", "magenta8", "teal2", "gray1", "olive3").
+#' - Color names with luminance levels from [the `ninecolors` package](https://mirror.quantum5.ca/CTAN/macros/latex/contrib/ninecolors/ninecolors.pdf) (ex: "azure4", "magenta8", "teal2", "gray1", "olive3").
#' @param background Background color. Specified as a color name or hexadecimal code. Can be `NULL` for default color.
#' @param fontsize Font size in em units. Can be `NULL` for default size.
#' @param align A single character or a string with a number of characters equal to the number of columns in `j`. Valid characters include 'c' (center), 'l' (left), 'r' (right), 'd' (decimal). Decimal alignment is only available in LaTeX via the `siunitx` package. The width of columns is determined by the maximum number of digits to the left and to the right in all cells specified by `i` and `j`.
@@ -32,7 +33,7 @@
#' @param colspan Number of columns a cell should span. `i` and `j` must be of length 1.
#' @param rowspan Number of rows a cell should span. `i` and `j` must be of length 1.
#' @param indent Text indentation in em units. Positive values only.
-#' @param line String determines if solid lines (rules or borders) should be drawn around the cell, row, or column.
+#' @param line String determines if solid lines (rules or borders) should be drawn around the cell, row, or column.
#' + "t": top
#' + "b": bottom
#' + "l": left
@@ -41,38 +42,39 @@
#' @param line_color Color of the line. See the `color` argument for details.
#' @param line_width Width of the line in em units (default: 0.1).
#' @param finalize A function applied to the table object at the very end of table-building, for post-processing. For example, the function could use regular expressions to add LaTeX commands to the text version of the table hosted in `x@table_string`, or it could programmatically change the caption in `x@caption`.
-#' @param bootstrap_css Character vector. CSS style declarations to be applied to every cell defined by `i` and `j` (ex: `"font-weight: bold"`).
-#' @param bootstrap_class String. Bootstrap table class such as `"table"`, `"table table-dark"` or `"table table-dark table-hover"`. See the bootstrap documentation.
+#' @param bootstrap_css Character vector. CSS style declarations to be applied to every cell defined by `i` and `j` (ex: `"font-weight: bold"`).
+#' @param bootstrap_class String. Bootstrap table class such as `"table"`, `"table table-dark"` or `"table table-dark table-hover"`. See the bootstrap documentation.
#' @param bootstrap_css_rule String. Complete CSS rules (with curly braces, semicolon, etc.) that apply to the table class specified by the `bootstrap_class` argument.
-#' @param tabularray_inner A string that specifies the "inner" settings of a tabularray LaTeX table.
+#' @param tabularray_inner A string that specifies the "inner" settings of a tabularray LaTeX table.
#' @param tabularray_outer A string that specifies the "outer" settings of a tabularray LaTeX table.
-#' @param output Apply style only to the output format specified by this argument. `NULL` means that we apply to all formats.
+#' @param output Apply style only to the output format specified by this argument. `NULL` means that we apply to all formats.
#' @param ... extra arguments are ignored
#' @return An object of class `tt` representing the table.
+#' @template limitations_word_markdown
#' @export
#' @examplesIf knitr::is_html_output()
#' @examples
#' if (knitr::is_html_output()) options(tinytable_print_output = "html")
-#'
+#'
#' library(tinytable)
-#'
+#'
#' tt(mtcars[1:5, 1:6])
-#'
+#'
#' # Alignment
-#' tt(mtcars[1:5, 1:6]) |>
+#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(j = 1:5, align = "lcccr")
-#'
+#'
#' # Colors and styles
-#' tt(mtcars[1:5, 1:6]) |>
+#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(i = 2:3, background = "black", color = "orange", bold = TRUE)
-#'
+#'
#' # column selection with `j``
-#' tt(mtcars[1:5, 1:6]) |>
+#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(j = 5:6, background = "pink")
-#'
+#'
#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(j = "drat|wt", background = "pink")
-#'
+#'
#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(j = c("drat", "wt"), background = "pink")
#'
@@ -81,27 +83,27 @@
#' i = 2, j = 2,
#' colspan = 3,
#' rowspan = 2,
-#' align="c",
+#' align = "c",
#' alignv = "m",
#' color = "white",
#' background = "black",
#' bold = TRUE)
-#'
+#'
#' tt(mtcars[1:5, 1:6], theme = "void") |>
#' style_tt(
-#' i=0:3,
-#' j=1:3,
-#' line="tblr",
-#' line_width=0.4,
-#' line_color="teal")
-#'
+#' i = 0:3,
+#' j = 1:3,
+#' line = "tblr",
+#' line_width = 0.4,
+#' line_color = "teal")
+#'
#' tt(mtcars[1:5, 1:6], theme = "bootstrap") |>
-#' style_tt(
-#' i = c(2,5),
-#' j = 3,
-#' strikeout = TRUE,
-#' fontsize = 0.7)
-#'
+#' style_tt(
+#' i = c(2, 5),
+#' j = 3,
+#' strikeout = TRUE,
+#' fontsize = 0.7)
+#'
#' tt(mtcars[1:5, 1:6]) |>
#' style_tt(bootstrap_class = "table table-dark table-hover")
#'
@@ -119,252 +121,261 @@
#' tt(mtcars[1:5, 1:4], theme = "void") |>
#' style_tt(tabularray_inner = inner)
#'
-style_tt <- 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,
- colspan = NULL,
- rowspan = NULL,
- indent = NULL,
- line = NULL,
- line_color = "black",
- line_width = 0.1,
- finalize = NULL,
- tabularray_inner = NULL,
- tabularray_outer = NULL,
- bootstrap_class = NULL,
- bootstrap_css = NULL,
- bootstrap_css_rule = NULL,
- output = NULL,
- ...) {
+style_tt <- 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,
+ colspan = NULL,
+ rowspan = NULL,
+ indent = NULL,
+ line = NULL,
+ line_color = "black",
+ line_width = 0.1,
+ finalize = NULL,
+ tabularray_inner = NULL,
+ tabularray_outer = NULL,
+ bootstrap_class = NULL,
+ bootstrap_css = NULL,
+ bootstrap_css_rule = NULL,
+ output = NULL,
+ ...) {
+ out <- x
- out <- x
+ assert_choice(alignv, c("t", "m", "b"), null.ok = TRUE)
- assert_choice(alignv, c("t", "m", "b"), null.ok = TRUE)
-
- assert_style_tt(
- x = out, i = i, j = j, bold = bold, italic = italic, monospace = monospace, underline = underline, strikeout = strikeout,
- color = color, background = background, fontsize = fontsize, align = align,
- colspan = colspan, rowspan = rowspan, indent = indent,
- line = line, line_color = line_color, line_width = line_width,
- tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer, bootstrap_css = bootstrap_css,
- bootstrap_css_rule = bootstrap_css_rule)
+ assert_style_tt(
+ x = out, i = i, j = j, bold = bold, italic = italic, monospace = monospace, underline = underline, strikeout = strikeout,
+ color = color, background = background, fontsize = fontsize, align = align,
+ colspan = colspan, rowspan = rowspan, indent = indent,
+ line = line, line_color = line_color, line_width = line_width,
+ tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer, bootstrap_css = bootstrap_css,
+ bootstrap_css_rule = bootstrap_css_rule)
+ if (isTRUE(i %in% c("notes", "caption"))) {
+ tmp <- list(
+ color = color,
+ fontsize = fontsize,
+ italic = italic,
+ monospace = monospace,
+ strikeout = strikeout,
+ underline = underline
+ )
+ if (identical(i, "notes")) out@style_notes <- tmp
+ if (identical(i, "caption")) out@style_caption <- tmp
+ return(out)
+ }
- if (!is.null(bootstrap_class)) {
- out@bootstrap_class <- bootstrap_class
- }
- if (!is.null(bootstrap_css_rule)) {
- out@bootstrap_css_rule <- bootstrap_css_rule
- }
+ if (!is.null(bootstrap_class)) {
+ out@bootstrap_class <- bootstrap_class
+ }
+ if (!is.null(bootstrap_css_rule)) {
+ out@bootstrap_css_rule <- bootstrap_css_rule
+ }
- sanity_align(align, i)
+ sanity_align(align, i)
- assert_choice(output, c("typst", "latex", "html", "markdown", "gfm"), null.ok = TRUE)
+ assert_choice(output, c("typst", "latex", "html", "markdown", "gfm"), null.ok = TRUE)
- if ("width" %in% names(list(...))) {
- stop("The `width` argument is now in the `tt()` function.", call. = FALSE)
- }
+ if ("width" %in% names(list(...))) {
+ stop("The `width` argument is now in the `tt()` function.", call. = FALSE)
+ }
- # i is a logical matrix mask
- if (is.matrix(i) && is.logical(i) && nrow(i) == nrow(x) && ncol(i) == ncol(x)) {
- assert_null(j)
- settings <- which(i == TRUE, arr.ind = TRUE)
- settings <- stats::setNames(data.frame(settings), c("i", "j"))
- } else {
- ival <- sanitize_i(i, x)
- jval <- sanitize_j(j, x)
- # 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), ]
- }
+ # i is a logical matrix mask
+ if (is.matrix(i) && is.logical(i) && nrow(i) == nrow(x) && ncol(i) == ncol(x)) {
+ assert_null(j)
+ settings <- which(i == TRUE, arr.ind = TRUE)
+ settings <- stats::setNames(data.frame(settings), c("i", "j"))
+ } else {
+ ival <- sanitize_i(i, x)
+ jval <- sanitize_j(j, x)
+ # 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), ]
}
+ }
- settings[["color"]] <- if (is.null(color)) NA else as.vector(color)
- settings[["background"]] <- if (is.null(background)) NA else as.vector(background)
- settings[["fontsize"]] <- if (is.null(fontsize)) NA else as.vector(fontsize)
- settings[["alignv"]] <- if (is.null(alignv)) NA else alignv
- settings[["line"]] <- if (is.null(line)) NA else line
- settings[["line_color"]] <- if (is.null(line)) NA else line_color
- settings[["line_width"]] <- if (is.null(line)) NA else line_width
- settings[["bold"]] <- bold
- settings[["italic"]] <- italic
- settings[["monospace"]] <- monospace
- settings[["strikeout"]] <- strikeout
- settings[["underline"]] <- underline
- settings[["indent"]] <- if (is.null(indent)) NA else as.vector(indent)
- settings[["colspan"]] <- if (is.null(colspan)) NA else colspan
- settings[["rowspan"]] <- if (is.null(rowspan)) NA else rowspan
- settings[["bootstrap_css_rule"]] <- if (!is.null(bootstrap_css_rule)) bootstrap_css_rule else NA
- settings[["bootstrap_css"]] <- if (!is.null(bootstrap_css)) bootstrap_css else NA
- settings[["tabularray_inner"]] <- if (!is.null(tabularray_inner)) tabularray_inner else NA
- settings[["tabularray_outer"]] <- if (!is.null(tabularray_outer)) tabularray_outer else NA
+ settings[["color"]] <- if (is.null(color)) NA else as.vector(color)
+ settings[["background"]] <- if (is.null(background)) NA else as.vector(background)
+ settings[["fontsize"]] <- if (is.null(fontsize)) NA else as.vector(fontsize)
+ settings[["alignv"]] <- if (is.null(alignv)) NA else alignv
+ settings[["line"]] <- if (is.null(line)) NA else line
+ settings[["line_color"]] <- if (is.null(line)) NA else line_color
+ settings[["line_width"]] <- if (is.null(line)) NA else line_width
+ settings[["bold"]] <- bold
+ settings[["italic"]] <- italic
+ settings[["monospace"]] <- monospace
+ settings[["strikeout"]] <- strikeout
+ settings[["underline"]] <- underline
+ settings[["indent"]] <- if (is.null(indent)) NA else as.vector(indent)
+ settings[["colspan"]] <- if (is.null(colspan)) NA else colspan
+ settings[["rowspan"]] <- if (is.null(rowspan)) NA else rowspan
+ settings[["bootstrap_css_rule"]] <- if (!is.null(bootstrap_css_rule)) bootstrap_css_rule else NA
+ settings[["bootstrap_css"]] <- if (!is.null(bootstrap_css)) bootstrap_css else NA
+ settings[["tabularray_inner"]] <- if (!is.null(tabularray_inner)) tabularray_inner else NA
+ settings[["tabularray_outer"]] <- if (!is.null(tabularray_outer)) tabularray_outer else NA
- if (!is.null(align)) {
- if (nchar(align) == length(jval)) {
- align_string <- strsplit(align, "")[[1]]
- if (!all(align_string %in% c("c", "l", "r", "d"))) {
- msg <- "`align` must be characters c, l, r, or d."
- stop(msg, call. = FALSE)
- }
- align_string <- data.frame(j = jval, align = align_string)
- settings <- merge(settings, align_string, by = "j", all.x = TRUE)
- } else if (nchar(align) == 1) {
- assert_choice(align, c("c", "l", "r", "d"))
- align_string <- data.frame(j = jval, align = align)
- settings <- merge(settings, align_string, by = "j", all.x = TRUE)
- } else {
- msg <- sprintf("`align` must be a single character or a string of length %s.", length(jval))
- stop(msg, call. = FALSE)
- }
+ if (!is.null(align)) {
+ if (nchar(align) == length(jval)) {
+ align_string <- strsplit(align, "")[[1]]
+ if (!all(align_string %in% c("c", "l", "r", "d"))) {
+ msg <- "`align` must be characters c, l, r, or d."
+ stop(msg, call. = FALSE)
+ }
+ align_string <- data.frame(j = jval, align = align_string)
+ settings <- merge(settings, align_string, by = "j", all.x = TRUE)
+ } else if (nchar(align) == 1) {
+ assert_choice(align, c("c", "l", "r", "d"))
+ align_string <- data.frame(j = jval, align = align)
+ settings <- merge(settings, align_string, by = "j", all.x = TRUE)
} else {
- settings[["align"]] <- NA
+ msg <- sprintf("`align` must be a single character or a string of length %s.", length(jval))
+ stop(msg, call. = FALSE)
}
+ } else {
+ settings[["align"]] <- NA
+ }
- empty <- settings[, 4:ncol(settings)]
- empty <- sapply(empty, function(x) is.na(x) | (is.logical(x) && !any(x)))
- if (nrow(settings) == 1) {
- empty <- all(empty)
- settings <- settings[!empty, , drop = FALSE]
- } else {
- empty <- apply(empty, 1, all)
- settings <- settings[!empty, , drop = FALSE]
- }
+ empty <- settings[, 4:ncol(settings)]
+ empty <- sapply(empty, function(x) is.na(x) | (is.logical(x) && !any(x)))
+ if (nrow(settings) == 1) {
+ empty <- all(empty)
+ settings <- settings[!empty, , drop = FALSE]
+ } else {
+ empty <- apply(empty, 1, all)
+ settings <- settings[!empty, , drop = FALSE]
+ }
- if (nrow(out@style) > 0 && nrow(settings) > 0 && ncol(out@style) != ncol(settings)) {
- a <- out@style
- b <- settings
- if (!"tabularray" %in% colnames(a)) a$tabularray <- ""
- if (!"tabularray" %in% colnames(b)) b$tabularray <- ""
- settings <- rbind(a, b[, colnames(a)])
- out@style <- unique(settings)
- } else if (nrow(settings) > 0) {
- out@style <- rbind(out@style, settings)
- }
+ if (nrow(out@style) > 0 && nrow(settings) > 0 && ncol(out@style) != ncol(settings)) {
+ a <- out@style
+ b <- settings
+ if (!"tabularray" %in% colnames(a)) a$tabularray <- ""
+ if (!"tabularray" %in% colnames(b)) b$tabularray <- ""
+ settings <- rbind(a, b[, colnames(a)])
+ out@style <- unique(settings)
+ } else if (nrow(settings) > 0) {
+ out@style <- rbind(out@style, settings)
+ }
- ## issue #759: reuse object with different styles across RevealJS slides requires new ID every time style_tt is called
- # This is a very bad idea. Breaks a ton of things. We need unique IDs.
- # out@id <- get_id("tinytable_")
+ ## issue #759: reuse object with different styles across RevealJS slides requires new ID every time style_tt is called
+ # This is a very bad idea. Breaks a ton of things. We need unique IDs.
+ # out@id <- get_id("tinytable_")
- assert_function(finalize, null.ok = TRUE)
- if (is.function(finalize)) {
- out@lazy_finalize <- c(out@lazy_finalize, list(finalize))
- }
+ assert_function(finalize, null.ok = TRUE)
+ if (is.function(finalize)) {
+ out@lazy_finalize <- c(out@lazy_finalize, list(finalize))
+ }
- return(out)
+ return(out)
}
-assert_style_tt <- function (x,
- i,
- j,
- bold,
- italic,
- monospace,
- underline,
- strikeout,
- color,
- background,
- fontsize,
- align,
- colspan,
- rowspan,
- indent,
- line,
- line_color,
- line_width,
- tabularray_inner,
- tabularray_outer,
- bootstrap_class = NULL,
- bootstrap_css = NULL,
- bootstrap_css_rule = NULL) {
+assert_style_tt <- function(x,
+ i,
+ j,
+ bold,
+ italic,
+ monospace,
+ underline,
+ strikeout,
+ color,
+ background,
+ fontsize,
+ align,
+ colspan,
+ rowspan,
+ indent,
+ line,
+ line_color,
+ line_width,
+ tabularray_inner,
+ tabularray_outer,
+ bootstrap_class = NULL,
+ bootstrap_css = NULL,
+ bootstrap_css_rule = NULL) {
+ assert_integerish(colspan, len = 1, lower = 2, null.ok = TRUE)
+ assert_integerish(rowspan, len = 1, lower = 2, null.ok = TRUE)
+ assert_numeric(indent, len = 1, lower = 0, null.ok = TRUE)
+ assert_character(background, null.ok = TRUE)
+ assert_character(color, null.ok = TRUE)
+ assert_numeric(fontsize, null.ok = TRUE)
+ assert_logical(bold)
+ assert_logical(italic)
+ assert_logical(monospace)
+ assert_logical(underline)
+ assert_logical(strikeout)
+ assert_string(line, null.ok = TRUE)
+ assert_string(line_color, null.ok = FALSE) # black default
+ assert_numeric(line_width, len = 1, lower = 0, null.ok = FALSE) # 0.1 default
+ assert_character(bootstrap_class, null.ok = TRUE)
+ assert_character(bootstrap_css, null.ok = TRUE)
+ assert_string(bootstrap_css_rule, null.ok = TRUE)
- assert_integerish(colspan, len = 1, lower = 2, null.ok = TRUE)
- assert_integerish(rowspan, len = 1, lower = 2, null.ok = TRUE)
- assert_numeric(indent, len = 1, lower = 0, null.ok = TRUE)
- assert_character(background, null.ok = TRUE)
- assert_character(color, null.ok = TRUE)
- assert_numeric(fontsize, null.ok = TRUE)
- assert_logical(bold)
- assert_logical(italic)
- assert_logical(monospace)
- assert_logical(underline)
- assert_logical(strikeout)
- assert_string(line, null.ok = TRUE)
- assert_string(line_color, null.ok = FALSE) # black default
- assert_numeric(line_width, len = 1, lower = 0, null.ok = FALSE) # 0.1 default
- assert_character(bootstrap_class, null.ok = TRUE)
- assert_character(bootstrap_css, null.ok = TRUE)
- assert_string(bootstrap_css_rule, null.ok = TRUE)
-
- if (is.character(line)) {
- line <- strsplit(line, split = "")[[1]]
- if (!all(line %in% c("t", "b", "l", "r"))) {
- msg <- "`line` must be a string of characters t, b, l, or r."
- stop(msg, call. = FALSE)
- }
+ if (is.character(line)) {
+ line <- strsplit(line, split = "")[[1]]
+ if (!all(line %in% c("t", "b", "l", "r"))) {
+ msg <- "`line` must be a string of characters t, b, l, or r."
+ stop(msg, call. = FALSE)
}
+ }
- ival <- sanitize_i(i, x)
- jval <- sanitize_j(j, x)
- inull <- isTRUE(attr(ival, "null"))
- jnull <- isTRUE(attr(jval, "null"))
+ ival <- sanitize_i(i, x)
+ jval <- sanitize_j(j, x)
+ inull <- isTRUE(attr(ival, "null"))
+ jnull <- isTRUE(attr(jval, "null"))
- # 1
- if (inull && jnull) {
- 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
+ if (inull && jnull) {
+ 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 (!inull && jnull) {
- 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)))
+ } else if (!inull && jnull) {
+ 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 (inull && !jnull) {
- 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)))
+ } else if (inull && !jnull) {
+ 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 (!inull && !jnull) {
- 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)))
- }
+ } else if (!inull && !jnull) {
+ 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/style_typst.R b/R/style_typst.R
index a48af9f7..6fd24350 100644
--- a/R/style_typst.R
+++ b/R/style_typst.R
@@ -25,13 +25,11 @@ setMethod(
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)
+ x@table_string <- lines_drop(x@table_string, "column-gutter:", fixed = TRUE)
}
sty$align[which(sty$align == "l")] <- "left"
@@ -44,54 +42,55 @@ setMethod(
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
+ 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)
+ 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)
- }
+ 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))
@@ -106,95 +105,96 @@ setMethod(
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)
+ 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")
+ x@table_string <- lines_insert(x@table_string, s, "tinytable cell style after", "after")
}
- lin <- sty[grepl("b|t", sty$line),, drop = FALSE]
+ 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 <- 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]
+ 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")
- }
+ 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)
+ 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)
+ 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)
+ 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)
}
diff --git a/R/theme_bootstrap.R b/R/theme_bootstrap.R
index 55dab118..ddd51c4b 100644
--- a/R/theme_bootstrap.R
+++ b/R/theme_bootstrap.R
@@ -1,26 +1,27 @@
theme_bootstrap <- function(x, ...) {
+ fn <- theme_placement_factory(
+ horizontal = get_option("tinytable_theme_default_horizontal", "c"),
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
+ x <- style_tt(x, finalize = fn)
- fn <- theme_placement_factory(
- horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
- x <- style_tt(x, finalize = fn)
-
- fn <- function(table) {
- if (isTRUE(table@output == "markdown")) {
- tab <- table@table_string
- tab <- strsplit(tab, "\n")[[1]]
- tab <- tab[!grepl("^[\\+|-]+$", tab)]
- tab <- gsub("|", " ", tab, fixed = TRUE)
- table@table_string <- paste(tab, collapse = "\n")
- } else if (isTRUE(table@output == "typst")) {
- table <- style_tt(table, i = 0:nrow(table), line = "bt", line_width = 0.05, line_color = "silver")
- }
- return(table)
+ fn <- function(table) {
+ if (isTRUE(table@output == "markdown")) {
+ tab <- table@table_string
+ tab <- strsplit(tab, "\n")[[1]]
+ tab <- tab[!grepl("^[\\+|-]+$", tab)]
+ tab <- gsub("|", " ", tab, fixed = TRUE)
+ table@table_string <- paste(tab, collapse = "\n")
+ } else if (isTRUE(table@output == "typst")) {
+ table <- style_tt(table, i = 0:nrow(table), line = "bt", line_width = 0.05, line_color = "silver")
}
- x <- style_tt(x, finalize = theme_void_fn) # only affects LaTeX
- x <- style_tt(x,
- tabularray_inner = "hlines={gray8},",
- bootstrap_class = "table",
- finalize = fn)
- return(x)
+ return(table)
+ }
+ x <- style_tt(x, finalize = theme_void_fn) # only affects LaTeX
+ x <- style_tt(x,
+ tabularray_inner = "hlines={gray8},",
+ bootstrap_class = "table",
+ finalize = fn
+ )
+ return(x)
}
diff --git a/R/theme_default.R b/R/theme_default.R
index eab4886b..17b625f5 100644
--- a/R/theme_default.R
+++ b/R/theme_default.R
@@ -1,36 +1,39 @@
theme_default <- function(x, ...) {
-
fn <- theme_placement_factory(
horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
x <- style_tt(x, finalize = fn)
if (isTRUE(x@output %in% c("html", "typst"))) {
col <- if (x@output == "typst") "black" else "#d3d8dc"
bc <- if (length(x@bootstrap_class) == 0) "table table-borderless" else x@bootstrap_class
# top
- x <- style_tt(x,
+ x <- style_tt(x,
bootstrap_class = bc,
- i = -x@nhead + 1,
- line = "t",
- line_color = col,
- line_width = 0.1)
+ i = -x@nhead + 1,
+ line = "t",
+ line_color = col,
+ line_width = 0.1
+ )
# mid
if (length(x@names) > 0) {
- x <- style_tt(x,
- bootstrap_class = bc,
- i = 0,
- line = "b",
- line_color = col,
- line_width = 0.05)
+ x <- style_tt(x,
+ bootstrap_class = bc,
+ i = 0,
+ line = "b",
+ line_color = col,
+ line_width = 0.05
+ )
}
# bottom
- x <- style_tt(x,
+ x <- style_tt(x,
bootstrap_class = bc,
- i = nrow(x),
- line = "b",
- line_color = col,
- line_width = 0.1)
+ i = nrow(x),
+ line = "b",
+ line_color = col,
+ line_width = 0.1
+ )
}
return(x)
diff --git a/R/theme_grid.R b/R/theme_grid.R
index dcbf3ee3..4b78f675 100644
--- a/R/theme_grid.R
+++ b/R/theme_grid.R
@@ -1,23 +1,26 @@
theme_grid <- function(x, ...) {
+ fn <- theme_placement_factory(
+ horizontal = get_option("tinytable_theme_default_horizontal", "c"),
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
+ x <- style_tt(x, finalize = fn)
- fn <- theme_placement_factory(
- horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
- x <- style_tt(x, finalize = fn)
-
- fn <- function(table) {
- if (isTRUE(table@output == "latex")) {
- table <- theme_void_fn(table)
- } else if (isTRUE(table@output == "typst")) {
- table@table_string <- sub(
- "stroke: none,",
- "stroke: (paint: black),",
- table@table_string)
- }
- return(table)
+ fn <- function(table) {
+ if (isTRUE(table@output == "latex")) {
+ table <- theme_void_fn(table)
+ } else if (isTRUE(table@output == "typst")) {
+ table@table_string <- sub(
+ "stroke: none,",
+ "stroke: (paint: black),",
+ table@table_string
+ )
}
+ return(table)
+ }
- x <- style_tt(x, tabularray_inner = "hlines, vlines,", finalize = fn,
- bootstrap_class = "table table-bordered")
- return(x)
+ x <- style_tt(x,
+ tabularray_inner = "hlines, vlines,", finalize = fn,
+ bootstrap_class = "table table-bordered"
+ )
+ return(x)
}
diff --git a/R/theme_multipage.R b/R/theme_multipage.R
index 6d28635a..e5231a68 100644
--- a/R/theme_multipage.R
+++ b/R/theme_multipage.R
@@ -1,41 +1,41 @@
-theme_multipage <- function(x,
- rowhead = get_option("tinytable_theme_multipage_rowhead", 0L),
- rowfoot = get_option("tinytable_theme_multipage_rowfoot", 0L),
+theme_multipage <- function(x,
+ rowhead = get_option("tinytable_theme_multipage_rowhead", 0L),
+ rowfoot = get_option("tinytable_theme_multipage_rowfoot", 0L),
...) {
- # do not change the defaul theme
- if (identical(x@theme[[1]], "multipage")) x@theme <- list("default")
- assert_integerish(rowhead, lower = 0, len = 1)
- assert_integerish(rowfoot, lower = 0, len = 1)
- # cap <- sprintf("caption={%s}", x@caption)
- # x@caption <- ""
- fn <- function(table) {
- if (!isTRUE(table@output == "latex")) return(table)
-
- tab <- table@table_string
- tab <- sub("\\\\begin\\{talltblr", "\\\\begin\\{longtblr", tab)
- tab <- sub("\\\\end\\{talltblr", "\\\\end\\{longtblr", tab)
-
- tab <- strsplit(tab, "\n")[[1]]
- idx <- grepl("^\\\\caption\\{|^\\\\begin\\{table|^\\\\end\\{table|^\\\\centering", trimws(tab))
- tab <- tab[!idx]
- tab <- paste(tab, collapse = "\n")
+ # do not change the defaul theme
+ if (identical(x@theme[[1]], "multipage")) x@theme <- list("default")
+ assert_integerish(rowhead, lower = 0, len = 1)
+ assert_integerish(rowfoot, lower = 0, len = 1)
+ # cap <- sprintf("caption={%s}", x@caption)
+ # x@caption <- ""
+ fn <- function(table) {
+ if (!isTRUE(table@output == "latex")) {
+ return(table)
+ }
- table@table_string <- tab
+ tab <- table@table_string
+ tab <- sub("\\\\begin\\{talltblr", "\\\\begin\\{longtblr", tab)
+ tab <- sub("\\\\end\\{talltblr", "\\\\end\\{longtblr", tab)
- # table <- style_tt(table, tabularray_outer = cap)
+ tab <- strsplit(tab, "\n")[[1]]
+ idx <- grepl("^\\\\caption\\{|^\\\\begin\\{table|^\\\\end\\{table|^\\\\centering", trimws(tab))
+ tab <- tab[!idx]
+ tab <- paste(tab, collapse = "\n")
- if (rowhead > 0) {
- table <- style_tt(table, tabularray_inner = sprintf("rowhead=%s", rowhead))
- }
+ table@table_string <- tab
- if (rowfoot > 0) {
- table <- style_tt(table, tabularray_inner = sprintf("rowfoot=%s", rowfoot))
- }
+ # table <- style_tt(table, tabularray_outer = cap)
- return(table)
+ if (rowhead > 0) {
+ table <- style_tt(table, tabularray_inner = sprintf("rowhead=%s", rowhead))
}
- x <- style_tt(x, finalize = fn)
- return(x)
-}
+ if (rowfoot > 0) {
+ table <- style_tt(table, tabularray_inner = sprintf("rowfoot=%s", rowfoot))
+ }
+ return(table)
+ }
+ x <- style_tt(x, finalize = fn)
+ return(x)
+}
diff --git a/R/theme_placement.R b/R/theme_placement.R
index 21d17cc8..1937b8ba 100644
--- a/R/theme_placement.R
+++ b/R/theme_placement.R
@@ -1,36 +1,34 @@
theme_placement_factory <- function(
horizontal = get_option("tinytable_theme_placement_horizontal", default = NULL),
latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)) {
-
- function(x) {
- tab <- x@table_string
- if (x@output == "latex" && !is.null(latex_float)) {
- assert_string(latex_float, null.ok = TRUE)
- tab <- sub(
- "\\\\begin\\{table\\}([^\\[])",
- sprintf("\\\\begin{table}[%s]\\1", latex_float),
- tab)
- } else if (x@output == "typst" && !is.null(horizontal)) {
- assert_choice(horizontal, c("l", "c", "r"))
- if (horizontal == "l") {
- tab <- sub("#align(center,", "#align(left,", tab, fixed = TRUE)
- } else if (horizontal == "r") {
- tab <- sub("#align(center,", "#align(right,", tab, fixed = TRUE)
- }
- }
- x@table_string <- tab
- return(x)
+ function(x) {
+ tab <- x@table_string
+ if (x@output == "latex" && !is.null(latex_float)) {
+ assert_string(latex_float, null.ok = TRUE)
+ tab <- sub(
+ "\\\\begin\\{table\\}([^\\[])",
+ sprintf("\\\\begin{table}[%s]\\1", latex_float),
+ tab
+ )
+ } else if (x@output == "typst" && !is.null(horizontal)) {
+ assert_choice(horizontal, c("l", "c", "r"))
+ if (horizontal == "l") {
+ tab <- sub("#align(center,", "#align(left,", tab, fixed = TRUE)
+ } else if (horizontal == "r") {
+ tab <- sub("#align(center,", "#align(right,", tab, fixed = TRUE)
+ }
}
+ x@table_string <- tab
+ return(x)
+ }
}
theme_placement <- function(
- x,
+ x,
horizontal = get_option("tinytable_theme_placement_horizontal", default = NULL),
latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)) {
- fn <- theme_placement_factory(horizontal = horizontal, latex_float = latex_float)
- x <- style_tt(x, finalize = fn)
- return(x)
+ fn <- theme_placement_factory(horizontal = horizontal, latex_float = latex_float)
+ x <- style_tt(x, finalize = fn)
+ return(x)
}
-
-
diff --git a/R/theme_resize.R b/R/theme_resize.R
index f56d2c2f..345ea029 100644
--- a/R/theme_resize.R
+++ b/R/theme_resize.R
@@ -1,44 +1,44 @@
-theme_resize <- function(x,
- width = get_option("tinytable_theme_resize_width", 1),
- direction = get_option("tinytable_theme_resize_direction", "down"),
+theme_resize <- function(x,
+ width = get_option("tinytable_theme_resize_width", 1),
+ direction = get_option("tinytable_theme_resize_direction", "down"),
...) {
+ fn <- theme_placement_factory(
+ horizontal = get_option("tinytable_theme_default_horizontal", "c"),
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
+ x <- style_tt(x, finalize = fn)
+
+ assert_numeric(width, len = 1, lower = 0.01, upper = 1)
+ assert_choice(direction, c("down", "up", "both"))
+ # do not change the default theme
+ if (identical(x@theme[[1]], "resize")) x@theme <- list("default")
+ fn <- function(table) {
+ if (!isTRUE(table@output == "latex")) {
+ return(table)
+ }
- fn <- theme_placement_factory(
- horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
- x <- style_tt(x, finalize = fn)
-
- assert_numeric(width, len = 1, lower = 0.01, upper = 1)
- assert_choice(direction, c("down", "up", "both"))
- # do not change the default theme
- if (identical(x@theme[[1]], "resize")) x@theme <- list("default")
- fn <- function(table) {
- if (!isTRUE(table@output == "latex")) return(table)
+ tab <- table@table_string
- tab <- table@table_string
+ if (direction == "both") {
+ new <- sprintf("\\resizebox{%s\\linewidth}{!}{", width)
+ } else if (direction == "down") {
+ new <- sprintf("\\resizebox{\\ifdim\\width>\\linewidth %s\\linewidth\\else\\width\\fi}{!}{", width)
+ } else if (direction == "up") {
+ new <- sprintf("\\resizebox{\\ifdim\\width<\\linewidth %s\\linewidth\\else\\width\\fi}{!}{", width)
+ }
- if (direction == "both") {
- new <- sprintf("\\resizebox{%s\\linewidth}{!}{", width)
- } else if (direction == "down") {
- new <- sprintf("\\resizebox{\\ifdim\\width>\\linewidth %s\\linewidth\\else\\width\\fi}{!}{", width)
- } else if (direction == "up") {
- new <- sprintf("\\resizebox{\\ifdim\\width<\\linewidth %s\\linewidth\\else\\width\\fi}{!}{", width)
- }
+ reg <- "\\\\begin\\{tblr\\}|\\\\begin\\{talltblr\\}"
+ tab <- lines_insert(tab, regex = reg, new = new, position = "before")
- reg <- "\\\\begin\\{tblr\\}|\\\\begin\\{talltblr\\}"
- tab <- lines_insert(tab, regex = reg, new = new, position = "before")
+ new <- "}"
+ reg <- "\\\\end\\{tblr\\}|\\\\end\\{talltblr\\}"
+ tab <- lines_insert(tab, regex = reg, new = new, position = "after")
- new <- "}"
- reg <- "\\\\end\\{tblr\\}|\\\\end\\{talltblr\\}"
- tab <- lines_insert(tab, regex = reg, new = new, position = "after")
+ table@table_string <- tab
- table@table_string <- tab
+ return(table)
+ }
- return(table)
- }
-
- x <- style_tt(x, finalize = fn)
- return(x)
+ x <- style_tt(x, finalize = fn)
+ return(x)
}
-
-
diff --git a/R/theme_revealjs.R b/R/theme_revealjs.R
index 5a170ab9..5be2cab4 100644
--- a/R/theme_revealjs.R
+++ b/R/theme_revealjs.R
@@ -1,8 +1,8 @@
-theme_revealjs <- function(x,
- fontsize = get_option("tinytable_theme_revealjs_fontsize", default = 0.8),
+theme_revealjs <- function(
+ x,
+ fontsize = get_option("tinytable_theme_revealjs_fontsize", default = 0.8),
fontsize_caption = get_option("tinytable_theme_revealjs_fontsize_caption", default = 1)) {
-
- css <- "
+ css <- "
// tables
.reveal table {
@@ -38,8 +38,7 @@ theme_revealjs <- function(x,
font-size: %emem;
}
"
- css <- sprintf(css, fontsize, fontsize_caption)
- x <- style_tt(x, bootstrap_css_rule = css)
- return(x)
+ css <- sprintf(css, fontsize, fontsize_caption)
+ x <- style_tt(x, bootstrap_css_rule = css)
+ return(x)
}
-
diff --git a/R/theme_rotate.R b/R/theme_rotate.R
index d04ca483..0db5403b 100644
--- a/R/theme_rotate.R
+++ b/R/theme_rotate.R
@@ -1,35 +1,38 @@
theme_rotate <- function(x, angle = 90, ...) {
- assert_numeric(angle, len = 1, lower = 0, upper = 360)
- fn <- function(table) {
- if (isTRUE(table@output == "latex")) {
- rot <- sprintf("\\begin{table}\n\\rotatebox{%s}{", angle)
- table@table_string <- sub(
- "\\begin{table}",
- rot,
- table@table_string,
- fixed = TRUE)
- table@table_string <- sub(
- "\\end{table}",
- "}\n\\end{table}",
- table@table_string,
- fixed = TRUE)
- } else if (isTRUE(table@output == "typst")) {
- rot <- sprintf("#rotate(-%sdeg, reflow: true, [\n #figure(", angle)
- table@table_string <- sub(
- "#figure(",
- rot,
- table@table_string,
- fixed = TRUE)
- table@table_string <- sub(
- ") // end figure",
- ") ]) // end figure",
- table@table_string,
- fixed = TRUE)
- }
- table <- style_tt(table, finalize = fn)
- return(table)
+ assert_numeric(angle, len = 1, lower = 0, upper = 360)
+ fn <- function(table) {
+ if (isTRUE(table@output == "latex")) {
+ rot <- sprintf("\\begin{table}\n\\rotatebox{%s}{", angle)
+ table@table_string <- sub(
+ "\\begin{table}",
+ rot,
+ table@table_string,
+ fixed = TRUE
+ )
+ table@table_string <- sub(
+ "\\end{table}",
+ "}\n\\end{table}",
+ table@table_string,
+ fixed = TRUE
+ )
+ } else if (isTRUE(table@output == "typst")) {
+ rot <- sprintf("#rotate(-%sdeg, reflow: true, [\n #figure(", angle)
+ table@table_string <- sub(
+ "#figure(",
+ rot,
+ table@table_string,
+ fixed = TRUE
+ )
+ table@table_string <- sub(
+ ") // end figure",
+ ") ]) // end figure",
+ table@table_string,
+ fixed = TRUE
+ )
}
- x <- style_tt(x, finalize = fn)
- return(x)
+ table <- style_tt(table, finalize = fn)
+ return(table)
+ }
+ x <- style_tt(x, finalize = fn)
+ return(x)
}
-
diff --git a/R/theme_spacing.R b/R/theme_spacing.R
index 1db3405e..10c1153c 100644
--- a/R/theme_spacing.R
+++ b/R/theme_spacing.R
@@ -1,40 +1,48 @@
theme_spacing <- function(x,
- rowsep = get_option("tinytable_theme_spacing_rowsep", 0.1),
- colsep = get_option("tinytable_theme_spacing_colsep", 0.5),
+ rowsep = get_option("tinytable_theme_spacing_rowsep", 0.1),
+ colsep = get_option("tinytable_theme_spacing_colsep", 0.5),
...) {
-
# placement
fn <- theme_placement_factory(
horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
x <- style_tt(x, finalize = fn)
# rules
if (isTRUE(x@output %in% c("html", "typst"))) {
bc <- if (length(x@bootstrap_class) == 0) "table table-borderless" else x@bootstrap_class
- x <- style_tt(x,
+ x <- style_tt(x,
bootstrap_class = bc,
- i = nrow(x),
- line = "b",
- line_color = "#d3d8dc",
- line_width = 0.1)
- x <- style_tt(x,
+ i = nrow(x),
+ line = "b",
+ line_color = "#d3d8dc",
+ line_width = 0.1
+ )
+ x <- style_tt(x,
bootstrap_class = bc,
- i = 0,
- line = "bt",
- line_color = "#d3d8dc",
- line_width = 0.1)
+ i = 0,
+ line = "bt",
+ line_color = "#d3d8dc",
+ line_width = 0.1
+ )
}
# spacing
x <- style_tt(x,
- tabularray_inner = sprintf("rowsep={%sem}, colsep = {%sem}", rowsep, colsep))
- x <- style_tt(x,
- tabularray_inner = sprintf("rowsep={%sem}, colsep = {%sem}", rowsep, colsep))
- x <- style_tt(x, j = seq_len(ncol(x) - 1),
- bootstrap_css = sprintf("padding-right: %sem;", colsep))
- x <- style_tt(x, i = -5:(nrow(x) - 1),
- bootstrap_css = sprintf("padding-bottom: %sem;", rowsep))
+ tabularray_inner = sprintf("rowsep={%sem}, colsep = {%sem}", rowsep, colsep)
+ )
+ x <- style_tt(x,
+ tabularray_inner = sprintf("rowsep={%sem}, colsep = {%sem}", rowsep, colsep)
+ )
+ x <- style_tt(x,
+ j = seq_len(ncol(x) - 1),
+ bootstrap_css = sprintf("padding-right: %sem;", colsep)
+ )
+ x <- style_tt(x,
+ i = -5:(nrow(x) - 1),
+ bootstrap_css = sprintf("padding-bottom: %sem;", rowsep)
+ )
return(x)
}
diff --git a/R/theme_striped.R b/R/theme_striped.R
index 375ecd9a..80d9ee28 100644
--- a/R/theme_striped.R
+++ b/R/theme_striped.R
@@ -1,32 +1,36 @@
theme_striped <- function(x, ...) {
+ fn <- theme_placement_factory(
+ horizontal = get_option("tinytable_theme_default_horizontal", "c"),
+ latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)
+ )
+ x <- style_tt(x, finalize = fn)
- fn <- theme_placement_factory(
- horizontal = get_option("tinytable_theme_default_horizontal", "c"),
- latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL))
- x <- style_tt(x, finalize = fn)
+ x <- style_tt(x,
+ tabularray_inner = "row{even}={bg=black!5!white}",
+ bootstrap_class = "table table-striped",
+ output = "latex"
+ )
- x <- style_tt(x,
- tabularray_inner = "row{even}={bg=black!5!white}",
- bootstrap_class = "table table-striped",
- output = "latex")
-
- x <- style_tt(x,
- i = seq(1, nrow(x), by = 2),
- background = "#ededed",
- output = "typst")
+ x <- style_tt(x,
+ i = seq(1, nrow(x), by = 2),
+ background = "#ededed",
+ output = "typst"
+ )
- # theme_default
- if (isTRUE(x@output %in% c("html", "typst"))) {
- x <- style_tt(x,
- i = nrow(x),
- line = "b",
- line_color = "#d3d8dc",
- line_width = 0.1)
- x <- style_tt(x,
- i = 0,
- line = "bt",
- line_color = "#d3d8dc",
- line_width = 0.1)
- }
- return(x)
+ # theme_default
+ if (isTRUE(x@output %in% c("html", "typst"))) {
+ x <- style_tt(x,
+ i = nrow(x),
+ line = "b",
+ line_color = "#d3d8dc",
+ line_width = 0.1
+ )
+ x <- style_tt(x,
+ i = 0,
+ line = "bt",
+ line_color = "#d3d8dc",
+ line_width = 0.1
+ )
+ }
+ return(x)
}
diff --git a/R/theme_tabular.R b/R/theme_tabular.R
index 5e7442fb..d50548fa 100644
--- a/R/theme_tabular.R
+++ b/R/theme_tabular.R
@@ -1,55 +1,50 @@
-theme_tabular <- function(x,
- style = get_option("tinytable_theme_tabular_style", "tabular"),
+theme_tabular <- function(x,
+ style = get_option("tinytable_theme_tabular_style", "tabular"),
...) {
-
- assert_choice(style, c("tabular", "tabularray"))
-
- # do not change the default theme
- if (identical(x@theme[[1]], "tabular")) x@theme <- list("default")
-
- fn <- function(table) {
- tab <- table@table_string
-
- if (isTRUE(table@output == "latex")) {
- tab <- lines_drop(tab, regex = "\\\\begin\\{table\\}", position = "before")
- tab <- lines_drop(tab, regex = "\\\\begin\\{table\\}", position = "equal")
- tab <- lines_drop(tab, regex = "\\\\end\\{table\\}", position = "after")
- tab <- lines_drop(tab, regex = "\\\\end\\{table\\}", position = "equal")
- tab <- lines_drop(tab, regex = "\\\\centering", position = "equal")
- if (style == "tabular") {
- tab <- lines_drop_between(tab, regex_start = "tabularray outer open", regex_end = "tabularray inner close")
- tab <- lines_drop(tab, regex = "tabularray outer close", position = "equal")
- tab <- lines_drop(tab, regex = "tabularray inner open", position = "equal")
- tab <- lines_drop(tab, regex = "tabularray inner close", position = "equal")
- tab <- lines_drop(tab, regex = "^colspec=\\{", position = "equal")
- tab <- gsub("cmidrule\\[(.*?)\\]", "cmidrule(\\1)", tab)
- tab <- gsub("\\{tblr\\}\\[*", "{tabular}", tab)
- tab <- gsub("\\{talltblr\\}\\[", "{tabular}", tab)
- tab <- gsub("\\{talltblr\\}", "{tabular}", tab)
- tab <- gsub("\\{longtblr\\}\\[", "{tabular}", tab)
- tab <- gsub("\\{longtblr\\}", "{tabular}", tab)
- tab <- gsub("\\\\toprule|\\\\midrule|\\\\bottomrule", "\\\\hline", tab)
- tab <- sub("\\s*%% tabularray outer open", "", tab)
- tab <- sub("\\s*%% TinyTableHeader", "", tab)
- # align
- a <- sprintf("begin{tabular}{%s}", strrep("l", ncol(table)))
- tab <- sub("begin{tabular}", a, tab, fixed = TRUE)
- }
-
- } else if (isTRUE(table@output == "html")) {
- tab <- lines_drop(tab, regex = "
theme_tt("striped")
-#'
+#'
#' # resize w/ argument
-#' x <- cbind(mtcars[1:10,], mtcars[1:10,])
+#' x <- cbind(mtcars[1:10, ], mtcars[1:10, ])
#' tt(x) |>
#' theme_tt("resize", width = .9) |>
#' print("latex")
-#'
+#'
#' @return A modified `tinytable` object
#' @export
theme_tt <- function(x, theme, ...) {
- assert_class(x, "tinytable")
- if (is.null(theme)) return(x)
- if (is.function(theme)) return(theme(x, ...))
- td <- theme_dictionary
- na <- unique(sort(names(td)))
- assert_choice(theme, na)
- fn <- td[[theme]]
- out <- list(list(fn, list(...)))
- x@lazy_theme <- c(x@lazy_theme, out)
+ assert_class(x, "tinytable")
+ if (is.null(theme)) {
return(x)
+ }
+ if (is.function(theme)) {
+ return(theme(x, ...))
+ }
+ td <- theme_dictionary
+ na <- unique(sort(names(td)))
+ assert_choice(theme, na)
+ fn <- td[[theme]]
+ out <- list(list(fn, list(...)))
+ x@lazy_theme <- c(x@lazy_theme, out)
+ return(x)
}
-
diff --git a/R/tt.R b/R/tt.R
index c7487273..cc31de18 100644
--- a/R/tt.R
+++ b/R/tt.R
@@ -15,8 +15,8 @@
#' @param x A data frame or data table to be rendered as a table.
#' @param digits Number of significant digits to keep for numeric variables. When `digits` is an integer, `tt()` calls `format_tt(x, digits = digits)` before proceeding to draw the table. Note that this will apply all default argument values of `format_tt()`, such as replacing `NA` by "". Users who need more control can use the `format_tt()` function instead.
#' @param caption A string that will be used as the caption of the table. This argument should *not* be used in Quarto or Rmarkdown documents. In that context, please use the appropriate chunk options.
-#' @param width Table or column width.
-#' - Single numeric value smaller than or equal to 1 determines the full table width, in proportion of line width.
+#' @param width Table or column width.
+#' - Single numeric value smaller than or equal to 1 determines the full table width, in proportion of line width.
#' - Numeric vector of length equal to the number of columns in `x` determines the width of each column, in proportion of line width. If the sum of `width` exceeds 1, each element is divided by `sum(width)`. This makes the table full-width with relative column sizes.
#' @param theme Function or string.
#' - String: `r paste(setdiff(names(theme_dictionary), "default"), collapse = ", ")`
@@ -30,31 +30,33 @@
#' @param escape Logical. If `TRUE`, escape special characters in the table. Equivalent to `format_tt(tt(x), escape = TRUE)`.
#' @param ... Additional arguments are ignored
#' @return An object of class `tt` representing the table.
-#'
+#'
#' The table object has S4 slots which hold information about the structure of the table. Relying on or modifying the contents of these slots is strongly discouraged. Their names and contents could change at any time, and the `tinytable` developers do not consider changes to the internal structure of the output object to be a "breaking change" for versioning or changelog purposes.
+#' @template dependencies
#' @template latex_preamble
+#' @template limitations_word_markdown
#' @template global_options
-#'
+#'
#' @examples
#' library(tinytable)
#' x <- mtcars[1:4, 1:5]
#'
#' tt(x)
-#'
+#'
#' tt(x,
-#' theme = "striped",
-#' width = 0.5,
-#' caption = "Data about cars.")
-#'
+#' theme = "striped",
+#' width = 0.5,
+#' caption = "Data about cars.")
+#'
#' tt(x, notes = "Hello World!")
#'
#' fn <- list(i = 0:1, j = 2, text = "Hello World!")
#' tab <- tt(x, notes = list("*" = fn))
#' print(tab, "latex")
-#'
+#'
#' k <- data.frame(x = c(0.000123456789, 12.4356789))
-#' tt(k, digits=2)
-#'
+#' tt(k, digits = 2)
+#'
#' @export
tt <- function(x,
digits = get_option("tinytable_tt_digits", default = NULL),
@@ -65,8 +67,6 @@ tt <- function(x,
rownames = get_option("tinytable_tt_rownames", default = FALSE),
escape = get_option("tinytable_tt_escape", default = FALSE),
...) {
-
-
dots <- list(...)
# sanity checks
@@ -90,20 +90,20 @@ tt <- function(x,
# it might be dangerous to leave non-numerics, but what about dates and other character-coercibles?
for (i in seq_along(x)) {
if (is.factor(x[[i]])) {
- x[[i]] <- as.character(x[[i]])
+ x[[i]] <- as.character(x[[i]])
}
}
assert_numeric(width, lower = 0, null.ok = TRUE)
if (!length(width) %in% c(0, 1, ncol(x))) {
- msg <- sprintf("The `width` argument must have length 1 or %s.", ncol(x))
- stop(msg, call. = FALSE)
+ msg <- sprintf("The `width` argument must have length 1 or %s.", ncol(x))
+ stop(msg, call. = FALSE)
}
if (sum(width) > 1) {
- width <- width / sum(width)
+ width <- width / sum(width)
}
- # bind the row names if the user explicitly asks for it in global option.
+ # bind the row names if the user explicitly asks for it in global option.
# Same name as tibble::rownames_to_column()
assert_flag(rownames)
if (isTRUE(rownames) && !is.null(row.names(x))) {
@@ -123,6 +123,7 @@ tt <- function(x,
# twice because format() leaves Date type, which cannot be partially reasigned
# with indexed format_tt(i)
tab <- data.frame(lapply(tab, format))
+ tab <- data.frame(lapply(tab, trimws))
colnames(tab) <- colnames(x)
out <- methods::new("tinytable",
@@ -131,7 +132,8 @@ tt <- function(x,
caption = caption,
notes = notes,
theme = list(theme),
- width = width)
+ width = width
+ )
if (is.null(theme)) {
out <- theme_tt(out, theme = "default")
diff --git a/R/tt_bootstrap.R b/R/tt_bootstrap.R
index 4fa11522..331d3b9b 100644
--- a/R/tt_bootstrap.R
+++ b/R/tt_bootstrap.R
@@ -2,176 +2,182 @@ setMethod(
f = "tt_eval",
signature = "tinytable_bootstrap",
definition = function(x, ...) {
+ template <- readLines(system.file("templates/bootstrap.html", package = "tinytable"))
+
+ mathjax <- get_option("tinytable_html_mathjax", default = FALSE)
+ assert_flag(mathjax, name = "tinytable_html_mathjax")
+ if (isFALSE(mathjax)) {
+ template <- paste(template, collapse = "\n")
+ sta <- " "
+ end <- " "
+ template <- lines_drop_between(template, sta, end, fixed = TRUE)
+ template <- strsplit(template, "\n")[[1]]
+ }
- template <- readLines(system.file("templates/bootstrap.html", package = "tinytable"))
-
- mathjax <- get_option("tinytable_html_mathjax", default = FALSE)
- assert_flag(mathjax, name = "tinytable_html_mathjax")
- if (isFALSE(mathjax)) {
- template <- paste(template, collapse = "\n")
- sta <- " "
- end <- " "
- template <- lines_drop_between(template, sta, end, fixed = TRUE)
- template <- strsplit(template, "\n")[[1]]
- }
-
- quartoprocessing <- get_option("tinytable_quarto_disable_processing", default = TRUE)
- assert_flag(quartoprocessing, name = "tinytable_quarto_disable_processing")
- if (isFALSE(quartoprocessing)) {
+ quartoprocessing <- get_option("tinytable_quarto_disable_processing", default = TRUE)
+ assert_flag(quartoprocessing, name = "tinytable_quarto_disable_processing")
+ if (isFALSE(quartoprocessing)) {
template <- sub("data-quarto-disable-processing='true'",
- "data-quarto-disable-processing='false'",
- template,
- fixed = TRUE)
- }
+ "data-quarto-disable-processing='false'",
+ template,
+ fixed = TRUE
+ )
+ }
- # caption
- if (length(x@caption) != 1) {
- template <- sub(
- "$tinytable_BOOTSTRAP_CAPTION",
- "",
- template,
- fixed = TRUE
- )
- } else {
- template <- sub(
- "$tinytable_BOOTSTRAP_CAPTION",
- sprintf("
")
- return(out)
- }
- body <- apply(x@table_dataframe, 1, makerow)
- idx <- grep("$tinytable_BOOTSTRAP_BODY", template, fixed = TRUE)
- template <- c(
- template[1:(idx - 1)],
- paste(strrep(" ", 13), body),
- template[(idx + 1):length(template)]
- )
-
- out <- paste(template, collapse = "\n")
-
- # before style_eval()
- x@table_string <- out
-
- if (length(x@bootstrap_class) == 0) {
- if (is.null(x@theme[[1]]) || is.function(x@theme[[1]]) || isTRUE("default" %in% x@theme[[1]])) {
- x <- theme_tt(x, "default")
+ out <- paste(template, collapse = "\n")
+
+ # before style_eval()
+ x@table_string <- out
+
+ if (length(x@bootstrap_class) == 0) {
+ if (is.null(x@theme[[1]]) || is.function(x@theme[[1]]) || isTRUE("default" %in% x@theme[[1]])) {
+ x <- theme_tt(x, "default")
+ }
+ } else if ("bootstrap" %in% x@theme[[1]]) {
+ x <- style_tt(x, bootstrap_class = "table")
+ } else if ("striped" %in% x@theme[[1]]) {
+ x <- style_tt(x, bootstrap_class = "table table-striped")
+ } else if ("grid" %in% x@theme[[1]]) {
+ x <- style_tt(x, bootstrap_class = "table table-bordered")
+ } else if ("void" %in% x@theme[[1]]) {
+ x <- style_tt(x, bootstrap_class = "table table-borderless")
}
- } else if ("bootstrap" %in% x@theme[[1]]) {
- x <- style_tt(x, bootstrap_class = "table")
- } else if ("striped" %in% x@theme[[1]]) {
- x <- style_tt(x, bootstrap_class = "table table-striped")
- } else if ("grid" %in% x@theme[[1]]) {
- x <- style_tt(x, bootstrap_class = "table table-bordered")
- } else if ("void" %in% x@theme[[1]]) {
- x <- style_tt(x, bootstrap_class = "table table-borderless")
- }
- if (length(x@width) > 1) {
+ if (length(x@width) > 1) {
for (j in seq_len(ncol(x))) {
- css <- sprintf("width: %s%%;", x@width[j] / sum(x@width) * 100)
- x <- style_tt(x, j = j, bootstrap_css = css)
+ css <- sprintf("width: %s%%;", x@width[j] / sum(x@width) * 100)
+ x <- style_tt(x, j = j, bootstrap_css = css)
}
- }
+ }
- return(x)
-})
+ return(x)
+ }
+)
bootstrap_setting <- function(x, new, component = "row") {
- att <- attributes(x)
+ att <- attributes(x)
out <- strsplit(x, "\n")[[1]]
if (component == "row") {
idx <- grep("tinytable rows before this", out)
diff --git a/R/tt_grid.R b/R/tt_grid.R
index ba67c2af..40bc5aca 100755
--- a/R/tt_grid.R
+++ b/R/tt_grid.R
@@ -6,8 +6,7 @@ grid_line <- function(width_cols, char = "-") {
}
-tt_eval_grid <- function(x, width_cols = NULL, ...) {
-
+tt_eval_grid <- function(x, width_cols = NULL, ...) {
is_matrix <- is.matrix(x)
if (is_matrix) {
tab <- x
@@ -16,7 +15,7 @@ tt_eval_grid <- function(x, width_cols = NULL, ...) {
}
if (is.null(width_cols)) {
- width_cols <- x@width_cols
+ width_cols <- x@width_cols
}
tthead <- inherits(x, "tinytable") && isTRUE(x@nhead > 0)
@@ -81,7 +80,9 @@ tt_eval_grid <- function(x, width_cols = NULL, ...) {
out <- paste(tab, collapse = "\n")
- if (is_matrix) return(out)
+ if (is_matrix) {
+ return(out)
+ }
# rebuild output
x@width_cols <- width_cols
@@ -140,14 +141,17 @@ grid_hlines <- function(x) {
setMethod(
f = "tt_eval",
signature = "tinytable_grid",
- definition = tt_eval_grid)
+ definition = tt_eval_grid
+)
setMethod(
f = "tt_eval",
signature = "matrix",
- definition = tt_eval_grid)
+ definition = tt_eval_grid
+)
setMethod(
f = "tt_eval",
signature = "tinytable_dataframe",
- definition = tt_eval_grid)
+ definition = tt_eval_grid
+)
diff --git a/R/tt_tabularray.R b/R/tt_tabularray.R
index 76e2cf16..21f86972 100644
--- a/R/tt_tabularray.R
+++ b/R/tt_tabularray.R
@@ -2,115 +2,111 @@ setMethod(
f = "tt_eval",
signature = "tinytable_tabularray",
definition = function(x, ...) {
+ template <- readLines(system.file("templates/tabularray.tex", package = "tinytable"))
- template <- readLines(system.file("templates/tabularray.tex", package = "tinytable"))
+ ncols <- ncol(x)
+ nrows <- nrow(x)
- ncols <- ncol(x)
- nrows <- nrow(x)
+ tall <- FALSE
+ if (length(x@caption) > 0) tall <- TRUE
+ if (length(x@notes) > 0) tall <- TRUE
- tall <- FALSE
- if (length(x@caption) > 0) tall <- TRUE
- if (length(x@notes) > 0) tall <- TRUE
+ # placement
+ if (length(x@placement) == 1) {
+ assert_string(x@placement)
+ # dollar sign to avoid [H][H] when we style multiple times
+ template <- sub("\\\\begin\\{table\\}", sprintf("\\\\begin{table}[%s]\n", x@placement), template)
+ }
- # placement
- if (length(x@placement) == 1) {
- assert_string(x@placement)
- # dollar sign to avoid [H][H] when we style multiple times
- template <- sub("\\\\begin\\{table\\}", sprintf("\\\\begin{table}[%s]\n", x@placement), template)
- }
-
- # body: main
- if (length(colnames(x)) > 0) {
- header <- paste(colnames(x), collapse = " & ")
- header <- paste(header, "\\\\")
- } else {
- header <- NULL
- }
- body <- apply(as.data.frame(x@table_dataframe), 1, paste, collapse = " & ")
- body <- paste(body, "\\\\")
-
- # theme: booktabs
- th <- x@theme[[1]]
- if (is.null(th) || is.function(th) || isTRUE(th %in% c("default", "striped"))) {
+ # body: main
if (length(colnames(x)) > 0) {
- # %% are important to distinguish between potentially redundant data rows
- header[length(header)] <- paste(header[length(header)], "\\midrule %% TinyTableHeader")
+ header <- paste(colnames(x), collapse = " & ")
+ header <- paste(header, "\\\\")
+ } else {
+ header <- NULL
+ }
+ body <- apply(as.data.frame(x@table_dataframe), 1, paste, collapse = " & ")
+ body <- paste(body, "\\\\")
+
+ # theme: booktabs
+ th <- x@theme[[1]]
+ if (is.null(th) || is.function(th) || isTRUE(th %in% c("default", "striped"))) {
+ if (length(colnames(x)) > 0) {
+ # %% are important to distinguish between potentially redundant data rows
+ header[length(header)] <- paste(header[length(header)], "\\midrule %% TinyTableHeader")
+ }
}
- }
-
- # body: finish
- idx <- grep("\\$tinytable_BODY", template)
- out <- c(
- template[1:(idx - 1)],
- header,
- body,
- template[(idx + 1):length(template)]
- )
- out <- trimws(out)
- out <- paste(out, collapse = "\n")
+ # body: finish
+ idx <- grep("\\$tinytable_BODY", template)
+ out <- c(
+ template[1:(idx - 1)],
+ header,
+ body,
+ template[(idx + 1):length(template)]
+ )
- if (length(x@caption) > 0) {
- spec <- sprintf("caption={%s},", x@caption[1])
- out <- tabularray_insert(out, content = spec, type = "outer")
- }
+ out <- trimws(out)
+ out <- paste(out, collapse = "\n")
- if (length(x@width) == 0) {
- tabularray_cols <- rep("Q[]", ncol(x))
-
- } else if (length(x@width) == 1) {
- tabularray_cols <- rep("X[]", ncol(x))
- spec <- sprintf("width={%s\\linewidth},", round(x@width, 4))
- out <- tabularray_insert(out, content = spec, type = "inner")
+ if (length(x@caption) > 0) {
+ spec <- sprintf("caption={%s},", x@caption[1])
+ out <- tabularray_insert(out, content = spec, type = "outer")
+ }
- } else if (length(x@width) > 1) {
- tabularray_cols <- sprintf("X[%s]", x@width)
- spec <- sprintf("width={%s\\linewidth},", round(sum(x@width), 4))
- out <- tabularray_insert(out, content = spec, type = "inner")
- }
+ if (length(x@width) == 0) {
+ tabularray_cols <- rep("Q[]", ncol(x))
+ } else if (length(x@width) == 1) {
+ tabularray_cols <- rep("X[]", ncol(x))
+ spec <- sprintf("width={%s\\linewidth},", round(x@width, 4))
+ out <- tabularray_insert(out, content = spec, type = "inner")
+ } else if (length(x@width) > 1) {
+ tabularray_cols <- sprintf("X[%s]", x@width)
+ spec <- sprintf("width={%s\\linewidth},", round(sum(x@width), 4))
+ out <- tabularray_insert(out, content = spec, type = "inner")
+ }
- # colspec (we don't need rowspec)
- colspec <- sprintf("colspec={%s},", paste(tabularray_cols, collapse = ""))
- out <- tabularray_insert(out, content = colspec, type = "inner")
+ # colspec (we don't need rowspec)
+ colspec <- sprintf("colspec={%s},", paste(tabularray_cols, collapse = ""))
+ out <- tabularray_insert(out, content = colspec, type = "inner")
- # notes
- if (length(x@notes) > 0) {
- if (length(x@caption) == 0) {
+ # notes
+ if (length(x@notes) > 0) {
+ if (length(x@caption) == 0) {
# otherwise an empty caption is created automatically
out <- tabularray_insert(out, content = "entry=none,label=none", type = "outer")
- }
- if (is.null(names(x@notes))) {
- lab <- sapply(seq_along(x@notes), function(k) strrep(" ", k - 1))
- } else {
- lab <- NULL
- pad <- 0
- for (i in seq_along(x@notes)) {
- # tabularray requires unique labels, but multiple blanks work
- if (names(x@notes)[i] == "") {
- lab[i] <- strrep(" ", pad) # not sure why -1 is necessary in tabularray
- pad <- pad + 1
- } else {
- lab[i] <- names(x@notes)[i]
+ }
+ if (is.null(names(x@notes))) {
+ lab <- sapply(seq_along(x@notes), function(k) strrep(" ", k - 1))
+ } else {
+ lab <- NULL
+ pad <- 0
+ for (i in seq_along(x@notes)) {
+ # tabularray requires unique labels, but multiple blanks work
+ if (names(x@notes)[i] == "") {
+ lab[i] <- strrep(" ", pad) # not sure why -1 is necessary in tabularray
+ pad <- pad + 1
+ } else {
+ lab[i] <- names(x@notes)[i]
+ }
}
}
+ notes <- sapply(x@notes, function(n) if (is.list(n)) n$text else n)
+ for (k in seq_along(notes)) {
+ spec <- sprintf("note{%s}={%s}", lab[k], notes[k])
+ out <- tabularray_insert(out, content = spec, type = "outer")
+ }
}
- notes <- sapply(x@notes, function(n) if (is.list(n)) n$text else n)
- for (k in seq_along(notes)) {
- spec <- sprintf("note{%s}={%s}", lab[k], notes[k])
- out <- tabularray_insert(out, content = spec, type = "outer")
- }
- }
-
- if (isTRUE(tall)) {
- out <- sub("\\begin{tblr}", "\\begin{talltblr}", out, fixed = TRUE)
- out <- sub("\\end{tblr}", "\\end{talltblr}", out, fixed = TRUE)
- }
- x@table_string <- out
- x@body <- body
-
- return(x)
-})
+ if (isTRUE(tall)) {
+ out <- sub("\\begin{tblr}", "\\begin{talltblr}", out, fixed = TRUE)
+ out <- sub("\\end{tblr}", "\\end{talltblr}", out, fixed = TRUE)
+ }
+ x@table_string <- out
+ x@body <- body
+ return(x)
+ }
+)
diff --git a/R/tt_typst.R b/R/tt_typst.R
index 1cd347c9..b41530dd 100644
--- a/R/tt_typst.R
+++ b/R/tt_typst.R
@@ -2,86 +2,95 @@ setMethod(
f = "tt_eval",
signature = "tinytable_typst",
definition = function(x, ...) {
- out <- readLines(system.file("templates/typst.typ", package = "tinytable"))
- out <- paste(out, collapse = "\n")
+ out <- readLines(system.file("templates/typst.typ", package = "tinytable"))
+ out <- paste(out, collapse = "\n")
- # body
- body <- apply(x@table_dataframe, 2, function(k) paste0("[", k, "]"))
- if (nrow(x@table_dataframe) && is.null(dim(body))) {
- body <- matrix(body)
- }
- header <- !is.null(colnames(x)) && length(colnames(x)) > 0
- if (header) {
- header <- paste(paste0("[", colnames(x), "]"), collapse = ", ")
- header <- paste0(header, ",")
- out <- lines_insert(out, header, "repeat: true", "after")
- }
- body <- apply(body, 1, paste, collapse = ", ", simplify = FALSE)
- body <- paste(body, collapse = ",\n")
- body <- paste0(body, ",\n")
- out <- typst_insert(out, body, type = "body")
+ # body
+ body <- apply(x@table_dataframe, 2, function(k) paste0("[", k, "]"))
+ if (nrow(x@table_dataframe) && is.null(dim(body))) {
+ body <- matrix(body)
+ }
+ header <- !is.null(colnames(x)) && length(colnames(x)) > 0
+ if (header) {
+ header <- paste(paste0("[", colnames(x), "]"), collapse = ", ")
+ header <- paste0(header, ",")
+ out <- lines_insert(out, header, "repeat: true", "after")
+ }
+ body <- apply(body, 1, paste, collapse = ", ", simplify = FALSE)
+ body <- paste(body, collapse = ",\n")
+ body <- paste0(body, ",\n")
+ out <- typst_insert(out, body, type = "body")
- if (length(x@width) == 0) {
- width <- rep("auto", ncol(x))
- } else if (length(x@width) == 1) {
- width <- rep(sprintf("%.2f%%", x@width / ncol(x) * 100), ncol(x))
- } else {
- width <- sprintf("%.2f%%", x@width * 100)
- }
- width <- sprintf(" columns: (%s),", paste(width, collapse = ", "))
- out <- lines_insert(out, width, "tinytable table start", "after")
+ if (length(x@width) == 0) {
+ width <- rep("auto", ncol(x))
+ } else if (length(x@width) == 1) {
+ width <- rep(sprintf("%.2f%%", x@width / ncol(x) * 100), ncol(x))
+ } else {
+ width <- sprintf("%.2f%%", x@width * 100)
+ }
+ width <- sprintf(" columns: (%s),", paste(width, collapse = ", "))
+ out <- lines_insert(out, width, "tinytable table start", "after")
- # notes
- if (length(x@notes) > 0) {
- ft <- "
+ # notes
+ if (length(x@notes) > 0) {
+ ft <- "
table.footer(
repeat: false,
// tinytable notes after
),
"
- out <- lines_insert(out, ft, "tinytable footer after", "after")
- notes <- rev(x@notes)
- # otherwise an empty caption is created automatically
- if (is.null(names(notes))) {
- lab <- rep("", length(notes))
- } else {
- lab <- names(notes)
- }
- notes <- sapply(notes, function(n) if (is.list(n)) n$text else n)
- for (k in seq_along(notes)) {
- if (lab[k] == "") {
- tmp <- sprintf(" table.cell(align: left, colspan: %s, [%s]),", ncol(x), notes[k])
+ out <- lines_insert(out, ft, "tinytable footer after", "after")
+ notes <- rev(x@notes)
+ # otherwise an empty caption is created automatically
+ if (is.null(names(notes))) {
+ lab <- rep("", length(notes))
} else {
- tmp <- sprintf(" table.cell(align: left, colspan: %s, [#super[%s] %s]),", ncol(x), lab[k], notes[k])
+ lab <- names(notes)
+ }
+ notes <- sapply(notes, function(n) if (is.list(n)) n$text else n)
+ for (k in seq_along(notes)) {
+ if (lab[k] == "") {
+ tmp <- sprintf(" table.cell(align: left, colspan: %s, %s),", ncol(x), notes[k])
+ } else {
+ n <- notes[k]
+ l <- sprintf("[#super[%s] ", lab[k])
+ n <- sub("[", l, n, fixed = TRUE)
+ tmp <- sprintf(" table.cell(align: left, colspan: %s, %s),", ncol(x), n)
+ }
+ tmp <- sub("text(, ", "text(", tmp, fixed = TRUE)
+ out <- lines_insert(out, tmp, "tinytable notes after", "after")
}
- out <- lines_insert(out, tmp, "tinytable notes after", "after")
}
- }
- # default alignment
- align_default <- sprintf(
- " #let align-default-array = ( %s, ) // tinytable align-default-array here",
- paste(rep("left", ncol(x)), collapse = ", "))
- out <- lines_insert(
- out,
- align_default,
- "// tinytable align-default-array before",
- "after")
+ # default alignment
+ align_default <- sprintf(
+ " #let align-default-array = ( %s, ) // tinytable align-default-array here",
+ paste(rep("left", ncol(x)), collapse = ", ")
+ )
+ out <- lines_insert(
+ out,
+ align_default,
+ "// tinytable align-default-array before",
+ "after"
+ )
- x@table_string <- out
+ x@table_string <- out
- return(x)
-})
+ return(x)
+ }
+)
typst_insert <- function(x, content = NULL, type = "body") {
- if (is.null(content)) return(x)
+ if (is.null(content)) {
+ return(x)
+ }
out <- strsplit(x, "\n")[[1]]
comment <- switch(type,
- "lines" = "tinytable lines before",
- "style" = "tinytable cell style before",
- "body" = "tinytable cell content after"
+ "lines" = "tinytable lines before",
+ "style" = "tinytable cell style before",
+ "body" = "tinytable cell content after"
)
idx <- grep(comment, out)
diff --git a/R/utils.R b/R/utils.R
index 70bc5435..39f5bdcf 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -36,7 +36,7 @@ lines_drop_consecutive_empty <- function(x) {
lines <- strsplit(x, "\n")[[1]]
tmp <- rle(lines)
tmp$lengths[trimws(tmp$values) == ""] <- 1
- lines <- inverse.rle(tmp)
+ lines <- inverse.rle(tmp)
x <- paste0(lines, collapse = "\n")
return(x)
}
@@ -78,7 +78,7 @@ lines_drop_between <- function(text, regex_start, regex_end, fixed = FALSE) {
if (idx_start >= idx_end) {
stop("`regex_start` matches a line after `regex_end`.", call. = FALSE)
}
- lines_to_keep <- c(1:(idx_start-1), (idx_end+1):length(lines))
+ lines_to_keep <- c(1:(idx_start - 1), (idx_end + 1):length(lines))
output <- lines[lines_to_keep]
out <- paste(output, collapse = "\n")
return(out)
@@ -86,19 +86,19 @@ lines_drop_between <- function(text, regex_start, regex_end, fixed = FALSE) {
lines_insert <- function(old, new, regex, position = "before") {
- lines <- strsplit(old, "\n")[[1]]
- idx <- grep(regex, lines)
- if (length(idx) != 1 || anyNA(idx)) {
- stop("The `regex` supplied `lines_insert()` did not match a unique line.", call. = FALSE)
- }
- if (position == "before") {
- top <- lines[1:(idx - 1)]
- bot <- lines[idx:length(lines)]
- } else if (position == "after") {
- top <- lines[1:idx]
- bot <- lines[(idx + 1):length(lines)]
- }
- lines <- c(top, new, bot)
- out <- paste(lines, collapse = "\n")
- return(out)
+ lines <- strsplit(old, "\n")[[1]]
+ idx <- grep(regex, lines)
+ if (length(idx) != 1 || anyNA(idx)) {
+ stop("The `regex` supplied `lines_insert()` did not match a unique line.", call. = FALSE)
+ }
+ if (position == "before") {
+ top <- lines[1:(idx - 1)]
+ bot <- lines[idx:length(lines)]
+ } else if (position == "after") {
+ top <- lines[1:idx]
+ bot <- lines[(idx + 1):length(lines)]
+ }
+ lines <- c(top, new, bot)
+ out <- paste(lines, collapse = "\n")
+ return(out)
}
diff --git a/R/zzz.R b/R/zzz.R
index add21f67..d4564bd9 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,5 +1,8 @@
-.onLoad <- function(libname, pkgname) {
- if(requireNamespace("knitr", quietly = TRUE)) {
- registerS3method("knit_print", "tinytable", knit_print.tinytable, envir = asNamespace("knitr"))
- }
-}
+# replaced this with @rawNamespace S3method(knitr::knit_print, tinytable) in print.R
+
+
+# .onLoad <- function(libname, pkgname) {
+# if (requireNamespace("knitr", quietly = TRUE)) {
+# registerS3method("knit_print", "tinytable", knit_print.tinytable, envir = asNamespace("knitr"))
+# }
+# }
diff --git a/README.md b/README.md
index 18102d03..17a7fe8c 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,7 @@
+
@@ -12,7 +13,7 @@
## What?
`tinytable` is a small but powerful `R` package to draw beautiful tables
-in a variety of formats: HTML, LaTeX, Word, PDF, PNG, Markdown, and
+in a variety of formats: HTML, LaTeX, Word[^1], PDF, PNG, Markdown, and
Typst. The user interface is minimalist and easy to learn, while giving
users access to powerful frameworks to create endlessly customizable
tables.
@@ -26,25 +27,24 @@ ecosystem. Why release a new one? As [the maintainer of
`modelsummary`](https://modelsummary.com), I needed a table-drawing
package which was:
-- *Simple*: Streamlined, consistent, and uncluttered user interface,
- with few functions to learn.
-- *Flexible*: Expressive frameworks to customize tables in HTML and
- LaTeX formats.[1]
-- *Zero-dependency*: Avoid importing any other `R` package.[2]
-- *Concise*: Draw beautiful tables without typing a lot of code.
-- *Safe*: User inputs are checked thoroughly, and informative errors
- are returned early.
-- *Maintainable*: A small code base which does not rely on too many
- complex regular expressions.
-- *Readable*: HTML and LaTeX code should be human-readable and
- editable.
-- *Free*: This package will always be free. Tiny tables for a tiny
- price!
+- *Simple*: Streamlined, consistent, and uncluttered user interface,
+ with few functions to learn.
+- *Flexible*: Expressive frameworks to customize tables in HTML and
+ LaTeX formats.[^2]
+- *Zero-dependency*: Avoid importing any other `R` package.[^3]
+- *Concise*: Draw beautiful tables without typing a lot of code.
+- *Safe*: User inputs are checked thoroughly, and informative errors are
+ returned early.
+- *Maintainable*: A small code base which does not rely on too many
+ complex regular expressions.
+- *Readable*: HTML and LaTeX code should be human-readable and editable.
+- *Free*: This package will always be free. Tiny tables for a tiny
+ price!
To achieve these goals, the design philosophy of `tinytable` rests on
three pillars:
-1. *Data is separate from style.* The code that this package creates
+1) *Data is separate from style.* The code that this package creates
keeps the content of a table separate from the style sheet that
applies to its cells. This is in contrast to other `R` packages that
modify the actual text in each cell to style it. Keeping data and
@@ -53,13 +53,13 @@ three pillars:
developers to keep a simpler code base, with minimal use of messy
regular expressions.
-2. *Flexibility.* Users’ needs are extremely varied, and a
+2) *Flexibility.* Users’ needs are extremely varied, and a
table-drawing package must be flexible enough to accomodate
different ideas. To achieve this, `tinytable` builds on
battle-tested and versatile frameworks like `Bootstrap` for HTML and
`tabularray` for LaTeX.
-3. [*Lightweight is the right weight.*](https://www.tinyverse.org/)
+3) [*Lightweight is the right weight.*](https://www.tinyverse.org/)
Some of the most popular table-drawing packages in the `R` ecosystem
are very heavy: A single `library()` call can sometimes load upwards
of 65 `R` packages. In contrast, `tinytable` imports zero 3rd party
@@ -131,31 +131,34 @@ tt(x,
## Tutorial
-The `tinytable` 0.5.0.5 tutorial will take you much further. It is
+The `tinytable` 0.6.1.3 tutorial will take you much further. It is
available in two formats:
-- [Tutorial
- (PDF)](https://vincentarelbundock.github.io/tinytable/vignettes/tinytable_tutorial.pdf)
-- Tutorial (HTML):
- - [Tiny
- tables](https://vincentarelbundock.github.io/tinytable/vignettes/tinytable.html)
- - [Format](https://vincentarelbundock.github.io/tinytable/vignettes/format.html)
- - [Style](https://vincentarelbundock.github.io/tinytable/vignettes/style.html)
- - [Group
- labels](https://vincentarelbundock.github.io/tinytable/vignettes/group.html)
- - [Plots and
- images](https://vincentarelbundock.github.io/tinytable/vignettes/plot.html)
- - [Themes](https://vincentarelbundock.github.io/tinytable/vignettes/theme.html)
- - [Notebooks (Quarto, Rmarkdown, Bookdown,
- etc.)](https://vincentarelbundock.github.io/tinytable/vignettes/notebooks.html)
- - [Customization](https://vincentarelbundock.github.io/tinytable/vignettes/custom.html)
- - [FAQ](https://vincentarelbundock.github.io/tinytable/vignettes/faq.html)
- - [Alternatives](https://vincentarelbundock.github.io/tinytable/vignettes/alternatives.html)
-
-[1] Other formats like Markdown and Typst are also available, but less
-flexible.
-
-[2] Some extra packages can be imported to access specific
-functionality, such as integration with Quarto, inserting `ggplot2`
-objects as inline plots, and saving tables to PNG images or PDF
-documents.
+- [Tutorial
+ (PDF)](https://vincentarelbundock.github.io/tinytable/vignettes/tinytable_tutorial.pdf)
+- Tutorial (HTML):
+ - [Tiny
+ tables](https://vincentarelbundock.github.io/tinytable/vignettes/tinytable.html)
+ - [Format](https://vincentarelbundock.github.io/tinytable/vignettes/format.html)
+ - [Style](https://vincentarelbundock.github.io/tinytable/vignettes/style.html)
+ - [Group
+ labels](https://vincentarelbundock.github.io/tinytable/vignettes/group.html)
+ - [Plots and
+ images](https://vincentarelbundock.github.io/tinytable/vignettes/plot.html)
+ - [Themes](https://vincentarelbundock.github.io/tinytable/vignettes/theme.html)
+ - [Notebooks (Quarto, Rmarkdown, Bookdown,
+ etc.)](https://vincentarelbundock.github.io/tinytable/vignettes/notebooks.html)
+ - [Customization](https://vincentarelbundock.github.io/tinytable/vignettes/custom.html)
+ - [FAQ](https://vincentarelbundock.github.io/tinytable/vignettes/faq.html)
+ - [Alternatives](https://vincentarelbundock.github.io/tinytable/vignettes/alternatives.html)
+
+[^1]: Styling options in Word are somewhat limited. See the FAQ page and
+ the `style_tt()` documentation for details.
+
+[^2]: Other formats like Markdown and Typst are also available, but less
+ flexible.
+
+[^3]: Some extra packages can be imported to access specific
+ functionality, such as integration with Quarto, inserting `ggplot2`
+ objects as inline plots, and saving tables to PNG images or PDF
+ documents.
diff --git a/README.qmd b/README.qmd
index a5a3f8ed..6725cde1 100644
--- a/README.qmd
+++ b/README.qmd
@@ -1,4 +1,6 @@
-
+---
+format: gfm
+---
}}
+
+You can set options in a script or via \code{.Rprofile}. Note: be cautious with \code{.Rprofile} settings as they may affect reproducibility.
+\subsection{Default values for function arguments}{
+\subsection{tt()}{
\itemize{
-\item \code{options("tinytable_quarto_figure" = FALSE)}: Typst only. Normally, it is best to allow Quarto to define the figure environment, so the default behavior is to not include one.
-\item \code{options(tinytable_print_rstudio_notebook = "inline")}: Display tables "inline" or in the "viewer" in RStudio notebooks.
+\item \code{tinytable_tt_digits}
+\item \code{tinytable_tt_caption}
+\item \code{tinytable_tt_notes}
+\item \code{tinytable_tt_width}
+\item \code{tinytable_tt_theme}
+\item \code{tinytable_tt_rownames}
}
}
-\subsection{Data Processing}{
-
-The \code{format_tt(quarto=TRUE)} argument activates Quarto data processing for specific cells. This funcationality comes with a few warnings:
-\enumerate{
-\item Currently, Quarto provides a \verb{\\QuartoMarkdownBase64\{\}} LaTeX macro, but it does not appear to do anything with it. References and markdown codes may not be processed as expected in LaTeX.
-\item Quarto data processing can enter in conflict with \code{tinytable} styling or formatting options. See below for how to disable it.
+\subsection{format_tt()}{
+\itemize{
+\item \code{tinytable_format_digits}
+\item \code{tinytable_format_num_fmt}
+\item \code{tinytable_format_num_zero}
+\item \code{tinytable_format_num_suffix}
+\item \code{tinytable_format_num_mark_big}
+\item \code{tinytable_format_num_mark_dec}
+\item \code{tinytable_format_date}
+\item \code{tinytable_format_bool}
+\item \code{tinytable_format_other}
+\item \code{tinytable_format_replace}
+\item \code{tinytable_format_escape}
+\item \code{tinytable_format_markdown}
+\item \code{tinytable_format_quarto}
+\item \code{tinytable_format_fn}
+\item \code{tinytable_format_sprintf}
+}
}
-\code{options(tinytable_quarto_disable_processing = TRUE)}
-
-Disable Quarto processing of cell content. Setting this global option to \code{FALSE} may lead to conflicts with some \code{tinytable} features, but it also allows use of markdown and Quarto-specific code in table cells, such as cross-references.
+\subsection{save_tt()}{
+\itemize{
+\item \code{tinytable_save_overwrite}
+}
+}
-\if{html}{\out{
}}
+\subsection{theme_tt()}{
-See this link for more details: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing
+Placement:
+\itemize{
+\item \code{tinytable_theme_placement_float}
+\item \code{tinytable_theme_placement_horizontal}
}
+Resize:
+\itemize{
+\item \code{tinytable_theme_resize_width}
+\item \code{tinytable_theme_resize_direction}
}
-\subsection{HTML}{
+Multipage:
\itemize{
-\item \code{options(tinytable_html_mathjax = TRUE)}
+\item \code{tinytable_theme_multipage_rowhead}
+\item \code{tinytable_theme_multipage_rowfoot}
+}
+
+Tabular:
\itemize{
-\item insert MathJax scripts in the HTML document. Warning: This may conflict with other elements of the page if MathJax is otherwise loaded.
+\item \code{tinytable_theme_tabular_style}
+}
}
-\item \code{options(tinytable_html_portable = TRUE)}
+
+\subsection{print.tinytable()}{
\itemize{
-\item \code{plot_tt()} inserts base 64 encoded images directly in the HTML file rather than use external links.
+\item \code{tinytable_print_output}
}
}
+
}
-\subsection{PDF}{
+\subsection{Output-specific options}{
+\subsection{HTML}{
\itemize{
-\item \code{options(tinytable_pdf_clean = TRUE)}
+\item \code{tinytable_html_mathjax}: Insert MathJax scripts (warning: may conflict if MathJax is loaded elsewhere)
+\item \code{tinytable_html_portable}: Insert base64 encoded images directly in HTML for \code{plot_tt()}
+}
+}
+
+\subsection{PDF}{
\itemize{
-\item deletes temporary and log files.
+\item \code{tinytable_pdf_clean}: Delete temporary and log files
+\item \code{tinytable_pdf_engine}: Choose between "xelatex", "pdflatex", "lualatex"
}
-\item \code{options(tinytable_pdf_engine = "xelatex")}
+}
+
+\subsection{Quarto}{
+
+The \code{format_tt(quarto=TRUE)} argument enables Quarto data processing with some limitations:
+\enumerate{
+\item The \verb{\\QuartoMarkdownBase64\{\}} LaTeX macro may not process references and markdown as expected
+\item Quarto processing may conflict with \code{tinytable} styling/formatting
+}
+
+Options:
\itemize{
-\item "xelatex", "pdflatex", "lualatex"
+\item \code{tinytable_quarto_disable_processing}: Disable Quarto cell processing
+\item \code{tinytable_print_rstudio_notebook}: Display tables "inline" or in "viewer" for RStudio notebooks
+\item \code{tinytable_quarto_figure}: Control Typst figure environment in Quarto
}
+
+Example of Quarto-specific code in cells:
+
+\if{html}{\out{
}}
+
+For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing
}
+
}
}
\examples{
dat <- data.frame(
a = rnorm(3, mean = 10000),
- b = rnorm(3, 10000))
+ b = rnorm(3, 10000)
+)
tab <- tt(dat)
format_tt(tab,
- digits = 2,
- num_mark_dec = ",",
- num_mark_big = " ")
-
+ digits = 2,
+ num_mark_dec = ",",
+ num_mark_big = " "
+)
+
k <- tt(data.frame(x = c(0.000123456789, 12.4356789)))
format_tt(k, digits = 2, num_fmt = "significant_cell")
-
+
dat <- data.frame(
- a = c("Burger", "Halloumi", "Tofu", "Beans"),
- b = c(1.43202, 201.399, 0.146188, 0.0031),
- c = c(98938272783457, 7288839482, 29111727, 93945))
+ a = c("Burger", "Halloumi", "Tofu", "Beans"),
+ b = c(1.43202, 201.399, 0.146188, 0.0031),
+ c = c(98938272783457, 7288839482, 29111727, 93945)
+)
tt(dat) |>
- format_tt(j = "a", sprintf = "Food: \%s") |>
- format_tt(j = 2, digits = 1, num_fmt = "decimal", num_zero = TRUE) |>
- format_tt(j = "c", digits = 2, num_suffix = TRUE)
-
+ format_tt(j = "a", sprintf = "Food: \%s") |>
+ format_tt(j = 2, digits = 1, num_fmt = "decimal", num_zero = TRUE) |>
+ format_tt(j = "c", digits = 2, num_suffix = TRUE)
+
y <- tt(data.frame(x = c(123456789.678, 12435.6789)))
-format_tt(y, digits=3, num_mark_big=" ")
+format_tt(y, digits = 3, num_mark_big = " ")
x <- tt(data.frame(Text = c("_italicized text_", "__bold text__")))
-format_tt(x, markdown=TRUE)
+format_tt(x, markdown = TRUE)
tab <- data.frame(a = c(NA, 1, 2), b = c(3, NA, 5))
tt(tab) |> format_tt(replace = "-")
dat <- data.frame(
- "LaTeX" = c("Dollars $", "Percent \%", "Underscore _"),
- "HTML" = c(" ", "4", "blah")
+ "LaTeX" = c("Dollars $", "Percent \%", "Underscore _"),
+ "HTML" = c(" ", "4", "blah")
)
-tt(dat) |> format_tt(escape = TRUE)
+tt(dat) |> format_tt(escape = TRUE)
}
diff --git a/man/group_tt.Rd b/man/group_tt.Rd
index e7fd6d23..3e1f1653 100644
--- a/man/group_tt.Rd
+++ b/man/group_tt.Rd
@@ -31,13 +31,24 @@ Spanning labels to identify groups of rows or columns
\details{
Warning: The \code{style_tt()} can normally be used to style the group headers, as expected, but that feature is not available for Markdown and Word tables.
}
+\section{Word and Markdown limitations}{
+
+
+Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} argument is also unavailable
+Moreover, the \code{style_tt()} function cannot be used to style headers inserted by the \code{group_tt()} function;
+instead, you should style the headers directly in the header definition using markdown syntax:
+\code{group_tt(i = list("*italic header*" = 2))}. These limitations are due to the fact that there is no markdown
+syntax for the other options, and that we create Word documents by converting a markdown table to .docx
+via the Pandoc software.
+}
+
\examples{
# vector of row labels
dat <- data.frame(
- label = c("a", "a", "a", "b", "b", "c", "a", "a"),
- x1 = rnorm(8),
- x2 = rnorm(8))
+ label = c("a", "a", "a", "b", "b", "c", "a", "a"),
+ x1 = rnorm(8),
+ x2 = rnorm(8))
tt(dat[, 2:3]) |> group_tt(i = dat$label)
# named lists of labels
diff --git a/man/rbind2-tinytable-tinytable-method.Rd b/man/rbind2-tinytable-tinytable-method.Rd
index 8b6461d1..861f58f1 100644
--- a/man/rbind2-tinytable-tinytable-method.Rd
+++ b/man/rbind2-tinytable-tinytable-method.Rd
@@ -42,8 +42,8 @@ This function relies on the \code{rbindlist()} function from the \code{data.tabl
}
\examples{
library(tinytable)
-x = tt(mtcars[1:3, 1:2], caption = "Combine two tiny tables.")
-y = tt(mtcars[4:5, 8:10])
+x <- tt(mtcars[1:3, 1:2], caption = "Combine two tiny tables.")
+y <- tt(mtcars[4:5, 8:10])
# rbind() does not support additional aarguments
# rbind2() supports additional arguments
diff --git a/man/save_tt.Rd b/man/save_tt.Rd
index 25e9f939..4560a46f 100644
--- a/man/save_tt.Rd
+++ b/man/save_tt.Rd
@@ -29,6 +29,162 @@ A string with the table when \code{output} is a format, and the file path when \
\description{
This function saves an object of class tinytable to a specified file and format, with an option to overwrite existing files.
}
+\section{Dependencies}{
+
+\itemize{
+\item \code{.pdf} output requires a full LaTeX installation on the local computer.
+\item \code{.png} output requires the \code{webshot2} package.
+\item \code{.html} self-contained files require the \code{base64enc} package.
+}
+}
+
+\section{LaTeX preamble}{
+
+
+\code{tinytable} uses the \code{tabularray} package from your LaTeX distribution to draw tables. \code{tabularray}, in turn, uses the special \code{tblr}, \code{talltblr}, and \code{longtblr} environments.
+
+When rendering a document from Quarto or Rmarkdown directly to PDF, \code{tinytable} will populate the LaTeX preamble automatically with all the required packages. For standalone LaTeX documents, these commands should be inserted in the preamble manually:
+
+Note: Your document will fail to compile to PDF in Quarto if you enable caching and you use tinytable due to missing LaTeX headers. To avoid this problem, set the option \verb{#| cache: false} for the chunk(s) where you use tinytable.
+
+\if{html}{\out{
}}
+}
+
+\section{Global options}{
+
+
+Options can be set with \code{options()} and change the default behavior of tinytable. For example:
+
+\if{html}{\out{
}}
+
+For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing
+}
+
+}
+}
+
\examples{
library(tinytable)
x <- mtcars[1:4, 1:5]
diff --git a/man/style_tt.Rd b/man/style_tt.Rd
index f6c48004..5c54a1da 100644
--- a/man/style_tt.Rd
+++ b/man/style_tt.Rd
@@ -37,7 +37,12 @@ style_tt(
\arguments{
\item{x}{A table object created by \code{tt()}.}
-\item{i}{Row indices where the styling should be applied. Can be a single value, a vector, or a logical matrix with the same number of rows and columns as \code{x}. \code{i=0} is the header, and negative values are higher level headers. Row indices refer to rows \emph{after} the insertion of row labels by \code{group_tt()}, when applicable.}
+\item{i}{Numeric vector, logical matrix, or string..
+\itemize{
+\item Numeric vector: Row indices where the styling should be applied. Can be a single value or a vector.
+\item Logical matrix: A matrix with the same number of rows and columns as \code{x}. \code{i=0} is the header, and negative values are higher level headers. Row indices refer to rows \emph{after} the insertion of row labels by \code{group_tt()}, when applicable.
+\item String: "notes" or "caption".
+}}
\item{j}{Column indices where the styling should be applied. Can be:
\itemize{
@@ -123,9 +128,18 @@ Style a Tiny Table
}
\details{
This function applies styling to a table created by \code{tt()}. It allows customization of text style (bold, italic, monospace), text and background colors, font size, cell width, text alignment, column span, and indentation. The function also supports passing native instructions to LaTeX (tabularray) and HTML (bootstrap) formats.
+}
+\section{Word and Markdown limitations}{
-Note: Markdown and Word tables only support these styles: italic, bold, strikeout. Moreover, the \code{style_tt()} function cannot be used to style headers inserted by the \code{group_tt()} function; instead, you should style the headers directly in the header definition using markdown syntax: \code{group_tt(i = list("*italic header*" = 2))}. These limitations are due to the fact that there is no markdown syntax for the other options, and that we create Word documents by converting a markdown table to .docx via the Pandoc software.
+
+Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} argument is also unavailable
+Moreover, the \code{style_tt()} function cannot be used to style headers inserted by the \code{group_tt()} function;
+instead, you should style the headers directly in the header definition using markdown syntax:
+\code{group_tt(i = list("*italic header*" = 2))}. These limitations are due to the fact that there is no markdown
+syntax for the other options, and that we create Word documents by converting a markdown table to .docx
+via the Pandoc software.
}
+
\examples{
\dontshow{if (knitr::is_html_output()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf}
\dontshow{\}) # examplesIf}
@@ -136,15 +150,15 @@ library(tinytable)
tt(mtcars[1:5, 1:6])
# Alignment
-tt(mtcars[1:5, 1:6]) |>
+tt(mtcars[1:5, 1:6]) |>
style_tt(j = 1:5, align = "lcccr")
# Colors and styles
-tt(mtcars[1:5, 1:6]) |>
+tt(mtcars[1:5, 1:6]) |>
style_tt(i = 2:3, background = "black", color = "orange", bold = TRUE)
# column selection with `j``
-tt(mtcars[1:5, 1:6]) |>
+tt(mtcars[1:5, 1:6]) |>
style_tt(j = 5:6, background = "pink")
tt(mtcars[1:5, 1:6]) |>
@@ -158,27 +172,27 @@ tt(mtcars[1:5, 1:6], theme = "void") |>
i = 2, j = 2,
colspan = 3,
rowspan = 2,
- align="c",
+ align = "c",
alignv = "m",
color = "white",
background = "black",
bold = TRUE)
-
+
tt(mtcars[1:5, 1:6], theme = "void") |>
style_tt(
- i=0:3,
- j=1:3,
- line="tblr",
- line_width=0.4,
- line_color="teal")
-
+ i = 0:3,
+ j = 1:3,
+ line = "tblr",
+ line_width = 0.4,
+ line_color = "teal")
+
tt(mtcars[1:5, 1:6], theme = "bootstrap") |>
- style_tt(
- i = c(2,5),
- j = 3,
- strikeout = TRUE,
- fontsize = 0.7)
-
+ style_tt(
+ i = c(2, 5),
+ j = 3,
+ strikeout = TRUE,
+ fontsize = 0.7)
+
tt(mtcars[1:5, 1:6]) |>
style_tt(bootstrap_class = "table table-dark table-hover")
diff --git a/man/theme_tt.Rd b/man/theme_tt.Rd
index 9ac81d50..dc21420f 100644
--- a/man/theme_tt.Rd
+++ b/man/theme_tt.Rd
@@ -17,6 +17,7 @@ theme_tt(x, theme, ...)
\item "placement": Position of the table environment (LaTeX)
\item "rotate": Rotate a LaTeX or Typst table.
\item "resize": Scale a LaTeX \code{tinytable} to fit the \code{width} argument.
+\item "spacing": Draw more compact or airy tables.
\item "striped": Grey stripes on alternating rows
\item "tabular": Remove table environment (LaTeX) or Javascript/CSS (HTML)
\item "void": No rules
@@ -91,6 +92,12 @@ rotate
\item LaTeX: In Quarto documents, captions must be specified using the \code{caption} argument in \code{tt()} rather than via Quarto chunk options.
}
}
+
+spacing
+\itemize{
+\item \code{rowsep}: Row spacing
+\item \code{colsep}: Column spacing
+}
}
\examples{
@@ -104,7 +111,7 @@ tt(x, theme = "striped")
tt(x) |> theme_tt("striped")
# resize w/ argument
-x <- cbind(mtcars[1:10,], mtcars[1:10,])
+x <- cbind(mtcars[1:10, ], mtcars[1:10, ])
tt(x) |>
theme_tt("resize", width = .9) |>
print("latex")
diff --git a/man/tt.Rd b/man/tt.Rd
index 6228189c..52e100a6 100644
--- a/man/tt.Rd
+++ b/man/tt.Rd
@@ -67,6 +67,15 @@ The \code{tt} function renders a table in different formats with various styling
\code{tinytable} attempts to determine the appropriate way to print the table based on interactive use, RStudio availability, and output format in RMarkdown or Quarto documents. Users can call \code{print(x, output="markdown")} to print the table in a specific format. Alternatively, they can set a global option: \code{options("tinytable_print_output"="markdown")}
}
+\section{Dependencies}{
+
+\itemize{
+\item \code{.pdf} output requires a full LaTeX installation on the local computer.
+\item \code{.png} output requires the \code{webshot2} package.
+\item \code{.html} self-contained files require the \code{base64enc} package.
+}
+}
+
\section{LaTeX preamble}{
@@ -89,67 +98,139 @@ Note: Your document will fail to compile to PDF in Quarto if you enable caching
}\if{html}{\out{}}
}
+\section{Word and Markdown limitations}{
+
+
+Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} argument is also unavailable
+Moreover, the \code{style_tt()} function cannot be used to style headers inserted by the \code{group_tt()} function;
+instead, you should style the headers directly in the header definition using markdown syntax:
+\code{group_tt(i = list("*italic header*" = 2))}. These limitations are due to the fact that there is no markdown
+syntax for the other options, and that we create Word documents by converting a markdown table to .docx
+via the Pandoc software.
+}
+
\section{Global options}{
-Many global options can be used to set the default argument values of \code{tinytable} functions.
-For a full list, see:
+Options can be set with \code{options()} and change the default behavior of tinytable. For example:
-https://vincentarelbundock.github.io/tinytable/vignettes/options.html
-\subsection{Quarto}{
-\subsection{Figure environment}{
+\if{html}{\out{
}}
+
+You can set options in a script or via \code{.Rprofile}. Note: be cautious with \code{.Rprofile} settings as they may affect reproducibility.
+\subsection{Default values for function arguments}{
+\subsection{tt()}{
\itemize{
-\item \code{options("tinytable_quarto_figure" = FALSE)}: Typst only. Normally, it is best to allow Quarto to define the figure environment, so the default behavior is to not include one.
-\item \code{options(tinytable_print_rstudio_notebook = "inline")}: Display tables "inline" or in the "viewer" in RStudio notebooks.
+\item \code{tinytable_tt_digits}
+\item \code{tinytable_tt_caption}
+\item \code{tinytable_tt_notes}
+\item \code{tinytable_tt_width}
+\item \code{tinytable_tt_theme}
+\item \code{tinytable_tt_rownames}
}
}
-\subsection{Data Processing}{
-
-The \code{format_tt(quarto=TRUE)} argument activates Quarto data processing for specific cells. This funcationality comes with a few warnings:
-\enumerate{
-\item Currently, Quarto provides a \verb{\\QuartoMarkdownBase64\{\}} LaTeX macro, but it does not appear to do anything with it. References and markdown codes may not be processed as expected in LaTeX.
-\item Quarto data processing can enter in conflict with \code{tinytable} styling or formatting options. See below for how to disable it.
+\subsection{format_tt()}{
+\itemize{
+\item \code{tinytable_format_digits}
+\item \code{tinytable_format_num_fmt}
+\item \code{tinytable_format_num_zero}
+\item \code{tinytable_format_num_suffix}
+\item \code{tinytable_format_num_mark_big}
+\item \code{tinytable_format_num_mark_dec}
+\item \code{tinytable_format_date}
+\item \code{tinytable_format_bool}
+\item \code{tinytable_format_other}
+\item \code{tinytable_format_replace}
+\item \code{tinytable_format_escape}
+\item \code{tinytable_format_markdown}
+\item \code{tinytable_format_quarto}
+\item \code{tinytable_format_fn}
+\item \code{tinytable_format_sprintf}
+}
}
-\code{options(tinytable_quarto_disable_processing = TRUE)}
+\subsection{save_tt()}{
+\itemize{
+\item \code{tinytable_save_overwrite}
+}
+}
-Disable Quarto processing of cell content. Setting this global option to \code{FALSE} may lead to conflicts with some \code{tinytable} features, but it also allows use of markdown and Quarto-specific code in table cells, such as cross-references.
+\subsection{theme_tt()}{
-\if{html}{\out{
}}
-
-See this link for more details: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing
+Placement:
+\itemize{
+\item \code{tinytable_theme_placement_float}
+\item \code{tinytable_theme_placement_horizontal}
}
+Resize:
+\itemize{
+\item \code{tinytable_theme_resize_width}
+\item \code{tinytable_theme_resize_direction}
}
-\subsection{HTML}{
+Multipage:
\itemize{
-\item \code{options(tinytable_html_mathjax = TRUE)}
+\item \code{tinytable_theme_multipage_rowhead}
+\item \code{tinytable_theme_multipage_rowfoot}
+}
+
+Tabular:
\itemize{
-\item insert MathJax scripts in the HTML document. Warning: This may conflict with other elements of the page if MathJax is otherwise loaded.
+\item \code{tinytable_theme_tabular_style}
}
-\item \code{options(tinytable_html_portable = TRUE)}
+}
+
+\subsection{print.tinytable()}{
\itemize{
-\item \code{plot_tt()} inserts base 64 encoded images directly in the HTML file rather than use external links.
+\item \code{tinytable_print_output}
}
}
+
}
-\subsection{PDF}{
+\subsection{Output-specific options}{
+\subsection{HTML}{
\itemize{
-\item \code{options(tinytable_pdf_clean = TRUE)}
+\item \code{tinytable_html_mathjax}: Insert MathJax scripts (warning: may conflict if MathJax is loaded elsewhere)
+\item \code{tinytable_html_portable}: Insert base64 encoded images directly in HTML for \code{plot_tt()}
+}
+}
+
+\subsection{PDF}{
\itemize{
-\item deletes temporary and log files.
+\item \code{tinytable_pdf_clean}: Delete temporary and log files
+\item \code{tinytable_pdf_engine}: Choose between "xelatex", "pdflatex", "lualatex"
+}
+}
+
+\subsection{Quarto}{
+
+The \code{format_tt(quarto=TRUE)} argument enables Quarto data processing with some limitations:
+\enumerate{
+\item The \verb{\\QuartoMarkdownBase64\{\}} LaTeX macro may not process references and markdown as expected
+\item Quarto processing may conflict with \code{tinytable} styling/formatting
}
-\item \code{options(tinytable_pdf_engine = "xelatex")}
+
+Options:
\itemize{
-\item "xelatex", "pdflatex", "lualatex"
+\item \code{tinytable_quarto_disable_processing}: Disable Quarto cell processing
+\item \code{tinytable_print_rstudio_notebook}: Display tables "inline" or in "viewer" for RStudio notebooks
+\item \code{tinytable_quarto_figure}: Control Typst figure environment in Quarto
}
+
+Example of Quarto-specific code in cells:
+
+\if{html}{\out{
