diff --git a/R/theme_bootstrap.R b/R/theme_bootstrap.R new file mode 100644 index 00000000..a8ede25b --- /dev/null +++ b/R/theme_bootstrap.R @@ -0,0 +1,17 @@ +theme_bootstrap <- function(x, ...) { + 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) + } + x <- theme_tt(x, theme = "void") # only affects LaTeX + x <- style_tt(x, tabularray_inner = "hlines={gray8},", finalize = fn) + return(x) +} diff --git a/R/theme_default.R b/R/theme_default.R new file mode 100644 index 00000000..e520dfa0 --- /dev/null +++ b/R/theme_default.R @@ -0,0 +1,17 @@ +theme_default <- function(x, ...) { + if (isTRUE(x@output %in% c("html", "typst"))) { + x <- style_tt(x, + bootstrap_class = "table table-borderless", + i = nrow(x), + line = "b", + line_color = "#d3d8dc", + line_width = 0.1) + x <- style_tt(x, + bootstrap_class = "table table-borderless", + i = 0, + line = "bt", + line_color = "#d3d8dc", + line_width = 0.1) + } + return(x) +} diff --git a/R/theme_grid.R b/R/theme_grid.R new file mode 100644 index 00000000..89076c26 --- /dev/null +++ b/R/theme_grid.R @@ -0,0 +1,20 @@ +theme_grid <- function(x, ...) { + fn <- function(table) { + if (isTRUE(table@output == "latex")) { + s <- table@table_string + s <- lines_drop(s, regex = "\\\\bottomrule", position = "equal") + s <- lines_drop(s, regex = "\\\\midrule", position = "equal") + s <- lines_drop(s, regex = "\\\\toprule", position = "equal") + table@table_string <- s + } 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) +} diff --git a/R/theme_multipage.R b/R/theme_multipage.R new file mode 100644 index 00000000..9a46c05b --- /dev/null +++ b/R/theme_multipage.R @@ -0,0 +1,41 @@ +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") + + table@table_string <- tab + + table <- style_tt(table, tabularray_outer = cap) + + if (rowhead > 0) { + table <- style_tt(table, tabularray_inner = sprintf("rowhead=%s", rowhead)) + } + + 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 new file mode 100644 index 00000000..419889c3 --- /dev/null +++ b/R/theme_placement.R @@ -0,0 +1,30 @@ +# Don't do much in here +theme_placement <- function(x, + horizontal = get_option("tinytable_theme_placement_horizontal", default = NULL), + latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)) { + # do not change the defaul theme + if (identical(x@theme[[1]], "placement")) x@theme <- list("default") + fn <- function(table) { + tab <- table@table_string + if (table@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 (table@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) + } + } + table@table_string <- tab + return(table) + } + x <- style_tt(x, finalize = fn) + return(x) +} + + diff --git a/R/theme_resize.R b/R/theme_resize.R new file mode 100644 index 00000000..464c3de0 --- /dev/null +++ b/R/theme_resize.R @@ -0,0 +1,38 @@ +theme_resize <- function(x, + width = get_option("tinytable_theme_resize_width", 1), + direction = get_option("tinytable_theme_resize_direction", "down"), + ...) { + 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 + + 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") + + new <- "}" + reg <- "\\\\end\\{tblr\\}|\\\\end\\{talltblr\\}" + tab <- lines_insert(tab, regex = reg, new = new, position = "after") + + table@table_string <- tab + + return(table) + } + + x <- style_tt(x, finalize = fn) + return(x) +} + + diff --git a/R/theme_rotate.R b/R/theme_rotate.R new file mode 100644 index 00000000..d04ca483 --- /dev/null +++ b/R/theme_rotate.R @@ -0,0 +1,35 @@ +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) + } + x <- style_tt(x, finalize = fn) + return(x) +} + diff --git a/R/theme_striped.R b/R/theme_striped.R new file mode 100644 index 00000000..f0bdea5b --- /dev/null +++ b/R/theme_striped.R @@ -0,0 +1,25 @@ +theme_striped <- function(x, ...) { + 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") + + # 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 new file mode 100644 index 00000000..5e7442fb --- /dev/null +++ b/R/theme_tabular.R @@ -0,0 +1,55 @@ +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 = "\\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") - - new <- "}" - reg <- "\\\\end\\{tblr\\}|\\\\end\\{talltblr\\}" - tab <- lines_insert(tab, regex = reg, new = new, position = "after") - - table@table_string <- tab - - return(table) - } - - x <- style_tt(x, finalize = fn) - return(x) -} - - -theme_void <- function(x, ...) { - assert_class(x, "tinytable") - fn <- function(table) { - if (isTRUE(table@output == "latex")) { - s <- table@table_string - s <- gsub("\\\\toprule|\\\\bottomrule|\\\\midrule", "", s) - l <- strsplit(s, "\n")[[1]] - l <- l[which(trimws(l) != "")] - table@table_string <- paste(l, collapse = "\n") - } else if (isTRUE(table@output == "markdown")) { - tab <- table@table_string - tab <- strsplit(tab, "\n")[[1]] - tab <- tab[!grepl("^[\\+|-]+$", tab)] - tab <- tab[!grepl("^[\\+|=]+$", tab)] - tab <- gsub("|", " ", tab, fixed = TRUE) - table@table_string <- paste(tab, collapse = "\n") - } else if (isTRUE(table@output == "typst")) { - tab <- table@table_string - tab <- lines_drop(tab, regex = "table.hline", position = "all", fixed = TRUE) - table@table_string <- tab - } - return(table) - } - x <- style_tt(x, finalize = fn, - bootstrap_class = "table table-borderless") - return(x) -} - - -theme_grid <- function(x, ...) { - assert_class(x, "tinytable") - fn <- function(table) { - if (isTRUE(table@output == "latex")) { - s <- table@table_string - s <- lines_drop(s, regex = "\\\\bottomrule", position = "equal") - s <- lines_drop(s, regex = "\\\\midrule", position = "equal") - s <- lines_drop(s, regex = "\\\\toprule", position = "equal") - table@table_string <- s - } 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) -} - - -theme_striped <- function(x, ...) { - assert_class(x, "tinytable") - 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 <- theme_tt(x, "default") - return(x) -} - - -theme_bootstrap <- function(x, ...) { - assert_class(x, "tinytable") - 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) - } - x <- theme_tt(x, theme = "void") # only affects LaTeX - x <- style_tt(x, tabularray_inner = "hlines={gray8},", finalize = fn) - return(x) -} - - -theme_placement <- function(x, - horizontal = get_option("tinytable_theme_placement_horizontal", default = NULL), - latex_float = get_option("tinytable_theme_placement_latex_float", default = NULL)) { - # do not change the defaul theme - if (identical(x@theme[[1]], "placement")) x@theme <- list("default") - fn <- function(table) { - tab <- table@table_string - if (table@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 (table@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) - } - } - table@table_string <- tab - return(table) - } - x <- style_tt(x, finalize = fn) - return(x) -} - - -theme_multipage <- function(x, - rowhead = get_option("tinytable_theme_multipage_rowhead", 0L), - rowfoot = get_option("tinytable_theme_multipage_rowfoot", 0L), - ...) { - assert_class(x, "tinytable") - # 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") - - table@table_string <- tab - - table <- style_tt(table, tabularray_outer = cap) - - if (rowhead > 0) { - table <- style_tt(table, tabularray_inner = sprintf("rowhead=%s", rowhead)) - } - - if (rowfoot > 0) { - table <- style_tt(table, tabularray_inner = sprintf("rowfoot=%s", rowfoot)) - } - - return(table) - } - x <- style_tt(x, finalize = fn) - return(x) -} - - -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) - } - x <- style_tt(x, finalize = fn) - return(x) -} - - theme_dictionary <- list( "default" = theme_default, "grid" = theme_grid, @@ -397,6 +89,7 @@ theme_dictionary <- list( #' @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 diff --git a/R/theme_void.R b/R/theme_void.R new file mode 100644 index 00000000..56ad5fb7 --- /dev/null +++ b/R/theme_void.R @@ -0,0 +1,25 @@ +theme_void <- function(x, ...) { + fn <- function(table) { + if (isTRUE(table@output == "latex")) { + s <- table@table_string + s <- gsub("\\\\toprule|\\\\bottomrule|\\\\midrule", "", s) + l <- strsplit(s, "\n")[[1]] + l <- l[which(trimws(l) != "")] + table@table_string <- paste(l, collapse = "\n") + } else if (isTRUE(table@output == "markdown")) { + tab <- table@table_string + tab <- strsplit(tab, "\n")[[1]] + tab <- tab[!grepl("^[\\+|-]+$", tab)] + tab <- tab[!grepl("^[\\+|=]+$", tab)] + tab <- gsub("|", " ", tab, fixed = TRUE) + table@table_string <- paste(tab, collapse = "\n") + } else if (isTRUE(table@output == "typst")) { + tab <- table@table_string + tab <- lines_drop(tab, regex = "table.hline", position = "all", fixed = TRUE) + table@table_string <- tab + } + return(table) + } + x <- style_tt(x, finalize = fn, bootstrap_class = "table table-borderless") + return(x) +} diff --git a/R/tt.R b/R/tt.R index a90bf306..6cca2cf2 100644 --- a/R/tt.R +++ b/R/tt.R @@ -61,7 +61,7 @@ tt <- function(x, caption = get_option("tinytable_tt_caption", default = NULL), notes = get_option("tinytable_tt_notes", default = NULL), width = get_option("tinytable_tt_width", default = NULL), - theme = get_option("tinytable_tt_theme", default = NULL), + theme = get_option("tinytable_tt_theme", default = c("default", "placement")), rownames = get_option("tinytable_tt_rownames", default = FALSE), escape = get_option("tinytable_tt_escape", default = FALSE), ...) { @@ -133,7 +133,16 @@ tt <- function(x, out <- theme_tt(out, theme = "default") out <- theme_tt(out, theme = "placement") } else { - out <- theme_tt(out, theme = theme) + if (is.character(theme)) { + for (th in theme) { + out <- theme_tt(out, theme = th) + } + } else if (is.function(theme)) { + out <- theme_tt(out, theme = theme) + } else { + stop("The `theme` argument must be a string or function.") + } + } if ("placement" %in% names(dots)) { diff --git a/man/tt.Rd b/man/tt.Rd index 29b85ef8..0604cb31 100644 --- a/man/tt.Rd +++ b/man/tt.Rd @@ -10,7 +10,7 @@ tt( caption = get_option("tinytable_tt_caption", default = NULL), notes = get_option("tinytable_tt_notes", default = NULL), width = get_option("tinytable_tt_width", default = NULL), - theme = get_option("tinytable_tt_theme", default = NULL), + theme = get_option("tinytable_tt_theme", default = c("default", "placement")), rownames = get_option("tinytable_tt_rownames", default = FALSE), escape = get_option("tinytable_tt_escape", default = FALSE), ... diff --git a/vignettes/style.qmd b/vignettes/style.qmd index 85eda28b..a6aad608 100644 --- a/vignettes/style.qmd +++ b/vignettes/style.qmd @@ -300,7 +300,7 @@ bg <- hcl.colors(20, "Inferno") fg <- ifelse(as.matrix(k) < 1.7, tail(bg, 1), head(bg, 1)) # table -tt(k, width = .7, theme = "void") |> +tt(k, width = .7, theme = c("void", "placement")) |> style_tt(j = 1:5, align = "ccccc") |> style_tt( i = 1:4, diff --git a/vignettes/theme.qmd b/vignettes/theme.qmd index cce737b1..e9b6702e 100644 --- a/vignettes/theme.qmd +++ b/vignettes/theme.qmd @@ -30,22 +30,22 @@ x <- mtcars[1:4, 1:5] To begin, let's explore a few of the basic looks supplied by themes: ```{r} -tt(x, theme = "striped") +tt(x, theme = c("striped", "placement")) tt(x) |> theme_tt("striped") ``` ```{r} -tt(x, theme = "grid") +tt(x, theme = c("grid", "placement")) ``` ```{r} -tt(x, theme = "bootstrap") +tt(x, theme = c("bootstrap", "placement")) ``` ::: {.content-visible when-format="pdf"} ```{r} -tt(x, theme = "void") +tt(x, theme = c("void", "placement")) ``` ::: @@ -57,8 +57,7 @@ Users can also define their own themes to apply consistent visual tweaks to tabl ```{r} theme_vincent <- function(x, ...) { out <- x |> - style_tt(color = "teal") |> - theme_tt("placement") + style_tt(color = "teal") out@caption <- "Always use the same caption." out@width <- .5 return(out)