From 84e590c92e87c9270e4fd26d498bb00508b05020 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sat, 7 Dec 2024 14:40:53 -0500 Subject: [PATCH 01/12] issue #401 style_tt("notes", italic = TRUE) --- DESCRIPTION | 6 +- NEWS.md | 14 ++-- R/build_tt.R | 189 ++++++++++++++++++++++--------------------- R/class.R | 195 +++++++++++++++++++++++--------------------- R/sanity.R | 4 + R/style_notes.R | 71 ++++++++++++++++ R/style_tt.R | 209 ++++++++++++++++++++++++------------------------ R/tt_typst.R | 156 ++++++++++++++++++------------------ 8 files changed, 470 insertions(+), 374 deletions(-) create mode 100644 R/style_notes.R diff --git a/DESCRIPTION b/DESCRIPTION index 288b618b..eb6b295a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: tinytable Type: Package Title: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats Description: Create highly customized tables with this simple and dependency-free package. Data frames can be converted to 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', or 'Typst' tables. The user interface is minimalist and easy to learn. The syntax is concise. 'HTML' tables can be customized using the flexible 'Bootstrap' framework, and 'LaTeX' code with the 'tabularray' package. -Version: 0.6.1.1 +Version: 0.6.1.2 Imports: methods Depends: @@ -31,8 +31,8 @@ Suggests: URL: https://vincentarelbundock.github.io/tinytable/ BugReports: https://github.com/vincentarelbundock/tinytable/issues Authors@R: c( - person("Vincent", "Arel-Bundock", - email = "vincent.arel-bundock@umontreal.ca", + person("Vincent", "Arel-Bundock", + email = "vincent.arel-bundock@umontreal.ca", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-2042-7063"))) License: GPL (>= 3) diff --git a/NEWS.md b/NEWS.md index e1e74754..11bcee4e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,10 @@ Bugs: * `save_tt("file.pdf")` works with colors. Thanks to @olivedv for the report and solution #395. +New: + +* `style_tt("notes")` can style footnotes. + Misc: * Documentation improvements @@ -92,7 +96,7 @@ MathJax = { * `format_tt(num_big_mark)` applies to integer columns. * Use `getOption("viewer")` instead of `rstudioapi::viewer()` for positron support * `glue::glue()` string is accepted by `format_tt()`. Thanks to @LukasWallrich for report #792 on the `modelsummary` repository. -* Support Github Flavored Markdown (`gfm`) output. Thanks to @kylebutts for contribution #315. +* Support Github Flavored Markdown (`gfm`) output. Thanks to @kylebutts for contribution #315. * `theme_tt("rotate")` to rotate tables in LaTeX or Typst. * `save_tt("/path/to/file")` returns the file path invisibly. Thanks to @yjunechoe for issue #328. @@ -197,7 +201,7 @@ New features: * `rbind()` and `rbind2()` can be used to stack `tinytable` objects. `rbind2()` is more flexible than `rbind()`. See `?tinytable::rbind2` * New output format in `print()`: "dataframe" -* Rename table headers: `colnames(tab) <- c("a", "b", "c")` +* Rename table headers: `colnames(tab) <- c("a", "b", "c")` * `theme_tt("resize")` gets a `direction` argument with "up", "down", "both" options. Thanks to @MarcoPortmann for feature request #207 Minor: @@ -216,7 +220,7 @@ New function `theme_tt()`: * Function to apply collections of transformations to a `tinytable`. * Visual themes: - - grid, void, striped, bootstrap, default + - grid, void, striped, bootstrap, default * `resize`: Insert a LaTeX table in a `resizebox` environment to ensure a table fits the page, or to scale it to a fraction of `\linewidth` * `placement`: Determine where a LaTeX table float is positioned. Ex: `[H]`, `[htbp]` * `multipage`: Split long LaTeX tables across multiple pages with (optional) repeated headers/footers. Uses the `longtblr` environment from `tabularray`. @@ -284,7 +288,7 @@ Bugfix: New: -- `Typst` tables are now supported using the `tablex` extension: +- `Typst` tables are now supported using the `tablex` extension: - https://typst.app/ - https://github.com/PgBiel/typst-tablex - `escape` argument in `format_tt()` escapes or substitutes special characters in LaTeX or HTML output to prevent compilation and rendering errors. @@ -315,7 +319,7 @@ Bug fixes: Documentation: -- Improved vignette on the package website. +- Improved vignette on the package website. - Various documentation updates. - Math in $$ is the new recommendation. diff --git a/R/build_tt.R b/R/build_tt.R index f3d18317..e773274a 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -4,106 +4,109 @@ # # THE ORDER MATTERS A LOT! build_tt <- function(x, output = NULL) { - output <- sanitize_output(output) - - - x <- switch(output, - html = swap_class(x, "tinytable_bootstrap"), - latex = swap_class(x, "tinytable_tabularray"), - markdown = swap_class(x, "tinytable_grid"), - gfm = swap_class(x, "tinytable_grid"), - typst = swap_class(x, "tinytable_typst"), - dataframe = swap_class(x, "tinytable_dataframe"), - ) - - x@output <- output - - for (th in x@lazy_theme) { - fn <- th[[1]] - args <- th[[2]] - args[["x"]] <- x - x <- do.call(fn, args) - } - - tab <- x@table_dataframe - - # strip ANSI from `tibble`/`pillar`; keep for markdown - if (isTRUE(check_dependency("fansi"))) { - for (col in seq_along(tab)) { - if (isTRUE(x@output == "html")) { - tab[[col]] <- as.character(fansi::to_html(tab[[col]], warn = FALSE)) - } else if (isTRUE(!x@output %in% c("markdown", "dataframe"))) { - tab[[col]] <- as.character(fansi::strip_ctl(tab[[col]])) - } + output <- sanitize_output(output) + + + x <- switch(output, + html = swap_class(x, "tinytable_bootstrap"), + latex = swap_class(x, "tinytable_tabularray"), + markdown = swap_class(x, "tinytable_grid"), + gfm = swap_class(x, "tinytable_grid"), + typst = swap_class(x, "tinytable_typst"), + dataframe = swap_class(x, "tinytable_dataframe"), + ) + + x@output <- output + + # apply the style_notes + x <- style_notes(x) + + for (th in x@lazy_theme) { + fn <- th[[1]] + args <- th[[2]] + args[["x"]] <- x + x <- do.call(fn, args) } - } - x@table_dataframe <- tab - - # format data before drawing the table - for (l in x@lazy_format) { - l[["x"]] <- x - x <- eval(l) - } - - # add footnote markers just after formatting, otherwise appending converts to string - x <- footnote_markers(x) - - # plots and images - for (l in x@lazy_plot) { - l[["x"]] <- x - x <- eval(l) - } - - # data frame we trim strings, pre-padded for markdown - if (x@output == "dataframe") { - tmp <- x@table_dataframe - for (i in seq_along(tmp)) { - tmp[[i]] <- trimws(tmp[[i]]) + + tab <- x@table_dataframe + + # strip ANSI from `tibble`/`pillar`; keep for markdown + if (isTRUE(check_dependency("fansi"))) { + for (col in seq_along(tab)) { + if (isTRUE(x@output == "html")) { + tab[[col]] <- as.character(fansi::to_html(tab[[col]], warn = FALSE)) + } else if (isTRUE(!x@output %in% c("markdown", "dataframe"))) { + tab[[col]] <- as.character(fansi::strip_ctl(tab[[col]])) + } + } } - x@table_dataframe <- tmp - } - - # markdown styles need to be applied before creating the table, otherwise there's annoying parsing, etc. - if (x@output %in% c("markdown", "gfm", "dataframe")) { - x <- style_eval(x) - } - - # draw the table - x <- tt_eval(x) - - ihead <- 0 - for (idx in seq_along(x@lazy_group)) { - l <- x@lazy_group[[idx]] - l[["x"]] <- x - if (length(l[["j"]]) > 0) { - ihead <- ihead - 1 - l[["ihead"]] <- ihead + x@table_dataframe <- tab + + # format data before drawing the table + for (l in x@lazy_format) { + l[["x"]] <- x + x <- eval(l) } - x <- eval(l) - } - - if (!x@output %in% c("markdown", "gfm", "dataframe")) { - for (l in x@lazy_style) { - l[["x"]] <- x - # output-specific styling - if (is.null(l$output) || isTRUE(x@output == l$output)) { + + # add footnote markers just after formatting, otherwise appending converts to string + x <- footnote_markers(x) + + # plots and images + for (l in x@lazy_plot) { + l[["x"]] <- x x <- eval(l) - } } - } - # markdown styles are applied earlier - if (!x@output %in% c("markdown", "gfm", "dataframe")) { - x <- style_eval(x) - } + # data frame we trim strings, pre-padded for markdown + if (x@output == "dataframe") { + tmp <- x@table_dataframe + for (i in seq_along(tmp)) { + tmp[[i]] <- trimws(tmp[[i]]) + } + x@table_dataframe <- tmp + } - x <- finalize(x) + # markdown styles need to be applied before creating the table, otherwise there's annoying parsing, etc. + if (x@output %in% c("markdown", "gfm", "dataframe")) { + x <- style_eval(x) + } + + # draw the table + x <- tt_eval(x) + + ihead <- 0 + for (idx in seq_along(x@lazy_group)) { + l <- x@lazy_group[[idx]] + l[["x"]] <- x + if (length(l[["j"]]) > 0) { + ihead <- ihead - 1 + l[["ihead"]] <- ihead + } + x <- eval(l) + } + + if (!x@output %in% c("markdown", "gfm", "dataframe")) { + for (l in x@lazy_style) { + l[["x"]] <- x + # output-specific styling + if (is.null(l$output) || isTRUE(x@output == l$output)) { + x <- eval(l) + } + } + } + + # markdown styles are applied earlier + if (!x@output %in% c("markdown", "gfm", "dataframe")) { + x <- style_eval(x) + } - x@table_string <- lines_drop_consecutive_empty(x@table_string) - if (output == "gfm") { - assert_dependency("pandoc") - x@table_string <- paste(pandoc::pandoc_convert(text = x@table_string, to = "gfm"), collapse = "\n") - } + x <- finalize(x) + + x@table_string <- lines_drop_consecutive_empty(x@table_string) + if (output == "gfm") { + assert_dependency("pandoc") + x@table_string <- paste(pandoc::pandoc_convert(text = x@table_string, to = "gfm"), collapse = "\n") + } - return(x) + return(x) } diff --git a/R/class.R b/R/class.R index b314214d..d0a9ed91 100644 --- a/R/class.R +++ b/R/class.R @@ -1,21 +1,21 @@ swap_class <- function(x, new_class) { - out <- methods::new(new_class) - for (s in methods::slotNames(x)) { - # modelsummary issue #727 - tmp <- methods::slot(x, s) - if (inherits(tmp, "data.table")) { - assert_dependency("data.table") - data.table::setDT(tmp) + out <- methods::new(new_class) + for (s in methods::slotNames(x)) { + # modelsummary issue #727 + tmp <- methods::slot(x, s) + if (inherits(tmp, "data.table")) { + assert_dependency("data.table") + data.table::setDT(tmp) + } + methods::slot(out, s) <- tmp } - methods::slot(out, s) <- tmp - } - return(out) + return(out) } setClassUnion("NULLorCharacter", c("NULL", "character")) #' tinytable S4 class -#' +#' #' @keywords internal #' @export setClass( @@ -45,6 +45,7 @@ setClass( bootstrap_css_rule = "character", css = "data.frame", style = "data.frame", + style_notes = "list", lazy_format = "list", lazy_group = "list", lazy_style = "list", @@ -52,11 +53,11 @@ setClass( lazy_finalize = "list", lazy_theme = "list", portable = "logical" - ) + ) ) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal setMethod("initialize", "tinytable", function( @@ -68,116 +69,126 @@ setMethod("initialize", "tinytable", function( theme = list("default"), placement = NULL, width = NULL) { - # explicit - .Object@data <- data - .Object@table_dataframe <- table - .Object@theme <- theme - # dynamic - .Object@nrow <- nrow(.Object@data) - .Object@ncol <- ncol(.Object@data) - .Object@nhead <- if (is.null(colnames(data))) 0 else 1 - .Object@ngroupi <- 0 - .Object@ngroupj <- 0 - .Object@names <- if (is.null(colnames(data))) character() else colnames(data) - .Object@id <- get_id("tinytable_") - .Object@output <- "tinytable" - .Object@output_dir <- getwd() - .Object@css <- data.frame(i = NA, j = NA, bootstrap = NA, id = NA) - .Object@portable <- FALSE - .Object@style <- data.frame() - .Object@lazy_theme <- list() - # conditional: allows NULL user input - if (!is.null(placement)) .Object@placement <- placement - if (!is.null(caption)) .Object@caption <- caption - if (!is.null(width)) .Object@width <- width - if (!is.null(notes)) .Object@notes <- notes - return(.Object) + # explicit + .Object@data <- data + .Object@table_dataframe <- table + .Object@theme <- theme + # dynamic + .Object@nrow <- nrow(.Object@data) + .Object@ncol <- ncol(.Object@data) + .Object@nhead <- if (is.null(colnames(data))) 0 else 1 + .Object@ngroupi <- 0 + .Object@ngroupj <- 0 + .Object@names <- if (is.null(colnames(data))) character() else colnames(data) + .Object@id <- get_id("tinytable_") + .Object@output <- "tinytable" + .Object@output_dir <- getwd() + .Object@css <- data.frame(i = NA, j = NA, bootstrap = NA, id = NA) + .Object@portable <- FALSE + .Object@style <- data.frame() + .Object@lazy_theme <- list() + # conditional: allows NULL user input + if (!is.null(placement)) .Object@placement <- placement + if (!is.null(caption)) .Object@caption <- caption + if (!is.null(width)) .Object@width <- width + if (!is.null(notes)) .Object@notes <- notes + return(.Object) }) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal -setMethod("nrow", "tinytable", function(x) return(x@nrow)) +setMethod("nrow", "tinytable", function(x) { + return(x@nrow) +}) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal -setMethod("ncol", "tinytable", function(x) return(x@ncol)) +setMethod("ncol", "tinytable", function(x) { + return(x@ncol) +}) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal #' @export -setMethod("colnames", "tinytable", function(x) return(x@names)) +setMethod("colnames", "tinytable", function(x) { + return(x@names) +}) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal #' @export -setMethod("names", "tinytable", function(x) return(x@names)) +setMethod("names", "tinytable", function(x) { + return(x@names) +}) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal #' @export setReplaceMethod("colnames", - signature = "tinytable", - definition = function(x, value) { - # Issue #306 - if (length(value) == 0) value <- NULL - if (!is.null(value)) { - assert_character(value, len = length(x@names)) - } else { - if (x@nhead == 1) x@nhead <- 0 - } - x@names <- value - return(x) - } -) + signature = "tinytable", + definition = function(x, value) { + # Issue #306 + if (length(value) == 0) value <- NULL + if (!is.null(value)) { + assert_character(value, len = length(x@names)) + } else { + if (x@nhead == 1) x@nhead <- 0 + } + x@names <- value + return(x) + }) #' Method for a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal #' @export setReplaceMethod("names", - signature = "tinytable", - definition = function(x, value) { - # Issue #306 - if (length(value) == 0) value <- NULL - if (!is.null(value)) { - assert_character(value, len = length(x@names)) - } else { - if (x@nhead == 1) x@nhead <- 0 - } - x@names <- value - return(x) - } -) + signature = "tinytable", + definition = function(x, value) { + # Issue #306 + if (length(value) == 0) value <- NULL + if (!is.null(value)) { + assert_character(value, len = length(x@names)) + } else { + if (x@nhead == 1) x@nhead <- 0 + } + x@names <- value + return(x) + }) #' Dimensions a tinytable S4 object -#' +#' #' @inheritParams tt #' @keywords internal -setMethod("dim", "tinytable", function(x) return(c(x@nrow, x@ncol))) +setMethod("dim", "tinytable", function(x) { + return(c(x@nrow, x@ncol)) +}) #' Column names of a tinytable -#' +#' #' @inheritParams tt #' @keywords internal -setMethod("names", "tinytable", function(x) return(x@names)) +setMethod("names", "tinytable", function(x) { + return(x@names) +}) #' Convert a tinytable S4 object to a string -#' +#' #' @inheritParams tt #' @keywords internal setMethod("as.character", "tinytable", function(x) { - out <- save_tt(x, x@output) + out <- save_tt(x, x@output) }) @@ -188,39 +199,37 @@ setClass("tinytable_grid", contains = "tinytable") setClass("tinytable_dataframe", contains = "tinytable") #' Apply style settings to a tinytable -#' +#' #' @inheritParams tt #' @keywords internal setGeneric( - name = "style_eval", - def = function(x, ...) standardGeneric("style_eval") + name = "style_eval", + def = function(x, ...) standardGeneric("style_eval") ) #' Apply group settings to a tinytable -#' +#' #' @inheritParams tt #' @keywords internal setGeneric( - name = "tt_eval", - def = function(x, ...) standardGeneric("tt_eval") + name = "tt_eval", + def = function(x, ...) standardGeneric("tt_eval") ) #' Apply group settings to a tinytable -#' +#' #' @inheritParams tt #' @keywords internal setGeneric( - name = "group_eval", - def = function(x, ...) standardGeneric("group_eval") + name = "group_eval", + def = function(x, ...) standardGeneric("group_eval") ) #' Apply final settings to a tinytable -#' +#' #' @inheritParams tt #' @keywords internal setGeneric( - name = "finalize", - def = function(x, ...) standardGeneric("finalize") + name = "finalize", + def = function(x, ...) standardGeneric("finalize") ) - - diff --git a/R/sanity.R b/R/sanity.R index cf267bb4..6c2966d5 100644 --- a/R/sanity.R +++ b/R/sanity.R @@ -13,7 +13,11 @@ sanity_align <- function(align, i) { sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) { + if (identical(i, "notes")) { + 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 diff --git a/R/style_notes.R b/R/style_notes.R new file mode 100644 index 00000000..d5387576 --- /dev/null +++ b/R/style_notes.R @@ -0,0 +1,71 @@ +setGeneric( + name = "style_notes", + def = function(x, ...) standardGeneric("style_notes") +) + +# default method +setMethod( + f = "style_notes", + signature = "ANY", + definition = function(x, ...) { + return(x) + }) + + +# HTML: bootstrap +setMethod( + f = "style_notes", + signature = "tinytable_bootstrap", + definition = function(x, ...) { + styles <- x@style_notes + if (isTRUE(styles[["italic"]])) { + x@notes <- lapply(x@notes, function(n) sprintf("%s", n)) + } + if (isTRUE(styles[["bold"]])) { + x@notes <- lapply(x@notes, function(n) sprintf("%s", n)) + } + return(x) + }) + + +# LaTeX: tabularray +setMethod( + f = "style_notes", + signature = "tinytable_tabularray", + definition = function(x, ...) { + styles <- x@style_notes + if (isTRUE(styles[["italic"]])) { + x@notes <- lapply(x@notes, function(n) sprintf("\\emph{%s}", n)) + } + if (isTRUE(styles[["bold"]])) { + x@notes <- lapply(x@notes, function(n) sprintf("\\textbf{%s}", n)) + } + return(x) + }) + + +# LaTeX: tabularray +setMethod( + f = "style_notes", + signature = "tinytable_typst", + definition = function(x, ...) { + styles <- x@style_notes + + if (length(x@notes) == 0) { + return(x) + } + + sty <- NULL + if (isTRUE(styles[["italic"]])) { + sty <- c(sty, 'style: "italic"') + } + + if (isTRUE(styles[["bold"]])) { + sty <- c(sty, 'weight: "bold"') + } + + template <- paste0("text(", paste(sty, collapse = ", "), ", [%s])") + x@notes <- lapply(x@notes, function(k) sprintf(template, k)) + + return(x) + }) diff --git a/R/style_tt.R b/R/style_tt.R index 742c4d00..69c8784b 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -10,7 +10,7 @@ #' @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 +24,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 +32,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,69 +41,69 @@ #' @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. #' @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]) |> -#' style_tt(j = 1:5, align = "lcccr") -#' +#' tt(mtcars[1:5, 1:6]) |> +#' style_tt(j = 1:5, align = "lcccr") +#' #' # Colors and styles -#' tt(mtcars[1:5, 1:6]) |> -#' style_tt(i = 2:3, background = "black", color = "orange", bold = TRUE) -#' +#' 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]) |> -#' style_tt(j = 5:6, background = "pink") -#' #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(j = "drat|wt", background = "pink") -#' +#' 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") +#' style_tt(j = c("drat", "wt"), background = "pink") #' #' tt(mtcars[1:5, 1:6], theme = "void") |> -#' style_tt( -#' i = 2, j = 2, -#' colspan = 3, -#' rowspan = 2, -#' align="c", -#' alignv = "m", -#' color = "white", -#' background = "black", -#' bold = TRUE) -#' +#' style_tt( +#' i = 2, j = 2, +#' colspan = 3, +#' rowspan = 2, +#' 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") -#' +#' style_tt( +#' 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) -#' +#' 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") +#' style_tt(bootstrap_class = "table table-dark table-hover") #' #' #' inner <- " @@ -117,36 +117,35 @@ #' cell{2}{2} = {r=4,c=2}{bg=azure7}, #' " #' tt(mtcars[1:5, 1:4], theme = "void") |> -#' style_tt(tabularray_inner = inner) +#' 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 assert_choice(alignv, c("t", "m", "b"), null.ok = TRUE) @@ -159,6 +158,13 @@ style_tt <- function (x, tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer, bootstrap_css = bootstrap_css, bootstrap_css_rule = bootstrap_css_rule) + if (identical(i, "notes")) { + out@style_notes <- list( + italic = italic, + bold = bold + ) + return(out) + } if (!is.null(bootstrap_class)) { out@bootstrap_class <- bootstrap_class @@ -266,30 +272,29 @@ style_tt <- function (x, -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) @@ -332,7 +337,7 @@ assert_style_tt <- function (x, assert_length(underline, len = 1) assert_length(strikeout, len = 1) - # 1 or #rows + # 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) @@ -343,7 +348,7 @@ assert_style_tt <- function (x, assert_length(underline, len = c(1, length(ival))) assert_length(strikeout, len = c(1, length(ival))) - # 1 or #cols + # 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) @@ -354,7 +359,7 @@ assert_style_tt <- function (x, assert_length(underline, len = c(1, length(jval))) assert_length(strikeout, len = c(1, length(jval))) - # 1 or #cells + # 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) @@ -366,5 +371,3 @@ assert_style_tt <- function (x, assert_length(strikeout, len = c(1, length(ival) * length(jval))) } } - - diff --git a/R/tt_typst.R b/R/tt_typst.R index 1cd347c9..8b9e61da 100644 --- a/R/tt_typst.R +++ b/R/tt_typst.R @@ -1,96 +1,98 @@ setMethod( - f = "tt_eval", - signature = "tinytable_typst", - definition = function(x, ...) { - out <- readLines(system.file("templates/typst.typ", package = "tinytable")) - out <- paste(out, collapse = "\n") + f = "tt_eval", + signature = "tinytable_typst", + definition = function(x, ...) { + 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]) - } else { - tmp <- sprintf(" table.cell(align: left, colspan: %s, [#super[%s] %s]),", ncol(x), lab[k], notes[k]) - } - out <- lines_insert(out, tmp, "tinytable notes after", "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]) + } else { + tmp <- sprintf(" table.cell(align: left, colspan: %s, [#super[%s] %s]),", ncol(x), lab[k], notes[k]) + } + 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" - ) - idx <- grep(comment, out) + out <- strsplit(x, "\n")[[1]] + comment <- switch(type, + "lines" = "tinytable lines before", + "style" = "tinytable cell style before", + "body" = "tinytable cell content after" + ) + idx <- grep(comment, out) - if (type == "body") { - out <- c(out[1:idx], content, out[(idx + 1):length(out)]) - } else { - out <- c(out[1:(idx - 1)], content, out[idx:length(out)]) - } + if (type == "body") { + out <- c(out[1:idx], content, out[(idx + 1):length(out)]) + } else { + out <- c(out[1:(idx - 1)], content, out[idx:length(out)]) + } - out <- paste(out, collapse = "\n") - return(out) + out <- paste(out, collapse = "\n") + return(out) } From 478c2fc6e55e0d3180394349ae1fa36aa54428a0 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 8 Dec 2024 09:14:40 -0500 Subject: [PATCH 02/12] more style_notes --- R/style_notes.R | 41 +++++++++++++++++++++++++++------------ R/style_string.R | 50 ++++++++++++++++++++++++++++++++++++++++++++++++ R/style_tt.R | 6 +++++- 3 files changed, 84 insertions(+), 13 deletions(-) create mode 100644 R/style_string.R diff --git a/R/style_notes.R b/R/style_notes.R index d5387576..a338d494 100644 --- a/R/style_notes.R +++ b/R/style_notes.R @@ -18,12 +18,7 @@ setMethod( signature = "tinytable_bootstrap", definition = function(x, ...) { styles <- x@style_notes - if (isTRUE(styles[["italic"]])) { - x@notes <- lapply(x@notes, function(n) sprintf("%s", n)) - } - if (isTRUE(styles[["bold"]])) { - x@notes <- lapply(x@notes, function(n) sprintf("%s", n)) - } + x@notes <- lapply(x@notes, style_string_html, styles) return(x) }) @@ -34,12 +29,7 @@ setMethod( signature = "tinytable_tabularray", definition = function(x, ...) { styles <- x@style_notes - if (isTRUE(styles[["italic"]])) { - x@notes <- lapply(x@notes, function(n) sprintf("\\emph{%s}", n)) - } - if (isTRUE(styles[["bold"]])) { - x@notes <- lapply(x@notes, function(n) sprintf("\\textbf{%s}", n)) - } + x@notes <- lapply(x@notes, style_string_html, styles) return(x) }) @@ -69,3 +59,30 @@ setMethod( return(x) }) + + + +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 +} diff --git a/R/style_string.R b/R/style_string.R new file mode 100644 index 00000000..61bef358 --- /dev/null +++ b/R/style_string.R @@ -0,0 +1,50 @@ +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{%s}{%s}\\selectfont %s}", styles[["fontsize"]], styles[["fontsize"]], n) + } + n +} diff --git a/R/style_tt.R b/R/style_tt.R index 69c8784b..4c47d88a 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -160,8 +160,12 @@ style_tt <- function(x, if (identical(i, "notes")) { out@style_notes <- list( + color = color, + fontsize = fontsize, italic = italic, - bold = bold + monospace = monospace, + strikeout = strikeout, + underline = underline ) return(out) } From b5aae2e0ed65f97ab6b3094433b6dd8c437429f4 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 8 Dec 2024 09:49:44 -0500 Subject: [PATCH 03/12] more typst styles --- R/style_notes.R | 49 +++--------------------------------------------- R/style_string.R | 32 ++++++++++++++++++++++++++++++- 2 files changed, 34 insertions(+), 47 deletions(-) diff --git a/R/style_notes.R b/R/style_notes.R index a338d494..9d05568e 100644 --- a/R/style_notes.R +++ b/R/style_notes.R @@ -29,60 +29,17 @@ setMethod( signature = "tinytable_tabularray", definition = function(x, ...) { styles <- x@style_notes - x@notes <- lapply(x@notes, style_string_html, styles) + x@notes <- lapply(x@notes, style_string_latex, styles) return(x) }) -# LaTeX: tabularray +# Typst setMethod( f = "style_notes", signature = "tinytable_typst", definition = function(x, ...) { styles <- x@style_notes - - if (length(x@notes) == 0) { - return(x) - } - - sty <- NULL - if (isTRUE(styles[["italic"]])) { - sty <- c(sty, 'style: "italic"') - } - - if (isTRUE(styles[["bold"]])) { - sty <- c(sty, 'weight: "bold"') - } - - template <- paste0("text(", paste(sty, collapse = ", "), ", [%s])") - x@notes <- lapply(x@notes, function(k) sprintf(template, k)) - + x@notes <- lapply(x@notes, style_string_typst, styles) return(x) }) - - - -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 -} diff --git a/R/style_string.R b/R/style_string.R index 61bef358..0ee5bc79 100644 --- a/R/style_string.R +++ b/R/style_string.R @@ -44,7 +44,37 @@ style_string_latex <- function(n, styles) { n <- sprintf("\\textcolor{%s}{%s}", styles[["color"]], n) } if (!is.null(styles[["fontsize"]])) { - n <- sprintf("{\\fontsize{%s}{%s}\\selectfont %s}", styles[["fontsize"]], styles[["fontsize"]], n) + 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) + return(out) +} From eac3e9be6b5fa147e7ccb735ea559859a2f2a682 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 8 Dec 2024 13:37:59 -0500 Subject: [PATCH 04/12] typst footnote marks --- R/tt_typst.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/tt_typst.R b/R/tt_typst.R index 8b9e61da..48c604e8 100644 --- a/R/tt_typst.R +++ b/R/tt_typst.R @@ -52,8 +52,12 @@ setMethod( if (lab[k] == "") { tmp <- sprintf(" table.cell(align: left, colspan: %s, %s),", ncol(x), notes[k]) } else { - tmp <- sprintf(" table.cell(align: left, colspan: %s, [#super[%s] %s]),", ncol(x), lab[k], notes[k]) + 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") } } From 323bbbdaf25ea6a3d9073c2fa777a9dc3d0125e4 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sun, 8 Dec 2024 15:07:58 -0500 Subject: [PATCH 05/12] caption style start --- R/build_tt.R | 1 + R/class.R | 1 + R/sanity.R | 3 ++- R/style_notes.R | 45 --------------------------------------------- R/style_string.R | 40 ++++++++++++++++++++++++++++++++++++++++ R/style_tt.R | 6 ++++-- 6 files changed, 48 insertions(+), 48 deletions(-) diff --git a/R/build_tt.R b/R/build_tt.R index e773274a..435489ff 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -20,6 +20,7 @@ build_tt <- function(x, output = NULL) { # apply the style_notes x <- style_notes(x) + x <- style_caption(x) for (th in x@lazy_theme) { fn <- th[[1]] diff --git a/R/class.R b/R/class.R index d0a9ed91..99a09962 100644 --- a/R/class.R +++ b/R/class.R @@ -45,6 +45,7 @@ setClass( bootstrap_css_rule = "character", css = "data.frame", style = "data.frame", + style_caption = "list", style_notes = "list", lazy_format = "list", lazy_group = "list", diff --git a/R/sanity.R b/R/sanity.R index 6c2966d5..5f92d5a3 100644 --- a/R/sanity.R +++ b/R/sanity.R @@ -13,7 +13,8 @@ sanity_align <- function(align, i) { sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) { - if (identical(i, "notes")) { + if (is.character(i)) { + assert_choice(i, c("notes", "caption")) return(i) } out <- seq_len(nrow(x)) diff --git a/R/style_notes.R b/R/style_notes.R index 9d05568e..e69de29b 100644 --- a/R/style_notes.R +++ b/R/style_notes.R @@ -1,45 +0,0 @@ -setGeneric( - name = "style_notes", - def = function(x, ...) standardGeneric("style_notes") -) - -# default method -setMethod( - f = "style_notes", - signature = "ANY", - definition = function(x, ...) { - return(x) - }) - - -# HTML: bootstrap -setMethod( - f = "style_notes", - signature = "tinytable_bootstrap", - definition = function(x, ...) { - styles <- x@style_notes - x@notes <- lapply(x@notes, style_string_html, styles) - return(x) - }) - - -# LaTeX: tabularray -setMethod( - f = "style_notes", - signature = "tinytable_tabularray", - definition = function(x, ...) { - styles <- x@style_notes - x@notes <- lapply(x@notes, style_string_latex, styles) - return(x) - }) - - -# Typst -setMethod( - f = "style_notes", - signature = "tinytable_typst", - definition = function(x, ...) { - styles <- x@style_notes - x@notes <- lapply(x@notes, style_string_typst, styles) - return(x) - }) diff --git a/R/style_string.R b/R/style_string.R index 0ee5bc79..091b0a8e 100644 --- a/R/style_string.R +++ b/R/style_string.R @@ -78,3 +78,43 @@ style_string_typst <- function(n, styles) { out <- sprintf(template, n) 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_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_tt.R b/R/style_tt.R index 4c47d88a..3b68ae1c 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -158,8 +158,8 @@ style_tt <- function(x, tabularray_inner = tabularray_inner, tabularray_outer = tabularray_outer, bootstrap_css = bootstrap_css, bootstrap_css_rule = bootstrap_css_rule) - if (identical(i, "notes")) { - out@style_notes <- list( + if (isTRUE(i %in% c("notes", "caption"))) { + tmp <- list( color = color, fontsize = fontsize, italic = italic, @@ -167,6 +167,8 @@ style_tt <- function(x, strikeout = strikeout, underline = underline ) + if (identical(i, "notes")) out@style_notes <- tmp + if (identical(i, "caption")) out@style_caption <- tmp return(out) } From 9c4b0caa5ec96b5e655883205e46cd229017423b Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Thu, 12 Dec 2024 15:07:33 -0500 Subject: [PATCH 06/12] styler v2 --- R/build_tt.R | 194 +++++----- R/class.R | 220 +++++------ R/escape.R | 135 +++---- R/finalize_bootstrap.R | 128 +++---- R/finalize_tabularray.R | 2 +- R/finalize_typst.R | 69 ++-- R/footnotes.R | 54 +-- R/format_numeric.R | 26 +- R/format_tt.R | 664 +++++++++++++++++----------------- R/group_bootstrap.R | 12 +- R/group_grid.R | 3 +- R/group_tabularray.R | 9 +- R/group_tt.R | 10 +- R/group_typst.R | 9 +- R/last_style.R | 34 +- R/package.R | 2 +- R/plot_tt.R | 16 +- R/print.R | 2 +- R/rbind2.R | 73 ++-- R/sanity.R | 612 +++++++++++++++---------------- R/save_tt.R | 9 +- R/style_bootstrap.R | 212 ++++++----- R/style_grid.R | 36 +- R/style_grid_dataframe.R | 27 +- R/style_string.R | 198 +++++----- R/style_tabularray.R | 15 +- R/style_tt.R | 414 ++++++++++----------- R/style_typst.R | 224 ++++++------ R/theme_bootstrap.R | 45 +-- R/theme_default.R | 39 +- R/theme_grid.R | 39 +- R/theme_multipage.R | 64 ++-- R/theme_placement.R | 48 ++- R/theme_resize.R | 70 ++-- R/theme_revealjs.R | 15 +- R/theme_rotate.R | 67 ++-- R/theme_spacing.R | 50 +-- R/theme_striped.R | 58 +-- R/theme_tabular.R | 99 +++-- R/theme_void.R | 57 +-- R/tt.R | 40 +- R/tt_bootstrap.R | 302 ++++++++-------- R/tt_grid.R | 18 +- R/tt_tabularray.R | 178 +++++---- R/tt_typst.R | 167 ++++----- R/utils.R | 34 +- R/zzz.R | 2 +- README.qmd | 8 +- sandbox/latex.qmd | 4 +- sandbox/quarto_processing.qmd | 2 +- sandbox/typst.qmd | 40 +- tests/tinytest.R | 4 +- vignettes/alternatives.qmd | 12 +- vignettes/custom.qmd | 30 +- vignettes/format.qmd | 42 ++- vignettes/group.qmd | 37 +- vignettes/notebooks.qmd | 8 +- vignettes/plot.qmd | 17 +- vignettes/style.qmd | 66 ++-- vignettes/theme.qmd | 28 +- vignettes/tinytable.qmd | 32 +- 61 files changed, 2625 insertions(+), 2506 deletions(-) diff --git a/R/build_tt.R b/R/build_tt.R index 435489ff..26d42cdd 100644 --- a/R/build_tt.R +++ b/R/build_tt.R @@ -4,110 +4,110 @@ # # THE ORDER MATTERS A LOT! build_tt <- function(x, output = NULL) { - output <- sanitize_output(output) - - - x <- switch(output, - html = swap_class(x, "tinytable_bootstrap"), - latex = swap_class(x, "tinytable_tabularray"), - markdown = swap_class(x, "tinytable_grid"), - gfm = swap_class(x, "tinytable_grid"), - typst = swap_class(x, "tinytable_typst"), - dataframe = swap_class(x, "tinytable_dataframe"), - ) - - x@output <- output - - # apply the style_notes - x <- style_notes(x) - x <- style_caption(x) - - for (th in x@lazy_theme) { - fn <- th[[1]] - args <- th[[2]] - args[["x"]] <- x - x <- do.call(fn, args) + output <- sanitize_output(output) + + + x <- switch(output, + html = swap_class(x, "tinytable_bootstrap"), + latex = swap_class(x, "tinytable_tabularray"), + markdown = swap_class(x, "tinytable_grid"), + gfm = swap_class(x, "tinytable_grid"), + typst = swap_class(x, "tinytable_typst"), + dataframe = swap_class(x, "tinytable_dataframe"), + ) + + x@output <- output + + # apply the style_notes + x <- style_notes(x) + x <- style_caption(x) + + for (th in x@lazy_theme) { + fn <- th[[1]] + args <- th[[2]] + args[["x"]] <- x + x <- do.call(fn, args) + } + + tab <- x@table_dataframe + + # strip ANSI from `tibble`/`pillar`; keep for markdown + if (isTRUE(check_dependency("fansi"))) { + for (col in seq_along(tab)) { + if (isTRUE(x@output == "html")) { + tab[[col]] <- as.character(fansi::to_html(tab[[col]], warn = FALSE)) + } else if (isTRUE(!x@output %in% c("markdown", "dataframe"))) { + tab[[col]] <- as.character(fansi::strip_ctl(tab[[col]])) + } } - - tab <- x@table_dataframe - - # strip ANSI from `tibble`/`pillar`; keep for markdown - if (isTRUE(check_dependency("fansi"))) { - for (col in seq_along(tab)) { - if (isTRUE(x@output == "html")) { - tab[[col]] <- as.character(fansi::to_html(tab[[col]], warn = FALSE)) - } else if (isTRUE(!x@output %in% c("markdown", "dataframe"))) { - tab[[col]] <- as.character(fansi::strip_ctl(tab[[col]])) - } - } + } + x@table_dataframe <- tab + + # format data before drawing the table + for (l in x@lazy_format) { + l[["x"]] <- x + x <- eval(l) + } + + # add footnote markers just after formatting, otherwise appending converts to string + x <- footnote_markers(x) + + # plots and images + for (l in x@lazy_plot) { + l[["x"]] <- x + x <- eval(l) + } + + # data frame we trim strings, pre-padded for markdown + if (x@output == "dataframe") { + tmp <- x@table_dataframe + for (i in seq_along(tmp)) { + tmp[[i]] <- trimws(tmp[[i]]) } - x@table_dataframe <- tab - - # format data before drawing the table - for (l in x@lazy_format) { - l[["x"]] <- x - x <- eval(l) + x@table_dataframe <- tmp + } + + # markdown styles need to be applied before creating the table, otherwise there's annoying parsing, etc. + if (x@output %in% c("markdown", "gfm", "dataframe")) { + x <- style_eval(x) + } + + # draw the table + x <- tt_eval(x) + + ihead <- 0 + for (idx in seq_along(x@lazy_group)) { + l <- x@lazy_group[[idx]] + l[["x"]] <- x + if (length(l[["j"]]) > 0) { + ihead <- ihead - 1 + l[["ihead"]] <- ihead } - - # add footnote markers just after formatting, otherwise appending converts to string - x <- footnote_markers(x) - - # plots and images - for (l in x@lazy_plot) { - l[["x"]] <- x + x <- eval(l) + } + + if (!x@output %in% c("markdown", "gfm", "dataframe")) { + for (l in x@lazy_style) { + l[["x"]] <- x + # output-specific styling + if (is.null(l$output) || isTRUE(x@output == l$output)) { x <- eval(l) + } } + } - # data frame we trim strings, pre-padded for markdown - if (x@output == "dataframe") { - tmp <- x@table_dataframe - for (i in seq_along(tmp)) { - tmp[[i]] <- trimws(tmp[[i]]) - } - x@table_dataframe <- tmp - } + # markdown styles are applied earlier + if (!x@output %in% c("markdown", "gfm", "dataframe")) { + x <- style_eval(x) + } - # markdown styles need to be applied before creating the table, otherwise there's annoying parsing, etc. - if (x@output %in% c("markdown", "gfm", "dataframe")) { - x <- style_eval(x) - } - - # draw the table - x <- tt_eval(x) - - ihead <- 0 - for (idx in seq_along(x@lazy_group)) { - l <- x@lazy_group[[idx]] - l[["x"]] <- x - if (length(l[["j"]]) > 0) { - ihead <- ihead - 1 - l[["ihead"]] <- ihead - } - x <- eval(l) - } - - if (!x@output %in% c("markdown", "gfm", "dataframe")) { - for (l in x@lazy_style) { - l[["x"]] <- x - # output-specific styling - if (is.null(l$output) || isTRUE(x@output == l$output)) { - x <- eval(l) - } - } - } - - # markdown styles are applied earlier - if (!x@output %in% c("markdown", "gfm", "dataframe")) { - x <- style_eval(x) - } + x <- finalize(x) - x <- finalize(x) - - x@table_string <- lines_drop_consecutive_empty(x@table_string) - if (output == "gfm") { - assert_dependency("pandoc") - x@table_string <- paste(pandoc::pandoc_convert(text = x@table_string, to = "gfm"), collapse = "\n") - } + x@table_string <- lines_drop_consecutive_empty(x@table_string) + if (output == "gfm") { + assert_dependency("pandoc") + x@table_string <- paste(pandoc::pandoc_convert(text = x@table_string, to = "gfm"), collapse = "\n") + } - return(x) + return(x) } diff --git a/R/class.R b/R/class.R index 99a09962..88736723 100644 --- a/R/class.R +++ b/R/class.R @@ -1,15 +1,15 @@ swap_class <- function(x, new_class) { - out <- methods::new(new_class) - for (s in methods::slotNames(x)) { - # modelsummary issue #727 - tmp <- methods::slot(x, s) - if (inherits(tmp, "data.table")) { - assert_dependency("data.table") - data.table::setDT(tmp) - } - methods::slot(out, s) <- tmp + out <- methods::new(new_class) + for (s in methods::slotNames(x)) { + # modelsummary issue #727 + tmp <- methods::slot(x, s) + if (inherits(tmp, "data.table")) { + assert_dependency("data.table") + data.table::setDT(tmp) } - return(out) + methods::slot(out, s) <- tmp + } + return(out) } setClassUnion("NULLorCharacter", c("NULL", "character")) @@ -19,42 +19,42 @@ setClassUnion("NULLorCharacter", c("NULL", "character")) #' @keywords internal #' @export setClass( - Class = "tinytable", - slots = representation( - table_dataframe = "data.frame", - table_string = "character", - data = "data.frame", - caption = "character", - width = "numeric", - width_cols = "numeric", - notes = "list", - theme = "list", - placement = "character", - body = "character", - nrow = "numeric", - ncol = "numeric", - nhead = "numeric", - ngroupi = "numeric", - ngroupj = "numeric", - group_i_idx = "numeric", - names = "NULLorCharacter", - output = "character", - output_dir = "character", - id = "character", - bootstrap_class = "character", - bootstrap_css_rule = "character", - css = "data.frame", - style = "data.frame", - style_caption = "list", - style_notes = "list", - lazy_format = "list", - lazy_group = "list", - lazy_style = "list", - lazy_plot = "list", - lazy_finalize = "list", - lazy_theme = "list", - portable = "logical" - ) + Class = "tinytable", + slots = representation( + table_dataframe = "data.frame", + table_string = "character", + data = "data.frame", + caption = "character", + width = "numeric", + width_cols = "numeric", + notes = "list", + theme = "list", + placement = "character", + body = "character", + nrow = "numeric", + ncol = "numeric", + nhead = "numeric", + ngroupi = "numeric", + ngroupj = "numeric", + group_i_idx = "numeric", + names = "NULLorCharacter", + output = "character", + output_dir = "character", + id = "character", + bootstrap_class = "character", + bootstrap_css_rule = "character", + css = "data.frame", + style = "data.frame", + style_caption = "list", + style_notes = "list", + lazy_format = "list", + lazy_group = "list", + lazy_style = "list", + lazy_plot = "list", + lazy_finalize = "list", + lazy_theme = "list", + portable = "logical" + ) ) #' Method for a tinytable S4 object @@ -70,30 +70,30 @@ setMethod("initialize", "tinytable", function( theme = list("default"), placement = NULL, width = NULL) { - # explicit - .Object@data <- data - .Object@table_dataframe <- table - .Object@theme <- theme - # dynamic - .Object@nrow <- nrow(.Object@data) - .Object@ncol <- ncol(.Object@data) - .Object@nhead <- if (is.null(colnames(data))) 0 else 1 - .Object@ngroupi <- 0 - .Object@ngroupj <- 0 - .Object@names <- if (is.null(colnames(data))) character() else colnames(data) - .Object@id <- get_id("tinytable_") - .Object@output <- "tinytable" - .Object@output_dir <- getwd() - .Object@css <- data.frame(i = NA, j = NA, bootstrap = NA, id = NA) - .Object@portable <- FALSE - .Object@style <- data.frame() - .Object@lazy_theme <- list() - # conditional: allows NULL user input - if (!is.null(placement)) .Object@placement <- placement - if (!is.null(caption)) .Object@caption <- caption - if (!is.null(width)) .Object@width <- width - if (!is.null(notes)) .Object@notes <- notes - return(.Object) + # explicit + .Object@data <- data + .Object@table_dataframe <- table + .Object@theme <- theme + # dynamic + .Object@nrow <- nrow(.Object@data) + .Object@ncol <- ncol(.Object@data) + .Object@nhead <- if (is.null(colnames(data))) 0 else 1 + .Object@ngroupi <- 0 + .Object@ngroupj <- 0 + .Object@names <- if (is.null(colnames(data))) character() else colnames(data) + .Object@id <- get_id("tinytable_") + .Object@output <- "tinytable" + .Object@output_dir <- getwd() + .Object@css <- data.frame(i = NA, j = NA, bootstrap = NA, id = NA) + .Object@portable <- FALSE + .Object@style <- data.frame() + .Object@lazy_theme <- list() + # conditional: allows NULL user input + if (!is.null(placement)) .Object@placement <- placement + if (!is.null(caption)) .Object@caption <- caption + if (!is.null(width)) .Object@width <- width + if (!is.null(notes)) .Object@notes <- notes + return(.Object) }) #' Method for a tinytable S4 object @@ -101,7 +101,7 @@ setMethod("initialize", "tinytable", function( #' @inheritParams tt #' @keywords internal setMethod("nrow", "tinytable", function(x) { - return(x@nrow) + return(x@nrow) }) #' Method for a tinytable S4 object @@ -109,7 +109,7 @@ setMethod("nrow", "tinytable", function(x) { #' @inheritParams tt #' @keywords internal setMethod("ncol", "tinytable", function(x) { - return(x@ncol) + return(x@ncol) }) #' Method for a tinytable S4 object @@ -118,7 +118,7 @@ setMethod("ncol", "tinytable", function(x) { #' @keywords internal #' @export setMethod("colnames", "tinytable", function(x) { - return(x@names) + return(x@names) }) #' Method for a tinytable S4 object @@ -127,7 +127,7 @@ setMethod("colnames", "tinytable", function(x) { #' @keywords internal #' @export setMethod("names", "tinytable", function(x) { - return(x@names) + return(x@names) }) #' Method for a tinytable S4 object @@ -136,18 +136,19 @@ setMethod("names", "tinytable", function(x) { #' @keywords internal #' @export setReplaceMethod("colnames", - signature = "tinytable", - definition = function(x, value) { - # Issue #306 - if (length(value) == 0) value <- NULL - if (!is.null(value)) { - assert_character(value, len = length(x@names)) - } else { - if (x@nhead == 1) x@nhead <- 0 - } - x@names <- value - return(x) - }) + signature = "tinytable", + definition = function(x, value) { + # Issue #306 + if (length(value) == 0) value <- NULL + if (!is.null(value)) { + assert_character(value, len = length(x@names)) + } else { + if (x@nhead == 1) x@nhead <- 0 + } + x@names <- value + return(x) + } +) #' Method for a tinytable S4 object #' @@ -155,25 +156,26 @@ setReplaceMethod("colnames", #' @keywords internal #' @export setReplaceMethod("names", - signature = "tinytable", - definition = function(x, value) { - # Issue #306 - if (length(value) == 0) value <- NULL - if (!is.null(value)) { - assert_character(value, len = length(x@names)) - } else { - if (x@nhead == 1) x@nhead <- 0 - } - x@names <- value - return(x) - }) + signature = "tinytable", + definition = function(x, value) { + # Issue #306 + if (length(value) == 0) value <- NULL + if (!is.null(value)) { + assert_character(value, len = length(x@names)) + } else { + if (x@nhead == 1) x@nhead <- 0 + } + x@names <- value + return(x) + } +) #' Dimensions a tinytable S4 object #' #' @inheritParams tt #' @keywords internal setMethod("dim", "tinytable", function(x) { - return(c(x@nrow, x@ncol)) + return(c(x@nrow, x@ncol)) }) #' Column names of a tinytable @@ -181,7 +183,7 @@ setMethod("dim", "tinytable", function(x) { #' @inheritParams tt #' @keywords internal setMethod("names", "tinytable", function(x) { - return(x@names) + return(x@names) }) #' Convert a tinytable S4 object to a string @@ -189,7 +191,7 @@ setMethod("names", "tinytable", function(x) { #' @inheritParams tt #' @keywords internal setMethod("as.character", "tinytable", function(x) { - out <- save_tt(x, x@output) + out <- save_tt(x, x@output) }) @@ -204,8 +206,8 @@ setClass("tinytable_dataframe", contains = "tinytable") #' @inheritParams tt #' @keywords internal setGeneric( - name = "style_eval", - def = function(x, ...) standardGeneric("style_eval") + name = "style_eval", + def = function(x, ...) standardGeneric("style_eval") ) #' Apply group settings to a tinytable @@ -213,8 +215,8 @@ setGeneric( #' @inheritParams tt #' @keywords internal setGeneric( - name = "tt_eval", - def = function(x, ...) standardGeneric("tt_eval") + name = "tt_eval", + def = function(x, ...) standardGeneric("tt_eval") ) #' Apply group settings to a tinytable @@ -222,8 +224,8 @@ setGeneric( #' @inheritParams tt #' @keywords internal setGeneric( - name = "group_eval", - def = function(x, ...) standardGeneric("group_eval") + name = "group_eval", + def = function(x, ...) standardGeneric("group_eval") ) #' Apply final settings to a tinytable @@ -231,6 +233,6 @@ setGeneric( #' @inheritParams tt #' @keywords internal setGeneric( - name = "finalize", - def = function(x, ...) standardGeneric("finalize") + name = "finalize", + def = function(x, ...) standardGeneric("finalize") ) diff --git a/R/escape.R b/R/escape.R index cad87f3f..79aa47c3 100644 --- a/R/escape.R +++ b/R/escape.R @@ -1,56 +1,57 @@ escape_text <- function(x, output = "latex") { - if (length(x) < 1 || all(is.na(x))) return(x) - if(isFALSE(output)) return(x) - - out <- x - - if (isTRUE(output == "latex")) { - # LaTeX escaping code adapted from the `gt` package, published under MIT - # https://github.com/rstudio/gt/ - # YEAR: 2018-2024 - # COPYRIGHT HOLDER: gt authors - # If all text elements are `NA_character_` then return `text` unchanged - latex_special_chars <- c( - "\\" = "\\textbackslash{}", - "~" = "\\textasciitilde{}", - "^" = "\\textasciicircum{}", - "&" = "\\&", - "%" = "\\%", - "$" = "\\$", - "#" = "\\#", - "_" = "\\_", - "{" = "\\{", - "}" = "\\}" - ) - na_out <- is.na(out) - m <- gregexpr("[\\\\&%$#_{}~^]", out[!na_out], perl = TRUE) - special_chars <- regmatches(out[!na_out], m) - escaped_chars <- lapply(special_chars, function(x) { - latex_special_chars[x] - }) - regmatches(out[!na_out], m) <- escaped_chars - - } else if (isTRUE(output == "html")) { - out <- htmlEscape(out) - - } else if (isTRUE(output == "typst")) { - out <- gsub("<", "\\<", out, fixed = TRUE) - out <- gsub(">", "\\>", out, fixed = TRUE) - out <- gsub("*", "\\*", out, fixed = TRUE) - out <- gsub(">", "\\>", out, fixed = TRUE) - out <- gsub("@", "\\@", out, fixed = TRUE) - out <- gsub("=", "\\=", out, fixed = TRUE) - out <- gsub("-", "\\-", out, fixed = TRUE) - out <- gsub("+", "\\+", out, fixed = TRUE) - out <- gsub("/", "\\/", out, fixed = TRUE) - out <- gsub("$", "\\$", out, fixed = TRUE) - out <- gsub("#", "\\#", out, fixed = TRUE) - out <- gsub("[", "\\[", out, fixed = TRUE) - out <- gsub("]", "\\]", out, fixed = TRUE) + if (length(x) < 1 || all(is.na(x))) { + return(x) + } + if (isFALSE(output)) { + return(x) + } - } + out <- x + + if (isTRUE(output == "latex")) { + # LaTeX escaping code adapted from the `gt` package, published under MIT + # https://github.com/rstudio/gt/ + # YEAR: 2018-2024 + # COPYRIGHT HOLDER: gt authors + # If all text elements are `NA_character_` then return `text` unchanged + latex_special_chars <- c( + "\\" = "\\textbackslash{}", + "~" = "\\textasciitilde{}", + "^" = "\\textasciicircum{}", + "&" = "\\&", + "%" = "\\%", + "$" = "\\$", + "#" = "\\#", + "_" = "\\_", + "{" = "\\{", + "}" = "\\}" + ) + na_out <- is.na(out) + m <- gregexpr("[\\\\&%$#_{}~^]", out[!na_out], perl = TRUE) + special_chars <- regmatches(out[!na_out], m) + escaped_chars <- lapply(special_chars, function(x) { + latex_special_chars[x] + }) + regmatches(out[!na_out], m) <- escaped_chars + } else if (isTRUE(output == "html")) { + out <- htmlEscape(out) + } else if (isTRUE(output == "typst")) { + out <- gsub("<", "\\<", out, fixed = TRUE) + out <- gsub(">", "\\>", out, fixed = TRUE) + out <- gsub("*", "\\*", out, fixed = TRUE) + out <- gsub(">", "\\>", out, fixed = TRUE) + out <- gsub("@", "\\@", out, fixed = TRUE) + out <- gsub("=", "\\=", out, fixed = TRUE) + out <- gsub("-", "\\-", out, fixed = TRUE) + out <- gsub("+", "\\+", out, fixed = TRUE) + out <- gsub("/", "\\/", out, fixed = TRUE) + out <- gsub("$", "\\$", out, fixed = TRUE) + out <- gsub("#", "\\#", out, fixed = TRUE) + out <- gsub("[", "\\[", out, fixed = TRUE) + out <- gsub("]", "\\]", out, fixed = TRUE) + } - return(out) + return(out) } @@ -59,37 +60,39 @@ escape_text <- function(x, output = "latex") { # function copied from `htmltools` under GPL3 license on 2024-02-07 # https://cran.r-project.org/web/packages/htmltools/index.html htmlEscape <- local({ - .htmlSpecials <- list( - `&` = '&', - `<` = '<', - `>` = '>' + `&` = "&", + `<` = "<", + `>` = ">" ) - .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|') + .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse = "|") .htmlSpecialsAttrib <- c( .htmlSpecials, - `'` = ''', - `"` = '"', - `\r` = ' ', - `\n` = ' ' + `'` = "'", + `"` = """, + `\r` = " ", + `\n` = " " ) - .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|') + .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse = "|") - function(text, attribute=FALSE) { - pattern <- if(attribute) + function(text, attribute = FALSE) { + pattern <- if (attribute) { .htmlSpecialsPatternAttrib - else + } else { .htmlSpecialsPattern + } text <- enc2utf8(as.character(text)) # Short circuit in the common case that there's nothing to escape - if (!any(grepl(pattern, text, useBytes = TRUE))) + if (!any(grepl(pattern, text, useBytes = TRUE))) { return(text) + } - specials <- if(attribute) + specials <- if (attribute) { .htmlSpecialsAttrib - else + } else { .htmlSpecials + } for (chr in names(specials)) { text <- gsub(chr, specials[[chr]], text, fixed = TRUE, useBytes = TRUE) diff --git a/R/finalize_bootstrap.R b/R/finalize_bootstrap.R index afee8f6a..0e7a05f7 100644 --- a/R/finalize_bootstrap.R +++ b/R/finalize_bootstrap.R @@ -2,82 +2,86 @@ setMethod( f = "finalize", signature = "tinytable_bootstrap", definition = function(x, ...) { - - # class - cl <- x@bootstrap_class - if (is.null(cl) || length(cl) == 0) { - cl <- "table table-borderless" - } - out <- sub( - "$tinytable_BOOTSTRAP_CLASS", - cl, - x@table_string, - fixed = TRUE) + # class + cl <- x@bootstrap_class + if (is.null(cl) || length(cl) == 0) { + cl <- "table table-borderless" + } + out <- sub( + "$tinytable_BOOTSTRAP_CLASS", + cl, + x@table_string, + fixed = TRUE + ) if (isTRUE(getOption("knitr.in.progress"))) { - # Rmarkdown and Quarto load their own bootstrap, which we probably don't want to override - out <- lines_drop(out, "jsdelivr.*bootstrap", fixed = FALSE, unique = FALSE) - # avoid nesting full HTML page inside an HTML page - out <- lines_drop_between(out, - regex_start = "", - regex_end = "", - fixed = TRUE) - out <- lines_drop_between(out, - regex_start = "", - regex_end = "", - fixed = TRUE) + # Rmarkdown and Quarto load their own bootstrap, which we probably don't want to override + out <- lines_drop(out, "jsdelivr.*bootstrap", fixed = FALSE, unique = FALSE) + # avoid nesting full HTML page inside an HTML page + out <- lines_drop_between(out, + regex_start = "", + regex_end = "", + fixed = TRUE + ) + out <- lines_drop_between(out, + regex_start = "", + regex_end = "", + fixed = TRUE + ) } - # Changing function names to table ID to avoid conflict with other tables functions - out <- gsub("styleCell_\\w+\\(", paste0("styleCell_", x@id, "("), out) - out <- gsub("spanCell_\\w+\\(", paste0("spanCell_", x@id, "("), out) - + # Changing function names to table ID to avoid conflict with other tables functions + out <- gsub("styleCell_\\w+\\(", paste0("styleCell_", x@id, "("), out) + out <- gsub("spanCell_\\w+\\(", paste0("spanCell_", x@id, "("), out) - css_template <- " .table td.%s, .table th.%s { %s }" - css <- unique(stats::na.omit(x@css)) - css <- css[which(css$bootstrap != ""), ] + css_template <- " .table td.%s, .table th.%s { %s }" - if (nrow(css) > 0) { + css <- unique(stats::na.omit(x@css)) + css <- css[which(css$bootstrap != ""), ] - css_rules <- css - css_rules$id <- NULL - css_rules <- split(css_rules, list(css_rules$i, css_rules$j)) - css_rules <- Filter(function(z) nrow(z) > 0, css_rules) - css_rules <- lapply(css_rules, function(z) z[rev(seq_len(nrow(z))),]) - css_rules <- lapply(css_rules, unique) - css_rules <- lapply(css_rules, function(z) transform(z, bootstrap = paste(bootstrap, collapse = " "))[1,]) - css_rules <- do.call(rbind, css_rules) - id <- unique(css_rules[, "bootstrap", drop = FALSE]) - id$id <- sapply(seq_len(nrow(id)), function(z) sprintf("tinytable_css_%s", get_id())) - css_rules <- merge(css_rules, id) - css_rules <- css_rules[order(css_rules$i, css_rules$j),] + if (nrow(css) > 0) { + css_rules <- css + css_rules$id <- NULL + css_rules <- split(css_rules, list(css_rules$i, css_rules$j)) + css_rules <- Filter(function(z) nrow(z) > 0, css_rules) + css_rules <- lapply(css_rules, function(z) z[rev(seq_len(nrow(z))), ]) + css_rules <- lapply(css_rules, unique) + css_rules <- lapply(css_rules, function(z) transform(z, bootstrap = paste(bootstrap, collapse = " "))[1, ]) + css_rules <- do.call(rbind, css_rules) + id <- unique(css_rules[, "bootstrap", drop = FALSE]) + id$id <- sapply(seq_len(nrow(id)), function(z) sprintf("tinytable_css_%s", get_id())) + css_rules <- merge(css_rules, id) + css_rules <- css_rules[order(css_rules$i, css_rules$j), ] - for (ii in seq_len(nrow(css_rules))) { + for (ii in seq_len(nrow(css_rules))) { listener <- sprintf( - "window.addEventListener('load', function () { styleCell_%s(%s, %s, '%s') })", - x@id, - css_rules$i[[ii]], - css_rules$j[[ii]], - css_rules$id[[ii]]) + "window.addEventListener('load', function () { styleCell_%s(%s, %s, '%s') })", + x@id, + css_rules$i[[ii]], + css_rules$j[[ii]], + css_rules$id[[ii]] + ) out <- bootstrap_setting(out, listener, component = "cell") - } - css_rules_unique <- unique(css_rules[, c("bootstrap", "id")]) - for (ii in seq_len(nrow(css_rules_unique))) { - css_rule <- sprintf(css_template, - css_rules_unique$id[[ii]], - css_rules_unique$id[[ii]], - css_rules_unique$bootstrap[[ii]]) + } + css_rules_unique <- unique(css_rules[, c("bootstrap", "id")]) + for (ii in seq_len(nrow(css_rules_unique))) { + css_rule <- sprintf( + css_template, + css_rules_unique$id[[ii]], + css_rules_unique$id[[ii]], + css_rules_unique$bootstrap[[ii]] + ) out <- bootstrap_setting(out, css_rule, component = "css") + } } - } + x@table_string <- out - x@table_string <- out + for (fn in x@lazy_finalize) { + x <- fn(x) + } - for (fn in x@lazy_finalize) { - x <- fn(x) + return(x) } - - return(x) -}) +) diff --git a/R/finalize_tabularray.R b/R/finalize_tabularray.R index 452ea5da..367aea92 100644 --- a/R/finalize_tabularray.R +++ b/R/finalize_tabularray.R @@ -7,4 +7,4 @@ setMethod( } return(x) } -) \ No newline at end of file +) diff --git a/R/finalize_typst.R b/R/finalize_typst.R index 5309905a..216b0334 100644 --- a/R/finalize_typst.R +++ b/R/finalize_typst.R @@ -2,45 +2,46 @@ setMethod( f = "finalize", signature = "tinytable_typst", definition = function(x, ...) { + out <- x@table_string + out <- sub("$TINYTABLE_TYPST_NROW", nrow(x), out, fixed = TRUE) + out <- sub("$TINYTABLE_TYPST_NCOL", ncol(x), out, fixed = TRUE) + out <- sub("$TINYTABLE_TYPST_NHEAD", x@nhead, out, fixed = TRUE) - out <- x@table_string - out <- sub("$TINYTABLE_TYPST_NROW", nrow(x), out, fixed = TRUE) - out <- sub("$TINYTABLE_TYPST_NCOL", ncol(x), out, fixed = TRUE) - out <- sub("$TINYTABLE_TYPST_NHEAD", x@nhead, out, fixed = TRUE) - - cap <- x@caption - if (length(cap) == 1) { - out <- sub("$TINYTABLE_TYPST_CAPTION", sprintf("caption: [%s],", cap), out, fixed = TRUE) - } else { - out <- sub("$TINYTABLE_TYPST_CAPTION", "", out, fixed = TRUE) - } + cap <- x@caption + if (length(cap) == 1) { + out <- sub("$TINYTABLE_TYPST_CAPTION", sprintf("caption: [%s],", cap), out, fixed = TRUE) + } else { + out <- sub("$TINYTABLE_TYPST_CAPTION", "", out, fixed = TRUE) + } - # Quarto cross-references - if (isTRUE(check_dependency("knitr"))) { - quarto_caption <- isTRUE(knitr::pandoc_to("typst")) && - isFALSE(getOption("tinytable_quarto_figure", default = FALSE)) - (!is.null(knitr::opts_current$get()[["label"]]) || - !is.null(knitr::opts_current$get()[["tbl-cap"]])) - if (quarto_caption) { - out <- lines_drop_between(out, - regex_start = "// start figure preamble", - regex_end = "// end figure preamble", - fixed = TRUE) - out <- lines_drop(out, regex = "// start figure preamble", fixed = TRUE) - out <- lines_drop(out, regex = "// end figure", fixed = TRUE) - out <- lines_drop(out, regex = "// start block", fixed = TRUE) - out <- lines_drop(out, regex = "// end block", fixed = TRUE) - out <- sub(" table(", " #table(", out, fixed = TRUE) + # Quarto cross-references + if (isTRUE(check_dependency("knitr"))) { + quarto_caption <- isTRUE(knitr::pandoc_to("typst")) && + isFALSE(getOption("tinytable_quarto_figure", default = FALSE)) + (!is.null(knitr::opts_current$get()[["label"]]) || + !is.null(knitr::opts_current$get()[["tbl-cap"]])) + if (quarto_caption) { + out <- lines_drop_between(out, + regex_start = "// start figure preamble", + regex_end = "// end figure preamble", + fixed = TRUE + ) + out <- lines_drop(out, regex = "// start figure preamble", fixed = TRUE) + out <- lines_drop(out, regex = "// end figure", fixed = TRUE) + out <- lines_drop(out, regex = "// start block", fixed = TRUE) + out <- lines_drop(out, regex = "// end block", fixed = TRUE) + out <- sub(" table(", " #table(", out, fixed = TRUE) + } } - } - x@table_string <- out + x@table_string <- out - for (fn in x@lazy_finalize) { - x <- fn(x) - } + for (fn in x@lazy_finalize) { + x <- fn(x) + } - return(x) -}) + return(x) + } +) diff --git a/R/footnotes.R b/R/footnotes.R index b60aa0c4..3e9ee34b 100644 --- a/R/footnotes.R +++ b/R/footnotes.R @@ -1,29 +1,29 @@ footnote_markers <- function(x) { - notes <- x@notes - tab <- x@table_dataframe - for (idx in seq_along(notes)) { - n <- notes[[idx]] - sup <- names(notes)[idx] - if (is.list(n)) { - if (x@output == "latex") { - tab[n$i, n$j] <- paste0(tab[n$i, n$j], "\\textsuperscript{", sup, "}") - if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "\\textsuperscript{", sup, "}") - if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "\\textsuperscript{", sup, "}") - } else if (x@output == "html") { - tab[n$i, n$j] <- paste0(tab[n$i, n$j], "", sup, "") - if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "", sup, "") - if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "", sup, "") - } else if (x@output == "typst") { - tab[n$i, n$j] <- paste0(tab[n$i, n$j], "#super[", sup, "]") - if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "#super[", sup, "]") - if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "#super[", sup, "]") - } else { - tab[n$i, n$j] <- paste0(tab[n$i, n$j], "^", sup, "^") - if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "^", sup, "^") - if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "^", sup, "^") - } - } + notes <- x@notes + tab <- x@table_dataframe + for (idx in seq_along(notes)) { + n <- notes[[idx]] + sup <- names(notes)[idx] + if (is.list(n)) { + if (x@output == "latex") { + tab[n$i, n$j] <- paste0(tab[n$i, n$j], "\\textsuperscript{", sup, "}") + if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "\\textsuperscript{", sup, "}") + if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "\\textsuperscript{", sup, "}") + } else if (x@output == "html") { + tab[n$i, n$j] <- paste0(tab[n$i, n$j], "", sup, "") + if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "", sup, "") + if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "", sup, "") + } else if (x@output == "typst") { + tab[n$i, n$j] <- paste0(tab[n$i, n$j], "#super[", sup, "]") + if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "#super[", sup, "]") + if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "#super[", sup, "]") + } else { + tab[n$i, n$j] <- paste0(tab[n$i, n$j], "^", sup, "^") + if (0 %in% n$i) colnames(tab)[n$j] <- paste0(colnames(tab)[n$j], "^", sup, "^") + if (0 %in% n$i) x@names[n$j] <- paste0(x@names[n$j], "^", sup, "^") + } } - x@table_dataframe <- tab - return(x) -} \ No newline at end of file + } + x@table_dataframe <- tab + return(x) +} diff --git a/R/format_numeric.R b/R/format_numeric.R index 9a101503..429d5643 100644 --- a/R/format_numeric.R +++ b/R/format_numeric.R @@ -9,8 +9,9 @@ format_numeric <- function(value, num_suffix, digits, num_mark_big, num_mark_dec num_mark_big = num_mark_big, num_mark_dec = num_mark_dec, num_zero = num_zero, - num_fmt = num_fmt) - # non-integer numeric + num_fmt = num_fmt + ) + # non-integer numeric } else if (is.numeric(value) && !isTRUE(check_integerish(value)) && !is.null(digits)) { out <- format_non_integer_numeric( value, @@ -18,15 +19,17 @@ format_numeric <- function(value, num_suffix, digits, num_mark_big, num_mark_dec num_mark_big = num_mark_big, num_mark_dec = num_mark_dec, num_zero = num_zero, - num_fmt = num_fmt) - # integer + num_fmt = num_fmt + ) + # integer } else if (isTRUE(check_integerish(value))) { - out <- format_integer(value, - digits = digits, - num_mark_big = num_mark_big, - num_mark_dec = num_mark_dec, - num_zero = num_zero, - num_fmt = num_fmt) + out <- format_integer(value, + digits = digits, + num_mark_big = num_mark_big, + num_mark_dec = num_mark_dec, + num_zero = num_zero, + num_fmt = num_fmt + ) } else { out <- NULL } @@ -46,7 +49,8 @@ format_num_suffix <- function(x, digits, num_mark_big, num_mark_dec, num_zero, n format(k, digits = digits, drop0trailing = !num_zero, type = "f", big.mark = num_mark_big, decimal.mark = num_mark_dec, - scientific = FALSE) + scientific = FALSE + ) }) } number <- fun(x) diff --git a/R/format_tt.R b/R/format_tt.R index ffc6c419..86a60f7e 100644 --- a/R/format_tt.R +++ b/R/format_tt.R @@ -1,6 +1,6 @@ #' Format columns of a data frame #' -#' This function formats the columns of a data frame based on the column type (logical, date, numeric). +#' This function formats the columns of a data frame based on the column type (logical, date, numeric). #' It allows various formatting options like significant digits, decimal points, and scientific notation. #' It also includes custom formatting for date and boolean values. #' If this function is applied several times to the same cell, the last transformation is retained and the previous calls are ignored, except for the `escape` argument which can be applied to previously transformed data. @@ -21,7 +21,7 @@ #' - TRUE: Replace `NA` by an empty string. #' - FALSE: Print `NA` as the string "NA". #' - String: Replace `NA` entries by the user-supplied string. -#' - Named list: Replace matching elements of the vectors in the list by theirs names. Example: +#' - Named list: Replace matching elements of the vectors in the list by theirs names. Example: #' - `list("-" = c(NA, NaN), "Tiny" = -Inf, "Massive" = Inf)` #' @param escape Logical or "latex" or "html". If TRUE, escape special characters to display them as text in the format of the output of a `tt()` table. #' - If `i` and `j` are both `NULL`, escape all cells, column names, caption, notes, and spanning labels created by `group_tt()`. @@ -39,39 +39,42 @@ #' @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) #' format_tt <- function(x, i = NULL, @@ -92,67 +95,67 @@ format_tt <- function(x, quarto = get_option("tinytable_format_quarto", default = FALSE), fn = get_option("tinytable_format_fn", default = NULL), sprintf = get_option("tinytable_format_sprintf", default = NULL), - ... - ) { - out <- x - - dots <- list(...) - if ("replace_na" %in% names(dots)) { - replace <- dots[["replace_na"]] - warning("The `replace_na` argument was renamed `replace`.", call. = FALSE) - } - - if (inherits(out, "tinytable")) { - cal <- call("format_tt_lazy", - i = i, - j = j, - digits = digits, - num_fmt = num_fmt, - num_zero = num_zero, - num_suffix = num_suffix, - num_mark_big = num_mark_big, - num_mark_dec = num_mark_dec, - replace = replace, - fn = fn, - sprintf = sprintf, - url = url, - date = date, - bool = bool, - math = math, - escape = escape, - markdown = markdown, - quarto = quarto, - other = other, - inull = is.null(i), - jnull = is.null(j)) - out@lazy_format <- c(out@lazy_format, list(cal)) - } else { - - out <- format_tt_lazy(out, - i = i, - j = j, - digits = digits, - num_fmt = num_fmt, - num_zero = num_zero, - num_suffix = num_suffix, - num_mark_big = num_mark_big, - num_mark_dec = num_mark_dec, - replace = replace, - fn = fn, - sprintf = sprintf, - url = url, - date = date, - bool = bool, - math = math, - other = other, - escape = escape, - quarto = quarto, - markdown = markdown, - inull = is.null(i), - jnull = is.null(j)) - } - - return(out) + ...) { + out <- x + + dots <- list(...) + if ("replace_na" %in% names(dots)) { + replace <- dots[["replace_na"]] + warning("The `replace_na` argument was renamed `replace`.", call. = FALSE) + } + + if (inherits(out, "tinytable")) { + cal <- call("format_tt_lazy", + i = i, + j = j, + digits = digits, + num_fmt = num_fmt, + num_zero = num_zero, + num_suffix = num_suffix, + num_mark_big = num_mark_big, + num_mark_dec = num_mark_dec, + replace = replace, + fn = fn, + sprintf = sprintf, + url = url, + date = date, + bool = bool, + math = math, + escape = escape, + markdown = markdown, + quarto = quarto, + other = other, + inull = is.null(i), + jnull = is.null(j) + ) + out@lazy_format <- c(out@lazy_format, list(cal)) + } else { + out <- format_tt_lazy(out, + i = i, + j = j, + digits = digits, + num_fmt = num_fmt, + num_zero = num_zero, + num_suffix = num_suffix, + num_mark_big = num_mark_big, + num_mark_dec = num_mark_dec, + replace = replace, + fn = fn, + sprintf = sprintf, + url = url, + date = date, + bool = bool, + math = math, + other = other, + escape = escape, + quarto = quarto, + markdown = markdown, + inull = is.null(i), + jnull = is.null(j) + ) + } + + return(out) } format_tt_lazy <- function(x, @@ -176,292 +179,287 @@ format_tt_lazy <- function(x, quarto = quarto, other = as.character, inull = FALSE, - jnull = FALSE - ) { - - # format_tt() supports vectors - if (isTRUE(check_atomic_vector(x))) { - atomic_vector <- TRUE - if (is.factor(x)) x <- as.character(x) - ori <- out <- x <- data.frame(tinytable = x, stringsAsFactors = FALSE) - j <- 1 - } else if (is.data.frame(x)) { - atomic_vector <- FALSE - ori <- out <- x - } else if (inherits(x, "tinytable")){ - atomic_vector <- FALSE - # if no other format_tt() call has been applied, we ctan have numeric values - out <- x@table_dataframe - ori <- x@data + jnull = FALSE) { + # format_tt() supports vectors + if (isTRUE(check_atomic_vector(x))) { + atomic_vector <- TRUE + if (is.factor(x)) x <- as.character(x) + ori <- out <- x <- data.frame(tinytable = x, stringsAsFactors = FALSE) + j <- 1 + } else if (is.data.frame(x)) { + atomic_vector <- FALSE + ori <- out <- x + } else if (inherits(x, "tinytable")) { + atomic_vector <- FALSE + # if no other format_tt() call has been applied, we ctan have numeric values + out <- x@table_dataframe + ori <- x@data + } else { + stop("`x` must be a `tinytable` object, a data frame, or an atomic vector.", call. = FALSE) + } + + assert_integerish(digits, len = 1, null.ok = TRUE) + assert_integerish(i, null.ok = TRUE) + assert_choice(num_fmt, c("significant", "significant_cell", "decimal", "scientific")) + assert_flag(num_zero) + assert_string(num_mark_big) + assert_string(num_mark_dec) + assert_string(date) + assert_function(bool) + assert_function(identity) + assert_function(fn, null.ok = TRUE) + assert_string(sprintf, null.ok = TRUE) + assert_flag(markdown) + assert_flag(quarto) + replace <- sanitize_replace(replace) + sanity_num_mark(digits, num_mark_big, num_mark_dec) + + i <- sanitize_i(i, x, lazy = FALSE) + j <- sanitize_j(j, x) + + # In sanity_tt(), we fill in missing NULL `j` in the format-specific versions, + # because tabularray can do whole column styling. Here, we need to fill in + # NULL for all formats since this is applied before creating the table. + # nrow(out) because nrow(x) sometimes includes rows that will be added **in the lazy future** by group_tt() + + # format each column + # Issue #230: drop=TRUE fixes bug which returned a character dput-like vector + for (col in j) { + # sprintf() is self-contained + if (!is.null(sprintf)) { + out[i, col] <- base::sprintf(sprintf, ori[i, col, drop = TRUE]) } else { - stop("`x` must be a `tinytable` object, a data frame, or an atomic vector.", call. = FALSE) + # logical + if (is.logical(ori[i, col])) { + out[i, col] <- bool(ori[i, col, drop = TRUE]) + + # date + } else if (inherits(ori[i, col], "Date")) { + out[i, col] <- format(ori[i, col, drop = TRUE], date) + + # numeric + } else if (is.numeric(ori[i, col, drop = TRUE])) { + tmp <- format_numeric(ori[i, col], + num_suffix = num_suffix, + digits = digits, + num_mark_big = num_mark_big, + num_mark_dec = num_mark_dec, + num_zero = num_zero, + num_fmt = num_fmt + ) + if (!is.null(tmp)) out[i, col] <- tmp + + # other + } else { + out[i, col] <- other(ori[i, col, drop = TRUE]) + } } - assert_integerish(digits, len = 1, null.ok = TRUE) - assert_integerish(i, null.ok = TRUE) - assert_choice(num_fmt, c("significant", "significant_cell", "decimal", "scientific")) - assert_flag(num_zero) - assert_string(num_mark_big) - assert_string(num_mark_dec) - assert_string(date) - assert_function(bool) - assert_function(identity) - assert_function(fn, null.ok = TRUE) - assert_string(sprintf, null.ok = TRUE) - assert_flag(markdown) - assert_flag(quarto) - replace <- sanitize_replace(replace) - sanity_num_mark(digits, num_mark_big, num_mark_dec) - - i <- sanitize_i(i, x, lazy = FALSE) - j <- sanitize_j(j, x) - - # In sanity_tt(), we fill in missing NULL `j` in the format-specific versions, - # because tabularray can do whole column styling. Here, we need to fill in - # NULL for all formats since this is applied before creating the table. - # nrow(out) because nrow(x) sometimes includes rows that will be added **in the lazy future** by group_tt() - - # format each column - # Issue #230: drop=TRUE fixes bug which returned a character dput-like vector - for (col in j) { - # sprintf() is self-contained - if (!is.null(sprintf)) { - out[i, col] <- base::sprintf(sprintf, ori[i, col, drop = TRUE]) - - } else { - # logical - if (is.logical(ori[i, col])) { - out[i, col] <- bool(ori[i, col, drop = TRUE]) - - # date - } else if (inherits(ori[i, col], "Date")) { - out[i, col] <- format(ori[i, col, drop = TRUE], date) - - # numeric - } else if (is.numeric(ori[i, col, drop = TRUE])) { - tmp <- format_numeric(ori[i, col], - num_suffix = num_suffix, - digits = digits, - num_mark_big = num_mark_big, - num_mark_dec = num_mark_dec, - num_zero = num_zero, - num_fmt = num_fmt) - if (!is.null(tmp)) out[i, col] <- tmp - - # other - } else { - out[i, col] <- other(ori[i, col, drop = TRUE]) - } - } - - for (k in seq_along(replace)) { - idx <- ori[i, col, drop = TRUE] %in% replace[[k]] - out[i, col][idx] <- names(replace)[[k]] - } - - } # loop over columns + for (k in seq_along(replace)) { + idx <- ori[i, col, drop = TRUE] %in% replace[[k]] + out[i, col][idx] <- names(replace)[[k]] + } + } # loop over columns - # Custom functions overwrite all the other formatting, but is before markdown - # before escaping - if (is.function(fn)) { - for (col in j) { - out[i, col] <- fn(ori[i, col, drop = TRUE]) - } + # Custom functions overwrite all the other formatting, but is before markdown + # before escaping + if (is.function(fn)) { + for (col in j) { + out[i, col] <- fn(ori[i, col, drop = TRUE]) } + } - if (isTRUE(math)) { - for (row in i) { - for (col in j) { - out[row, col] <- format_math(out[row, col], math) - } + if (isTRUE(math)) { + for (row in i) { + for (col in j) { + out[row, col] <- format_math(out[row, col], math) + } + } + if (inull && jnull) { + x@caption <- format_math(x@caption, math) + colnames(x) <- format_math(colnames(x), math) + for (idx in seq_along(x@notes)) { + n <- x@notes[[idx]] + if (is.character(n) && length(n) == 1) { + x@notes[[idx]] <- format_math(n, math = math) + } else if (is.list(n) && "text" %in% names(n)) { + n$text <- format_math(n$text, math = math) + x@notes[[idx]] <- n + } + } + for (idx in seq_along(x@lazy_group)) { + g <- x@lazy_group[[idx]] + if (!is.null(g$j)) { + names(g$j) <- format_math(names(g$j), math = math) } - if (inull && jnull) { - x@caption <- format_math(x@caption, math) - colnames(x) <- format_math(colnames(x), math) - for (idx in seq_along(x@notes)) { - n <- x@notes[[idx]] - if (is.character(n) && length(n) == 1) { - x@notes[[idx]] <- format_math(n, math = math) - } else if (is.list(n) && "text" %in% names(n)) { - n$text <- format_math(n$text, math = math) - x@notes[[idx]] <- n - } - } - for (idx in seq_along(x@lazy_group)) { - g <- x@lazy_group[[idx]] - if (!is.null(g$j)) { - names(g$j) <- format_math(names(g$j), math = math) - } - if (!is.null(g$i)) { - names(g$i) <- format_math(names(g$i), math = math) - } - x@lazy_group[[idx]] <- g - } + if (!is.null(g$i)) { + names(g$i) <- format_math(names(g$i), math = math) } + x@lazy_group[[idx]] <- g + } + } + } + + + # escape latex characters + if (!isFALSE(escape)) { + if (isTRUE(escape == "latex")) { + o <- "latex" + } else if (isTRUE(escape == "html")) { + o <- "html" + } else if (isTRUE(escape == "typst")) { + o <- "typst" + } else if (inherits(x, "tinytable")) { + o <- x@output + } else { + o <- FALSE } - - # escape latex characters - if (!isFALSE(escape)) { - if (isTRUE(escape == "latex")) { - o <- "latex" - } else if (isTRUE(escape == "html")) { - o <- "html" - } else if (isTRUE(escape == "typst")) { - o <- "typst" - } else if (inherits(x, "tinytable")) { - o <- x@output - } else { - o <- FALSE + # caption & groups: if i and j are both null + if (inull && jnull) { + if (inherits(x, "tinytable")) { + x@caption <- escape_text(x@caption, output = o) + + for (idx in seq_along(x@notes)) { + n <- x@notes[[idx]] + if (is.character(n) && length(n) == 1) { + x@notes[[idx]] <- escape_text(n, output = o) + } else if (is.list(n) && "text" %in% names(n)) { + n$text <- escape_text(n$text, output = o) + x@notes[[idx]] <- n + } } - # caption & groups: if i and j are both null - if (inull && jnull) { - if (inherits(x, "tinytable")) { - x@caption <- escape_text(x@caption, output = o) - - for (idx in seq_along(x@notes)) { - n <- x@notes[[idx]] - if (is.character(n) && length(n) == 1) { - x@notes[[idx]] <- escape_text(n, output = o) - } else if (is.list(n) && "text" %in% names(n)) { - n$text <- escape_text(n$text, output = o) - x@notes[[idx]] <- n - } - } - - for (idx in seq_along(x@lazy_group)) { - g <- x@lazy_group[[idx]] - if (!is.null(g$j)) { - names(g$j) <- escape_text(names(g$j), output = o) - } - if (!is.null(g$i)) { - names(g$i) <- escape_text(names(g$i), output = o) - } - x@lazy_group[[idx]] <- g - } - } - colnames(x) <- escape_text(colnames(x), output = o) - for (col in seq_len(ncol(out))) { - out[, col] <- escape_text(out[, col], output = o) - } - - } else { - # body - for (row in i) { - for (col in j) { - out[row, col] <- escape_text(out[row, col], output = o) - } - } - - # column names - if (0 %in% i) { - colnames(x) <- escape_text(colnames(x), output = o) - } + for (idx in seq_along(x@lazy_group)) { + g <- x@lazy_group[[idx]] + if (!is.null(g$j)) { + names(g$j) <- escape_text(names(g$j), output = o) + } + if (!is.null(g$i)) { + names(g$i) <- escape_text(names(g$i), output = o) + } + x@lazy_group[[idx]] <- g } + } + colnames(x) <- escape_text(colnames(x), output = o) + for (col in seq_len(ncol(out))) { + out[, col] <- escape_text(out[, col], output = o) + } + } else { + # body + for (row in i) { + for (col in j) { + out[row, col] <- escape_text(out[row, col], output = o) + } + } + # column names + if (0 %in% i) { + colnames(x) <- escape_text(colnames(x), output = o) + } } + } - # markdown and quarto at the very end - for (col in j) { - if (isTRUE(markdown)) { - assert_dependency("markdown") - out <- format_markdown(out = out, i = i, col = col, x = x) - } - - if (isTRUE(quarto)) { - tmp <- format_quarto(out = out, i = i, col = col, x = x) - out <- tmp$out - x <- tmp$x - } + # markdown and quarto at the very end + for (col in j) { + if (isTRUE(markdown)) { + assert_dependency("markdown") + out <- format_markdown(out = out, i = i, col = col, x = x) } - if (inull && jnull && isTRUE(markdown)) { - colnames(x) <- format_markdown(colnames(x), x = x) - if (inherits(x, "tinytable")) { - for (k in seq_along(x@lazy_group)) { - g <- x@lazy_group[[k]] - if (!is.null(g$j)) { - names(g$j) <- format_markdown(names(g$j), x = x) - } - if (!is.null(g$i)) { - names(g$i) <- format_markdown(names(g$i), x = x) - } - x@lazy_group[[k]] <- g - } + if (isTRUE(quarto)) { + tmp <- format_quarto(out = out, i = i, col = col, x = x) + out <- tmp$out + x <- tmp$x + } + } + + if (inull && jnull && isTRUE(markdown)) { + colnames(x) <- format_markdown(colnames(x), x = x) + if (inherits(x, "tinytable")) { + for (k in seq_along(x@lazy_group)) { + g <- x@lazy_group[[k]] + if (!is.null(g$j)) { + names(g$j) <- format_markdown(names(g$j), x = x) } + if (!is.null(g$i)) { + names(g$i) <- format_markdown(names(g$i), x = x) + } + x@lazy_group[[k]] <- g + } } + } - # output - if (isTRUE(atomic_vector)) { - return(out[[1]]) - } else if (!inherits(x, "tinytable")) { - return(out) - } else { - x@table_dataframe <- out - return(x) - } + # output + if (isTRUE(atomic_vector)) { + return(out[[1]]) + } else if (!inherits(x, "tinytable")) { + return(out) + } else { + x@table_dataframe <- out + return(x) + } } format_math <- function(out, math) { - if (isTRUE(math)) { - out <- sprintf("$%s$", out) - } - return(out) + if (isTRUE(math)) { + out <- sprintf("$%s$", out) + } + return(out) } format_markdown <- function(out, i = NULL, col = NULL, x) { - tmpfun_html <- function(k) { - k <- trimws(markdown::mark_html(text = k, template = FALSE)) - k <- sub("

", "", k, fixed = TRUE) - k <- sub("

", "", k, fixed = TRUE) - return(k) + tmpfun_html <- function(k) { + k <- trimws(markdown::mark_html(text = k, template = FALSE)) + k <- sub("

", "", k, fixed = TRUE) + k <- sub("

", "", k, fixed = TRUE) + return(k) + } + + tmpfun_latex <- function(k) { + k <- trimws(markdown::mark_latex(text = k, template = FALSE)) + return(k) + } + + if (inherits(out, "data.frame")) { + ipos <- i[i > 0] + if (length(ipos) > 0) { + if (inherits(x, "tinytable_bootstrap")) { + out[ipos, col] <- sapply(out[ipos, col], function(k) tmpfun_html(k)) + } else if (inherits(x, "tinytable_tabularray")) { + out[ipos, col] <- sapply(out[ipos, col], function(k) tmpfun_latex(k)) + } } - - tmpfun_latex <- function(k) { - k <- trimws(markdown::mark_latex(text = k, template = FALSE)) - return(k) - } - - if (inherits(out, "data.frame")) { - ipos <- i[i > 0] - if (length(ipos) > 0) { - if (inherits(x, "tinytable_bootstrap")) { - out[ipos, col] <- sapply(out[ipos, col], function(k) tmpfun_html(k)) - } else if (inherits(x, "tinytable_tabularray")) { - out[ipos, col] <- sapply(out[ipos, col], function(k) tmpfun_latex(k)) - } - } - } else { - if (inherits(x, "tinytable_bootstrap")) { - out <- sapply(out, function(k) tmpfun_html(k)) - } else if (inherits(x, "tinytable_tabularray")) { - out <- sapply(out, function(k) tmpfun_latex(k)) - } + } else { + if (inherits(x, "tinytable_bootstrap")) { + out <- sapply(out, function(k) tmpfun_html(k)) + } else if (inherits(x, "tinytable_tabularray")) { + out <- sapply(out, function(k) tmpfun_latex(k)) } + } - return(out) + return(out) } format_quarto <- function(out, i, col, x) { - if (isTRUE(x@output == "html")) { - fun <- function(z) { - z@table_string <- sub("data-quarto-disable-processing='true'", - "data-quarto-disable-processing='false'", - z@table_string, - fixed = TRUE) - return(z) - } - x <- style_tt(x, finalize = fun) - out[i, col] <- sprintf('', out[i, col, drop = TRUE]) - } else if (isTRUE(x@output == "latex")) { - assert_dependency("base64enc") - tmp <- sapply(out[i, col, drop = TRUE], function(z) base64enc::base64encode(charToRaw(z))) - out[i, col] <- sprintf("\\QuartoMarkdownBase64{%s}", tmp) + if (isTRUE(x@output == "html")) { + fun <- function(z) { + z@table_string <- sub("data-quarto-disable-processing='true'", + "data-quarto-disable-processing='false'", + z@table_string, + fixed = TRUE + ) + return(z) } - - return(list("out" = out, "x" = x)) + x <- style_tt(x, finalize = fun) + out[i, col] <- sprintf('', out[i, col, drop = TRUE]) + } else if (isTRUE(x@output == "latex")) { + assert_dependency("base64enc") + tmp <- sapply(out[i, col, drop = TRUE], function(z) base64enc::base64encode(charToRaw(z))) + out[i, col] <- sprintf("\\QuartoMarkdownBase64{%s}", tmp) + } + + return(list("out" = out, "x" = x)) } - diff --git a/R/group_bootstrap.R b/R/group_bootstrap.R index 015d4f53..ca67fae4 100644 --- a/R/group_bootstrap.R +++ b/R/group_bootstrap.R @@ -14,7 +14,8 @@ setMethod( out <- group_bootstrap_row(out, i = i, j = j, indent = indent, ...) } return(out) - }) + } +) group_bootstrap_col <- function(x, j, ihead, ...) { @@ -33,7 +34,8 @@ group_bootstrap_col <- function(x, j, ihead, ...) { jstring <- lapply(names(j), function(n) { sprintf( '%s', - max(j[[n]]) - min(j[[n]]) + 1, n) + max(j[[n]]) - min(j[[n]]) + 1, n + ) }) jstring <- paste(unlist(jstring), collapse = "\n") jstring <- sprintf("\n%s\n", 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..2c96352c 100644 --- a/R/group_tt.R +++ b/R/group_tt.R @@ -17,9 +17,10 @@ #' #' # 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 <- "![](%s){ 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..e0a712f0 100644 --- a/R/print.R +++ b/R/print.R @@ -77,7 +77,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 5f92d5a3..38c56328 100644 --- a/R/sanity.R +++ b/R/sanity.R @@ -1,113 +1,113 @@ 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) + } } sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) { - if (is.character(i)) { - assert_choice(i, c("notes", "caption")) - 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) + if (is.character(i)) { + assert_choice(i, c("notes", "caption")) + 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) } @@ -115,315 +115,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 2106d337..dc7813d7 100644 --- a/R/save_tt.R +++ b/R/save_tt.R @@ -26,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) @@ -37,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")) { @@ -100,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") 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_string.R b/R/style_string.R index 091b0a8e..c3996ef9 100644 --- a/R/style_string.R +++ b/R/style_string.R @@ -1,120 +1,120 @@ 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 + 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 + 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) - return(out) + 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) + 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) + 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_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) + 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) + 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 375c0d28..c43445c7 100644 --- a/R/style_tabularray.R +++ b/R/style_tabularray.R @@ -103,7 +103,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] @@ -181,7 +182,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) }) @@ -201,9 +203,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 @@ -237,7 +241,8 @@ setMethod( } return(x) - }) + } +) diff --git a/R/style_tt.R b/R/style_tt.R index 3b68ae1c..2bc6bea9 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -60,50 +60,53 @@ #' #' # Alignment #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(j = 1:5, align = "lcccr") +#' style_tt(j = 1:5, align = "lcccr") #' #' # Colors and styles #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(i = 2:3, background = "black", color = "orange", bold = TRUE) +#' style_tt(i = 2:3, background = "black", color = "orange", bold = TRUE) #' #' # column selection with `j`` #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(j = 5:6, background = "pink") +#' style_tt(j = 5:6, background = "pink") #' #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(j = "drat|wt", background = "pink") +#' style_tt(j = "drat|wt", background = "pink") #' #' tt(mtcars[1:5, 1:6]) |> -#' style_tt(j = c("drat", "wt"), background = "pink") +#' style_tt(j = c("drat", "wt"), background = "pink") #' #' tt(mtcars[1:5, 1:6], theme = "void") |> -#' style_tt( -#' i = 2, j = 2, -#' colspan = 3, -#' rowspan = 2, -#' align = "c", -#' alignv = "m", -#' color = "white", -#' background = "black", -#' bold = TRUE) +#' style_tt( +#' i = 2, j = 2, +#' colspan = 3, +#' rowspan = 2, +#' 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") +#' style_tt( +#' 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") +#' style_tt(bootstrap_class = "table table-dark table-hover") #' #' #' inner <- " @@ -117,7 +120,7 @@ #' cell{2}{2} = {r=4,c=2}{bg=azure7}, #' " #' tt(mtcars[1:5, 1:4], theme = "void") |> -#' style_tt(tabularray_inner = inner) +#' style_tt(tabularray_inner = inner) #' style_tt <- function(x, i = NULL, @@ -146,134 +149,135 @@ style_tt <- function(x, 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 (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) } @@ -301,79 +305,79 @@ assert_style_tt <- function(x, 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))) + # 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))) - # 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))) + # 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))) - # 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))) - } + # 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))) + } } 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 = " 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))) { @@ -132,7 +131,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("", x@caption), - template, - fixed = TRUE - ) - } + # caption + if (length(x@caption) != 1) { + template <- sub( + "$tinytable_BOOTSTRAP_CAPTION", + "", + template, + fixed = TRUE + ) + } else { + template <- sub( + "$tinytable_BOOTSTRAP_CAPTION", + sprintf("", x@caption), + template, + fixed = TRUE + ) + } - # note - if (length(x@notes) == 0) { - template <- sub( - "$tinytable_BOOTSTRAP_NOTE", - "", - template, - fixed = TRUE - ) - } else { - notes_tmp <- NULL - for (k in seq_along(x@notes)) { - if (!is.null(names(x@notes))) { - if (is.list(x@notes[[k]])) { - tmp <- sprintf("", - ncol(x), - names(x@notes)[k], - x@notes[[k]]$text) - # note is a string + # note + if (length(x@notes) == 0) { + template <- sub( + "$tinytable_BOOTSTRAP_NOTE", + "", + template, + fixed = TRUE + ) + } else { + notes_tmp <- NULL + for (k in seq_along(x@notes)) { + if (!is.null(names(x@notes))) { + if (is.list(x@notes[[k]])) { + tmp <- sprintf( + "", + ncol(x), + names(x@notes)[k], + x@notes[[k]]$text + ) + # note is a string + } else { + tmp <- sprintf( + "", + ncol(x), + names(x@notes)[k], + x@notes[k] + ) + } } else { - tmp <- sprintf("", - ncol(x), - names(x@notes)[k], - x@notes[k]) + tmp <- sprintf("", ncol(x), x@notes[[k]]) } - } else { - tmp <- sprintf("", ncol(x), x@notes[[k]]) + notes_tmp <- c(notes_tmp, tmp) } - notes_tmp <- c(notes_tmp, tmp) - } - notes <- paste(notes_tmp, collapse = "\n") - notes <- paste0("", notes, "") - template <- sub( - "$tinytable_BOOTSTRAP_NOTE", - notes, - template, - fixed = TRUE - ) - for (ii in seq_along(notes)) { + notes <- paste(notes_tmp, collapse = "\n") + notes <- paste0("", notes, "") + template <- sub( + "$tinytable_BOOTSTRAP_NOTE", + notes, + template, + fixed = TRUE + ) + for (ii in seq_along(notes)) { x <- style_tt(x, i = nrow(x) + ii, align = "l") + } } - } - # width - if (length(x@width) == 1) { - template <- sub( - "width: auto;", - sprintf('table-layout: fixed; width: %s%% !important;', round(x@width * 100)), - template, - fixed = TRUE + # width + if (length(x@width) == 1) { + template <- sub( + "width: auto;", + sprintf("table-layout: fixed; width: %s%% !important;", round(x@width * 100)), + template, + fixed = TRUE + ) + } else if (length(x@width) > 1) { + template <- sub( + "width: auto;", + sprintf("table-layout: fixed; width: %s%% !important;", round(sum(x@width) * 100)), + template, + fixed = TRUE + ) + } + + # (pseudo-)unique table IDs + id <- get_id("") + x@id <- id + + # table and styling function in JS must have different names when there is more than one table on a page. + template <- gsub("styleCell", paste0("styleCell_", id), template, fixed = TRUE) + template <- gsub("spanCell", paste0("spanCell_", id), template, fixed = TRUE) + template <- gsub("$tinytable_TABLE_ID", paste0("tinytable_", id), template, fixed = TRUE) + + # header + idx <- grep("$tinytable_BOOTSTRAP_HEADER", template, fixed = TRUE) + if (length(colnames(x)) > 0) { + header <- sprintf(' ', colnames(x)) + header <- c(" ", header, " ") + header <- paste(strrep(" ", 11), header) + } else { + header <- NULL + } + template <- c( + template[1:(idx - 1)], + header, + template[(idx + 1):length(template)] ) - } else if (length(x@width) > 1) { - template <- sub( - "width: auto;", - sprintf('table-layout: fixed; width: %s%% !important;', round(sum(x@width) * 100)), - template, - fixed = TRUE + # body + makerow <- function(k) { + out <- c( + " ", + sprintf(" ", k), + " " + ) + 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)] ) - } - # (pseudo-)unique table IDs - id <- get_id("") - x@id <- id - - # table and styling function in JS must have different names when there is more than one table on a page. - template <- gsub("styleCell", paste0("styleCell_", id), template, fixed = TRUE) - template <- gsub("spanCell", paste0("spanCell_", id), template, fixed = TRUE) - template <- gsub("$tinytable_TABLE_ID", paste0("tinytable_", id), template, fixed = TRUE) - - # header - idx <- grep("$tinytable_BOOTSTRAP_HEADER", template, fixed = TRUE) - if (length(colnames(x)) > 0) { - header <- sprintf(' ', colnames(x)) - header <- c(" ", header, " ") - header <- paste(strrep(" ", 11), header) - } else { - header <- NULL - } - template <- c( - template[1:(idx - 1)], - header, - template[(idx + 1):length(template)] - ) - # body - makerow <- function(k) { - out <- c( - " ", - sprintf(' ', k), - " ") - 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 48c604e8..b41530dd 100644 --- a/R/tt_typst.R +++ b/R/tt_typst.R @@ -1,102 +1,105 @@ setMethod( - f = "tt_eval", - signature = "tinytable_typst", - definition = function(x, ...) { - out <- readLines(system.file("templates/typst.typ", package = "tinytable")) - out <- paste(out, collapse = "\n") + f = "tt_eval", + signature = "tinytable_typst", + definition = function(x, ...) { + 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]) - } 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, 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]) + } 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") + } + } - # 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" - ) - idx <- grep(comment, out) + out <- strsplit(x, "\n")[[1]] + comment <- switch(type, + "lines" = "tinytable lines before", + "style" = "tinytable cell style before", + "body" = "tinytable cell content after" + ) + idx <- grep(comment, out) - if (type == "body") { - out <- c(out[1:idx], content, out[(idx + 1):length(out)]) - } else { - out <- c(out[1:(idx - 1)], content, out[idx:length(out)]) - } + if (type == "body") { + out <- c(out[1:idx], content, out[(idx + 1):length(out)]) + } else { + out <- c(out[1:(idx - 1)], content, out[idx:length(out)]) + } - out <- paste(out, collapse = "\n") - return(out) + out <- paste(out, collapse = "\n") + return(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..76f5d54a 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,5 @@ .onLoad <- function(libname, pkgname) { - if(requireNamespace("knitr", quietly = TRUE)) { + if (requireNamespace("knitr", quietly = TRUE)) { registerS3method("knit_print", "tinytable", knit_print.tinytable, envir = asNamespace("knitr")) } } diff --git a/README.qmd b/README.qmd index a5a3f8ed..c3ee1200 100644 --- a/README.qmd +++ b/README.qmd @@ -20,10 +20,10 @@ ```{r, include=FALSE} db <- tools::CRAN_package_db() -dep_ke <- tools::package_dependencies(c("kableExtra"), recursive=TRUE, db=db)[[1]] |> length() -dep_hux <- tools::package_dependencies(c("huxtable"), recursive=TRUE, db=db)[[1]] |> length() -dep_dt <- tools::package_dependencies(c("DT"), recursive=TRUE, db=db)[[1]] |> length() -dep_gt <- tools::package_dependencies(c("gt"), recursive=TRUE, db=db)[[1]] |> length() +dep_ke <- tools::package_dependencies(c("kableExtra"), recursive = TRUE, db = db)[[1]] |> length() +dep_hux <- tools::package_dependencies(c("huxtable"), recursive = TRUE, db = db)[[1]] |> length() +dep_dt <- tools::package_dependencies(c("DT"), recursive = TRUE, db = db)[[1]] |> length() +dep_gt <- tools::package_dependencies(c("gt"), recursive = TRUE, db = db)[[1]] |> length() ``` There are already many excellent table-drawing packages in the `R` ecosystem. Why release a new one? As [the maintainer of `modelsummary`](https://modelsummary.com), I needed a table-drawing package which was: diff --git a/sandbox/latex.qmd b/sandbox/latex.qmd index 6ff0a1db..3256603c 100644 --- a/sandbox/latex.qmd +++ b/sandbox/latex.qmd @@ -4,12 +4,12 @@ format: pdf ```{r} pkgload::load_all() -dat = data.frame(a = c("(03.1)", "(3.14)**", "(003.1416)+")) +dat <- data.frame(a = c("(03.1)", "(3.14)**", "(003.1416)+")) tt(dat) |> style_tt(align = "d") ``` ```{r} -dat = data.frame(a = c("(03.1)", "(3.14)**", "(003.1416)+")) +dat <- data.frame(a = c("(03.1)", "(3.14)**", "(003.1416)+")) tt(dat) |> group_tt(j = list("blah" = 1)) |> style_tt(align = "d") diff --git a/sandbox/quarto_processing.qmd b/sandbox/quarto_processing.qmd index 6b24b2fb..fb16e054 100644 --- a/sandbox/quarto_processing.qmd +++ b/sandbox/quarto_processing.qmd @@ -36,4 +36,4 @@ tt(x) |> format_tt(replace = " ", quarto = TRUE) ```{r} #| eval: false tt(x) |> format_tt(replace = "+", quarto = TRUE) -``` \ No newline at end of file +``` diff --git a/sandbox/typst.qmd b/sandbox/typst.qmd index 74f9b9d4..ea19181e 100644 --- a/sandbox/typst.qmd +++ b/sandbox/typst.qmd @@ -33,7 +33,7 @@ tab ```{r} # Issue #139 tab <- tt(mtcars[1:5, 1:5]) |> - style_tt(2:3, 2:3, line_color = "red", line = "tblr", line_width = .05) + style_tt(2:3, 2:3, line_color = "red", line = "tblr", line_width = .05) tab ``` @@ -50,7 +50,8 @@ dat <- data.frame( w = c(143002.2092, 201399.181, 100188.3883), x = c(1.43402, 201.399, 0.134588), y = as.Date(c(897, 232, 198), origin = "1970-01-01"), - z = c(TRUE, TRUE, FALSE)) + z = c(TRUE, TRUE, FALSE) +) dat <- tt(dat, digits = 2) dat ``` @@ -60,7 +61,8 @@ dat 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)) + c = c(98938272783457, 7288839482, 29111727, 93945) +) tab <- tt(dat) |> format_tt(j = "a", sprintf = "Food: %s") |> format_tt(j = 2, digits = 1) |> @@ -116,7 +118,8 @@ dat <- tt(dat) |> group_tt(i = list( "I like (fake) hamburgers" = 3, "She prefers halloumi" = 4, - "They love tofu" = 7)) + "They love tofu" = 7 + )) dat ``` @@ -129,7 +132,9 @@ tab <- tt(dat) |> j = list( "Hamburgers" = 1:3, "Halloumi" = 4:5, - "Tofu" = 7)) + "Tofu" = 7 + ) + ) tab ``` @@ -146,19 +151,25 @@ tab #| warnings: false # issue #323 dat <- mtcars[1:9, 1:8] -tab <- tt(dat) |> +tab <- tt(dat) |> group_tt( - i = list("I like (fake) hamburgers" = 3, - "She prefers halloumi" = 4, - "They love tofu" = 7), - j = list("Hamburgers" = 1:3, - "Halloumi" = 4:5, - "Tofu" = 7)) |> + i = list( + "I like (fake) hamburgers" = 3, + "She prefers halloumi" = 4, + "They love tofu" = 7 + ), + j = list( + "Hamburgers" = 1:3, + "Halloumi" = 4:5, + "Tofu" = 7 + ) + ) |> style_tt( i = c(3, 5, 9), align = "c", background = "black", - color = "orange") |> + color = "orange" + ) |> style_tt(i = -1, color = "orange") tab ``` @@ -186,7 +197,8 @@ tt(head(iris), notes = "blah") dat <- data.frame( a = c("a", "aa", "aaa"), b = c("b", "bb", "bbb"), - c = c("c", "cc", "ccc")) + c = c("c", "cc", "ccc") +) tt(dat) ``` ```{r} diff --git a/tests/tinytest.R b/tests/tinytest.R index 09bf3bf6..c4b167e7 100644 --- a/tests/tinytest.R +++ b/tests/tinytest.R @@ -1,5 +1,3 @@ - -if ( requireNamespace("tinytest", quietly=TRUE) ){ +if (requireNamespace("tinytest", quietly = TRUE)) { tinytest::test_package("tinytable") } - diff --git a/vignettes/alternatives.qmd b/vignettes/alternatives.qmd index 94e62c43..f02441f0 100644 --- a/vignettes/alternatives.qmd +++ b/vignettes/alternatives.qmd @@ -29,12 +29,12 @@ How does `tinytable` compare to alternative table-drawing packages in `R`? There ```{r, include=FALSE} db <- tools::CRAN_package_db() -dep_kableExtra <- length(tools::package_dependencies("kableExtra", recursive=TRUE, db=db)[[1]]) -dep_gt <- length(tools::package_dependencies("gt", recursive=TRUE, db=db)[[1]]) -dep_flextable <- length(tools::package_dependencies("flextable", recursive=TRUE, db=db)[[1]]) -dep_huxtable <- length(tools::package_dependencies("huxtable", recursive=TRUE, db=db)[[1]]) -dep_DT <- length(tools::package_dependencies("DT", recursive=TRUE, db=db)[[1]]) -dep_reactable <- length(tools::package_dependencies("reactable", recursive=TRUE, db=db)[[1]]) +dep_kableExtra <- length(tools::package_dependencies("kableExtra", recursive = TRUE, db = db)[[1]]) +dep_gt <- length(tools::package_dependencies("gt", recursive = TRUE, db = db)[[1]]) +dep_flextable <- length(tools::package_dependencies("flextable", recursive = TRUE, db = db)[[1]]) +dep_huxtable <- length(tools::package_dependencies("huxtable", recursive = TRUE, db = db)[[1]]) +dep_DT <- length(tools::package_dependencies("DT", recursive = TRUE, db = db)[[1]]) +dep_reactable <- length(tools::package_dependencies("reactable", recursive = TRUE, db = db)[[1]]) ``` Here are a few totally biased (and possibly unfair) comments about each of them. diff --git a/vignettes/custom.qmd b/vignettes/custom.qmd index 6e15d67a..1a3a68d4 100644 --- a/vignettes/custom.qmd +++ b/vignettes/custom.qmd @@ -49,7 +49,8 @@ We can also combine several Bootstrap classes. Here, we get a table with the "ho ```{r, eval = knitr::is_html_output()} tt(x) |> style_tt( - bootstrap_class = "table table-hover") + bootstrap_class = "table table-hover" +) ``` @@ -112,12 +113,13 @@ css_rule <- " } " -tt(x, width = 2/3) |> +tt(x, width = 2 / 3) |> style_tt( j = 1:5, align = "ccccc", bootstrap_class = "table mytable", - bootstrap_css_rule = css_rule) + bootstrap_css_rule = css_rule + ) ``` @@ -136,8 +138,9 @@ css <- " tt(mtcars[1:10, 1:8]) |> style_tt( - bootstrap_class = "table table-borderless squirreltable", - bootstrap_css_rule = css) + bootstrap_class = "table table-borderless squirreltable", + bootstrap_css_rule = css + ) ``` ::: @@ -208,7 +211,7 @@ The Inner block, enclosed in `{}`, defines specific styles like column formats ( We can create this code easily by passing a string to the `tabularray_inner` argument of the `style_tt()` function: ```{r, eval = knitr::is_latex_output()} -##| tbl-cap: "\\LaTeX{} table with colors and a spanning cell." +## | tbl-cap: "\\LaTeX{} table with colors and a spanning cell." inner <- " column{1-4}={halign=c}, hlines = {fg=white}, @@ -354,15 +357,18 @@ library("shiny") library("tinytable") fn <- paste(tempfile(), ".html") -tab <- tt(mtcars[1:5, 1:4]) |> - style_tt(i = 0:5, color = "orange", background = "black") |> - save_tt(fn) +tab <- tt(mtcars[1:5, 1:4]) |> + style_tt(i = 0:5, color = "orange", background = "black") |> + save_tt(fn) shinyApp( ui = fluidPage( - fluidRow(column(12, h1("This is test of tinytable"), - shiny::includeHTML(fn)))), - server = function(input, output) { + fluidRow(column( + 12, h1("This is test of tinytable"), + shiny::includeHTML(fn) + )) + ), + server = function(input, output) { } ) ``` diff --git a/vignettes/format.qmd b/vignettes/format.qmd index a8721edf..c7eb122e 100644 --- a/vignettes/format.qmd +++ b/vignettes/format.qmd @@ -33,10 +33,11 @@ In a very simple case---such as printing 2 significant digits of all numeric var ```{r} dat <- data.frame( - w = c(143002.2092, 201399.181, 100188.3883), - x = c(1.43402, 201.399, 0.134588), - y = as.Date(sample(1:1000, 3), origin = "1970-01-01"), - z = c(TRUE, TRUE, FALSE)) + w = c(143002.2092, 201399.181, 100188.3883), + x = c(1.43402, 201.399, 0.134588), + y = as.Date(sample(1:1000, 3), origin = "1970-01-01"), + z = c(TRUE, TRUE, FALSE) +) tt(dat, digits = 2) ``` @@ -44,27 +45,30 @@ tt(dat, digits = 2) We can get more fine-grained control over formatting by calling `format_tt()` after `tt()`, optionally by specifying the columns to format with `j`: ```{r} -tt(dat) |> +tt(dat) |> format_tt( j = 2:4, digits = 1, - date = "%B %d %Y") |> + date = "%B %d %Y" + ) |> format_tt( j = 1, digits = 2, num_mark_big = " ", num_mark_dec = ",", num_zero = TRUE, - num_fmt = "decimal") + num_fmt = "decimal" + ) ``` We can use a regular expression in `j` to select columns, and the `?sprintf` function to format strings, numbers, and to do [string interpolation](https://en.wikipedia.org/wiki/String_interpolation) (similar to the `glue` package, but using Base `R`): ```{r} 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) |> @@ -199,8 +203,8 @@ LaTeX and HTML use special characters to indicate strings which should be interp ```{r} 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) @@ -217,10 +221,10 @@ format_tt("_ Dollars $", escape = "latex") Markdown can be rendered in cells by using the `markdown` argument of the `format_tt()` function (note: this requires installing the `markdown` as an optional dependency). ```{r} -dat <- data.frame( markdown = c( +dat <- data.frame(markdown = c( "This is _italic_ text.", - "This sentence ends with a superscript.^2^") -) + "This sentence ends with a superscript.^2^" +)) tt(dat) |> format_tt(j = 1, markdown = TRUE) |> @@ -269,7 +273,7 @@ tt(dat) |> format_tt(j = 1, markdown = TRUE) On top of the built-in features of `format_tt`, a custom formatting function can be specified via the `fn` argument. The `fn` argument takes a function that accepts a single vector and returns a string (or something that coerces to a string like a number). ```{r} -tt(x) |> +tt(x) |> format_tt(j = "mpg", fn = function(x) paste(x, "mi/gal")) |> format_tt(j = "drat", fn = \(x) signif(x, 2)) ``` @@ -290,9 +294,9 @@ thumbdrives <- data.frame( tt(thumbdrives) |> format_tt(j = 1, fn = scales::label_date("%e %b", locale = "fr")) |> format_tt(j = 2, fn = scales::label_currency()) |> - format_tt(j = 3, fn = scales::label_ordinal()) |> - format_tt(j = 4, fn = scales::label_bytes()) |> - format_tt(j = 5, fn = scales::label_percent()) |> + format_tt(j = 3, fn = scales::label_ordinal()) |> + format_tt(j = 4, fn = scales::label_bytes()) |> + format_tt(j = 5, fn = scales::label_percent()) |> format_tt(escape = TRUE) ``` diff --git a/vignettes/group.qmd b/vignettes/group.qmd index b52ba90e..d61adea5 100644 --- a/vignettes/group.qmd +++ b/vignettes/group.qmd @@ -53,18 +53,21 @@ tt(head(iris)) |> We can style group rows in the same way as regular rows: ```{r} -tt(dat) |> +tt(dat) |> group_tt( i = list( "I like (fake) hamburgers" = 3, "She prefers halloumi" = 4, - "They love tofu" = 7)) |> + "They love tofu" = 7 + ) + ) |> style_tt( i = c(3, 5, 9), align = "c", color = "white", background = "gray", - bold = TRUE) + bold = TRUE + ) ``` ### Automatic row groups @@ -73,7 +76,9 @@ We can use the `group_tt()` function to group rows and label them using spanners ```{r} # subset and sort data -df <- mtcars |> head(10) |> sort_by(~ am) +df <- mtcars |> + head(10) |> + sort_by(~am) # draw table tt(df) |> group_tt(i = df$am) @@ -85,7 +90,7 @@ tt(df) |> group_tt(i = df$am) The syntax for column groups is very similar, but we use the `j` argument instead. The named list specifies the labels to appear in column-spanning labels, and the values must be a vector of consecutive and non-overlapping integers that indicate which columns are associated to which labels: ```{r} -tt(dat) |> +tt(dat) |> group_tt( j = list( "Hamburgers" = 1:3, @@ -97,19 +102,25 @@ Here is a table with both row and column headers, as well as some styling: ```{r} dat <- mtcars[1:9, 1:8] -tt(dat) |> +tt(dat) |> group_tt( - i = list("I like (fake) hamburgers" = 3, - "She prefers halloumi" = 4, - "They love tofu" = 7), - j = list("Hamburgers" = 1:3, - "Halloumi" = 4:5, - "Tofu" = 7)) |> + i = list( + "I like (fake) hamburgers" = 3, + "She prefers halloumi" = 4, + "They love tofu" = 7 + ), + j = list( + "Hamburgers" = 1:3, + "Halloumi" = 4:5, + "Tofu" = 7 + ) + ) |> style_tt( i = c(3, 5, 9), align = "c", background = "teal", - color = "white") |> + color = "white" + ) |> style_tt(i = -1, color = "teal") ``` diff --git a/vignettes/notebooks.qmd b/vignettes/notebooks.qmd index 985fe242..4e8cd233 100644 --- a/vignettes/notebooks.qmd +++ b/vignettes/notebooks.qmd @@ -69,7 +69,7 @@ See @apptbl-testing ```{r} library(tinytable) -tt(mtcars[1:5,]) |> theme_tt("tabular", style = "tabularray") +tt(mtcars[1:5, ]) |> theme_tt("tabular", style = "tabularray") ``` Caption goes here. @@ -91,7 +91,7 @@ See @tbl-example, @tbl-example-1, or @tbl-example-2. ```{r} #| label: tbl-example #| tbl-cap: "Example" -#| tbl-subcap: +#| tbl-subcap: #| - "Cars" #| - "Pressure" #| layout-ncol: 2 @@ -200,8 +200,8 @@ Table \@ref(tab:tinytableref) ```{r} library(tinytable) -tt(head(iris), caption = "(#tab:tinytableref) Hello world!") |> - style_tt(color = "blue") +tt(head(iris), caption = "(#tab:tinytableref) Hello world!") |> + style_tt(color = "blue") ``` ```` diff --git a/vignettes/plot.qmd b/vignettes/plot.qmd index eb289b92..f0feb46e 100644 --- a/vignettes/plot.qmd +++ b/vignettes/plot.qmd @@ -73,7 +73,7 @@ There are several types of inline plots available by default. For example, plot_data <- list(mtcars$mpg, mtcars$hp, mtcars$qsec) dat <- data.frame( - Variables = c("mpg", "hp", "qsec"), + Variables = c("mpg", "hp", "qsec"), Histogram = "", Density = "", Bar = "", @@ -124,10 +124,10 @@ library(ggplot2) f <- function(d, color = "black", ...) { d <- data.frame(x = d) - ggplot(d, aes(x = x)) + + ggplot(d, aes(x = x)) + geom_histogram(bins = 30, color = color, fill = color) + - scale_x_continuous(expand=c(0,0)) + - scale_y_continuous(expand=c(0,0)) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(expand = c(0, 0)) + theme_void() } @@ -144,7 +144,8 @@ We can insert arbitrarily complex plots by customizing the `ggplot2` call: #| warning: false penguins <- read.csv( "https://vincentarelbundock.github.io/Rdatasets/csv/palmerpenguins/penguins.csv", - na.strings = "") |> na.omit() + na.strings = "" +) |> na.omit() # split data by species dat <- split(penguins, penguins$species) @@ -164,8 +165,8 @@ tab <- data.frame( f <- function(d, ...) { ggplot(d, aes(x = flipper_length_mm, y = body_mass_g, color = sex)) + geom_point(size = .2) + - scale_x_continuous(expand=c(0,0)) + - scale_y_continuous(expand=c(0,0)) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(expand = c(0, 0)) + scale_color_manual(values = c("#E69F00", "#56B4E9")) + theme_void() + theme(legend.position = "none") @@ -176,7 +177,7 @@ tt(tab) |> plot_tt(j = 2, fun = "histogram", data = body, height = 2) |> plot_tt(j = 3, fun = "density", data = flip, height = 2) |> plot_tt(j = 4, fun = f, data = dat, height = 2) |> - style_tt(j = 2:4, align = "c") + style_tt(j = 2:4, align = "c") ``` diff --git a/vignettes/style.qmd b/vignettes/style.qmd index 9465740c..47e2a957 100644 --- a/vignettes/style.qmd +++ b/vignettes/style.qmd @@ -54,7 +54,8 @@ tt(x) |> i = 2, j = 3, background = "black", - color = "white") + color = "white" + ) ``` The `i` and `j` accept vectors of integers to modify several cells at once: @@ -65,7 +66,8 @@ tt(x) |> i = 2:3, j = c(1, 3, 4), italic = TRUE, - color = "orange") + color = "orange" + ) ``` We can style all cells in a table by omitting both the `i` and `j` arguments: @@ -104,7 +106,7 @@ tt(x) |> style_tt(j = "^(?!drat|mpg)", color = "orange") Of course, we can also call the `style_tt()` function several times to apply different styles to different parts of the table: ```{r} -tt(x) |> +tt(x) |> style_tt(i = 1, j = 1:2, color = "orange") |> style_tt(i = 1, j = 3:4, color = "green") ``` @@ -143,7 +145,8 @@ To align columns, we use a single character, or a string where each letter repre dat <- data.frame( a = c("a", "aa", "aaa"), b = c("b", "bb", "bbb"), - c = c("c", "cc", "ccc")) + c = c("c", "cc", "ccc") +) tt(dat) |> style_tt(j = 1:3, align = "c") @@ -155,8 +158,8 @@ In LaTeX documents (only), we can use decimal-alignment: ```{r} z <- data.frame(pi = c(pi * 100, pi * 1000, pi * 10000, pi * 100000)) tt(z) |> - format_tt(j = 1, digits = 8, num_fmt = "significant_cell") |> - style_tt(j = 1, align = "d") + format_tt(j = 1, digits = 8, num_fmt = "significant_cell") |> + style_tt(j = 1, align = "d") ``` @@ -173,7 +176,7 @@ tt(x) |> style_tt(j = "mpg|hp|qsec", fontsize = 1.5) Sometimes, it can be useful to make a cell stretch across multiple colums or rows, for example when we want to insert a label. To achieve this, we can use the `colspan` argument. Here, we make the 2nd cell of the 2nd row stretch across three columns and two rows: ```{r} -tt(x)|> style_tt( +tt(x) |> style_tt( i = 2, j = 2, colspan = 3, rowspan = 2, @@ -181,7 +184,8 @@ tt(x)|> style_tt( alignv = "m", color = "white", background = "black", - bold = TRUE) + bold = TRUE +) ``` Here is the original table for comparison: @@ -194,7 +198,7 @@ Spanning cells can be particularly useful when we want to suppress redundant lab ```{r} tab <- aggregate(mpg ~ cyl + am, FUN = mean, data = mtcars) -tab <- tab[order(tab$cyl, tab$am),] +tab <- tab[order(tab$cyl, tab$am), ] tab tt(tab, digits = 2) |> @@ -207,15 +211,15 @@ The `rowspan` feature is also useful to create multi-row labels. For example, in tab <- data.frame(Letters = c("A
B", ""), Numbers = c("First", "Second")) tt(tab) |> - style_tt(bootstrap_class = "table-bordered") + style_tt(bootstrap_class = "table-bordered") ``` Now, we use `colspan` to ensure that that cells in the first column take up less space and are combined into one: ```{r} tt(tab) |> - style_tt(bootstrap_class = "table-bordered") |> - style_tt(1, 1, rowspan = 2) + style_tt(bootstrap_class = "table-bordered") |> + style_tt(1, 1, rowspan = 2) ``` ## Headers @@ -248,11 +252,12 @@ We can use the standard `which` function from Base `R` to create indices and app ```{r} k <- mtcars[1:10, c("mpg", "am", "vs")] -tt(k) |> +tt(k) |> style_tt( i = which(k$am == k$vs), background = "teal", - color = "white") + color = "white" + ) ``` In versions *above* 0.4.0 of `tinytable`, users can also supply a logical matrix of the same size as `x` to indicate which cell should be styled. For example, we can change the colors of certain entries in a correlation matrix as follows: @@ -272,7 +277,8 @@ The `color`, `background`, and `fontsize` arguments are vectorized. This allows tt(x) |> style_tt( i = 1:4, - color = c("red", "blue", "green", "orange")) + color = c("red", "blue", "green", "orange") + ) ``` When using a single value for a vectorized argument, it gets applied to all values: @@ -282,7 +288,8 @@ tt(x) |> style_tt( j = 2:3, color = c("orange", "green"), - background = "black") + background = "black" + ) ``` We can also produce more complex heatmap-like tables to illustrate different font sizes in em units: @@ -307,7 +314,8 @@ tt(k, width = .7, theme = "void") |> j = 1:5, color = fg, background = bg, - fontsize = fs) + fontsize = fs + ) ``` @@ -328,21 +336,22 @@ Here is an example where we draw lines around every border ("t", "b", "l", and " ```{r} tt(x, theme = "void") |> - style_tt( - i = 0:3, - j = 1:3, - line = "tblr", - line_width = 0.4, - line_color = "orange") + style_tt( + i = 0:3, + j = 1:3, + line = "tblr", + line_width = 0.4, + line_color = "orange" + ) ``` And here is an example with horizontal rules: ```{r} tt(x, theme = "void") |> - style_tt(i = 0, line = "t", line_color = "orange", line_width = 0.4) |> - style_tt(i = 1, line = "t", line_color = "purple", line_width = 0.2) |> - style_tt(i = 4, line = "b", line_color = "orange", line_width = 0.4) + style_tt(i = 0, line = "t", line_color = "orange", line_width = 0.4) |> + style_tt(i = 1, line = "t", line_color = "purple", line_width = 0.2) |> + style_tt(i = 4, line = "b", line_color = "orange", line_width = 0.4) ``` @@ -350,10 +359,11 @@ tt(x, theme = "void") |> dat <- data.frame(1:2, 3:4, 5:6, 7:8) colnames(dat) <- NULL -tt(dat, theme = "void") |> +tt(dat, theme = "void") |> style_tt( line = "tblr", line_color = "white", line_width = 0.5, - background = "blue", color = "white") + background = "blue", color = "white" + ) ``` ## Markdown and Word diff --git a/vignettes/theme.qmd b/vignettes/theme.qmd index ad2e2369..216a07b3 100644 --- a/vignettes/theme.qmd +++ b/vignettes/theme.qmd @@ -60,7 +60,7 @@ Users can also define their own themes to apply consistent visual tweaks to tabl ```{r} theme_vincent <- function(x, ...) { - out <- x |> + out <- x |> style_tt(color = "teal") out@caption <- "Always use the same caption." out@width <- .5 @@ -82,14 +82,14 @@ Here is a slightly more complex example. The benefit of this approach is that we ```{r} #| eval: false theme_slides <- function(x, ...) { - fn <- function(table) { - if (isTRUE(table@output == "typst")) { - table@table_string <- paste0("#figure([\n", table@table_string, "\n])") - } - return(table) + fn <- function(table) { + if (isTRUE(table@output == "typst")) { + table@table_string <- paste0("#figure([\n", table@table_string, "\n])") } - x <- style_tt(x, finalize = fn) - return(x) + return(table) + } + x <- style_tt(x, finalize = fn) + return(x) } tt(head(iris), theme = theme_slides) @@ -101,7 +101,9 @@ tt(head(iris), theme = theme_slides) The `tabular` theme is designed to provide a more "raw" table, without a floating table environment in LaTeX, and without CSS or Javascript in HTML. ```{r tabular-theme} -tt(x) |> theme_tt("tabular") |> print("latex") +tt(x) |> + theme_tt("tabular") |> + print("latex") ``` @@ -115,7 +117,7 @@ LaTeX only. The `resize` theme allows you to adjust the size of the table in LaTeX outputs, making it fit within a specified width of the page. This is useful for large tables that need to be scaled down to fit the document layout. This table will be scaled to 90% of the available line width, ensuring it fits nicely within the document. ```{r} -tmp <- cbind(mtcars, mtcars)[1:10,] +tmp <- cbind(mtcars, mtcars)[1:10, ] tt(tmp) |> theme_tt("resize", width = .9) ``` @@ -145,7 +147,7 @@ tt(x) |> ## Rotate ```{r} -tt(head(iris), caption = "Rotated table.") |> +tt(head(iris), caption = "Rotated table.") |> theme_tt("rotate", angle = 45) ``` ::: @@ -165,8 +167,8 @@ tmp <- rbind(mtcars, mtcars)[, 1:6] cap <- "A long 80\\% width table with repeating headers." -tt(tmp, width = .8, caption = cap) |> - theme_tt("multipage", rowhead = 1) +tt(tmp, width = .8, caption = cap) |> + theme_tt("multipage", rowhead = 1) ``` ::: diff --git a/vignettes/tinytable.qmd b/vignettes/tinytable.qmd index 00aedc0f..cd0039ed 100644 --- a/vignettes/tinytable.qmd +++ b/vignettes/tinytable.qmd @@ -21,7 +21,8 @@ Install the latest version from R-Universe or CRAN: ```{r, eval = FALSE} install.packages("tinytable", - repos = c("https://vincentarelbundock.r-universe.dev", "https://cran.r-project.org")) + repos = c("https://vincentarelbundock.r-universe.dev", "https://cran.r-project.org") +) ``` This tutorial introduces the main functions of the package. It is also [available as a single PDF document.](tinytable_tutorial.pdf) @@ -74,7 +75,7 @@ lorem <- data.frame( Ipsum = " Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos." ) -tt(lorem, width = 3/4) +tt(lorem, width = 3 / 4) ``` @@ -99,10 +100,9 @@ We can also add markers in individual cells by providing coordinates: ```{r} tt(x, notes = list( - a = list(i = 0:1, j = 1, text = "Blah."), - b = "Blah blah." - ) -) + a = list(i = 0:1, j = 1, text = "Blah."), + b = "Blah blah." +)) ``` @@ -201,10 +201,13 @@ tt(mtcars[1:10, 1:5]) |> group_tt( i = list( "Hello" = 3, - "World" = 8), + "World" = 8 + ), j = list( "Foo" = 2:3, - "Bar" = 4:5)) |> + "Bar" = 4:5 + ) + ) |> print("markdown") ``` @@ -213,10 +216,13 @@ tt(mtcars[1:10, 1:5]) |> group_tt( i = list( "Hello" = 3, - "World" = 8), + "World" = 8 + ), j = list( "Foo" = 2:3, - "Bar" = 4:5)) |> + "Bar" = 4:5 + ) + ) |> save_tt("markdown") ``` @@ -238,7 +244,7 @@ Tables can be combined with the usual `rbind()` function: ```{r} a <- tt(mtcars[1:3, 1:2], caption = "Combine two tiny tables.") -b <- tt(mtcars[4:5, 8:10]) +b <- tt(mtcars[4:5, 8:10]) rbind(a, b) @@ -274,7 +280,7 @@ In a pipe-based workflow, we can use the `setNames()` function from base `R`: ```{r} mtcars[1:2, 1:2] |> - tt() |> - setNames(c("a", "b")) + tt() |> + setNames(c("a", "b")) ``` From f00fc289bbd2a519fb6feb4c4c6c692fca878f7e Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Tue, 10 Dec 2024 06:27:42 -0500 Subject: [PATCH 07/12] docs --- R/group_tt.R | 4 +-- R/style_tt.R | 15 +++------ R/tt.R | 6 ++-- man-roxygen/limitations_word_markdown.R | 8 +++++ man/group_tt.Rd | 17 ++++++++-- man/style_tt.Rd | 45 +++++++++++++++---------- man/tt.Rd | 19 ++++++++--- 7 files changed, 75 insertions(+), 39 deletions(-) create mode 100644 man-roxygen/limitations_word_markdown.R diff --git a/R/group_tt.R b/R/group_tt.R index 2c96352c..ce198c6b 100644 --- a/R/group_tt.R +++ b/R/group_tt.R @@ -11,6 +11,7 @@ #' @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 @@ -19,8 +20,7 @@ #' dat <- data.frame( #' label = c("a", "a", "a", "b", "b", "c", "a", "a"), #' x1 = rnorm(8), -#' x2 = rnorm(8) -#' ) +#' x2 = rnorm(8)) #' tt(dat[, 2:3]) |> group_tt(i = dat$label) #' #' # named lists of labels diff --git a/R/style_tt.R b/R/style_tt.R index 2bc6bea9..b905e7b1 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -3,8 +3,6 @@ #' @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 j Column indices where the styling should be applied. Can be: @@ -49,6 +47,7 @@ #' @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 @@ -85,8 +84,7 @@ #' alignv = "m", #' color = "white", #' background = "black", -#' bold = TRUE -#' ) +#' bold = TRUE) #' #' tt(mtcars[1:5, 1:6], theme = "void") |> #' style_tt( @@ -94,16 +92,14 @@ #' j = 1:3, #' line = "tblr", #' line_width = 0.4, -#' line_color = "teal" -#' ) +#' line_color = "teal") #' #' tt(mtcars[1:5, 1:6], theme = "bootstrap") |> #' style_tt( #' i = c(2, 5), #' j = 3, #' strikeout = TRUE, -#' fontsize = 0.7 -#' ) +#' fontsize = 0.7) #' #' tt(mtcars[1:5, 1:6]) |> #' style_tt(bootstrap_class = "table table-dark table-hover") @@ -159,8 +155,7 @@ style_tt <- function(x, 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 - ) + bootstrap_css_rule = bootstrap_css_rule) if (isTRUE(i %in% c("notes", "caption"))) { tmp <- list( diff --git a/R/tt.R b/R/tt.R index 4ba8d595..3af842e7 100644 --- a/R/tt.R +++ b/R/tt.R @@ -17,6 +17,8 @@ #' @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 = ", ")` @@ -34,6 +36,7 @@ #' 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 @@ -45,8 +48,7 @@ #' tt(x, #' theme = "striped", #' width = 0.5, -#' caption = "Data about cars." -#' ) +#' caption = "Data about cars.") #' #' tt(x, notes = "Hello World!") #' diff --git a/man-roxygen/limitations_word_markdown.R b/man-roxygen/limitations_word_markdown.R new file mode 100644 index 00000000..4c668ad5 --- /dev/null +++ b/man-roxygen/limitations_word_markdown.R @@ -0,0 +1,8 @@ +#' @section Word and Markdown limitations: +#' +#' Markdown and Word tables only support these styles: italic, bold, strikeout. The `width` arugment is also unavailable +#' 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. diff --git a/man/group_tt.Rd b/man/group_tt.Rd index e7fd6d23..082335b6 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} arugment 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/style_tt.Rd b/man/style_tt.Rd index f6c48004..bdd077fe 100644 --- a/man/style_tt.Rd +++ b/man/style_tt.Rd @@ -123,9 +123,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} arugment 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 +145,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 +167,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/tt.Rd b/man/tt.Rd index ad8638ef..ae6bcae3 100644 --- a/man/tt.Rd +++ b/man/tt.Rd @@ -98,6 +98,17 @@ 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} arugment 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}{ @@ -169,9 +180,9 @@ 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!") @@ -180,6 +191,6 @@ 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) } From 84d5e418c30abfa87a085311a024c4122f97c845 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Tue, 10 Dec 2024 06:37:28 -0500 Subject: [PATCH 08/12] typo --- man-roxygen/limitations_word_markdown.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man-roxygen/limitations_word_markdown.R b/man-roxygen/limitations_word_markdown.R index 4c668ad5..1851e7da 100644 --- a/man-roxygen/limitations_word_markdown.R +++ b/man-roxygen/limitations_word_markdown.R @@ -1,6 +1,6 @@ #' @section Word and Markdown limitations: #' -#' Markdown and Word tables only support these styles: italic, bold, strikeout. The `width` arugment is also unavailable +#' Markdown and Word tables only support these styles: italic, bold, strikeout. The `width` argument is also unavailable #' 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 From 006835ff0ac1a96530bba8834e1f746baf08bcc4 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Wed, 11 Dec 2024 06:43:35 -0500 Subject: [PATCH 09/12] issue #403 : consolidate global options documentation --- altdoc/quarto_website.yml | 1 - man-roxygen/global_options.R | 110 ++++++++++++++++++++++-------- man/format_tt.Rd | 123 +++++++++++++++++++++++++--------- man/group_tt.Rd | 2 +- man/save_tt.Rd | 125 ++++++++++++++++++++++++++--------- man/style_tt.Rd | 2 +- man/tt.Rd | 125 ++++++++++++++++++++++++++--------- vignettes/options.qmd | 120 --------------------------------- 8 files changed, 361 insertions(+), 247 deletions(-) delete mode 100644 vignettes/options.qmd diff --git a/altdoc/quarto_website.yml b/altdoc/quarto_website.yml index cf8a5bb9..462a8ad5 100644 --- a/altdoc/quarto_website.yml +++ b/altdoc/quarto_website.yml @@ -20,7 +20,6 @@ website: - vignettes/plot.qmd - vignettes/theme.qmd - vignettes/custom.qmd - - vignettes/options.qmd - vignettes/notebooks.qmd - vignettes/faq.qmd - text: Tutorial (PDF) diff --git a/man-roxygen/global_options.R b/man-roxygen/global_options.R index 520fe5af..c2b845ae 100644 --- a/man-roxygen/global_options.R +++ b/man-roxygen/global_options.R @@ -1,49 +1,101 @@ #' #' @section Global options: #' -#' Many global options can be used to set the default argument values of `tinytable` functions. -#' For a full list, see: +#' Options can be set with `options()` and change the default behavior of tinytable. For example: #' -#' https://vincentarelbundock.github.io/tinytable/vignettes/options.html +#' ```r +#' options(tinytable_tt_digits = 4) +#' tt(head(iris)) +#' ``` #' -#' ## Quarto +#' You can set options in a script or via `.Rprofile`. Note: be cautious with `.Rprofile` settings as they may affect reproducibility. #' -#' ### Figure environment +#' ## Default values for function arguments #' -#' * `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. -#' * `options(tinytable_print_rstudio_notebook = "inline")`: Display tables "inline" or in the "viewer" in RStudio notebooks. +#' ### tt() #' -#' ### Data Processing +#' * `tinytable_tt_digits` +#' * `tinytable_tt_caption` +#' * `tinytable_tt_notes` +#' * `tinytable_tt_width` +#' * `tinytable_tt_theme` +#' * `tinytable_tt_rownames` #' -#' The `format_tt(quarto=TRUE)` argument activates Quarto data processing for specific cells. This funcationality comes with a few warnings: +#' ### format_tt() #' -#' 1. Currently, Quarto provides a `\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. -#' 2. Quarto data processing can enter in conflict with `tinytable` styling or formatting options. See below for how to disable it. +#' * `tinytable_format_digits` +#' * `tinytable_format_num_fmt` +#' * `tinytable_format_num_zero` +#' * `tinytable_format_num_suffix` +#' * `tinytable_format_num_mark_big` +#' * `tinytable_format_num_mark_dec` +#' * `tinytable_format_date` +#' * `tinytable_format_bool` +#' * `tinytable_format_other` +#' * `tinytable_format_replace` +#' * `tinytable_format_escape` +#' * `tinytable_format_markdown` +#' * `tinytable_format_quarto` +#' * `tinytable_format_fn` +#' * `tinytable_format_sprintf` #' -#' `options(tinytable_quarto_disable_processing = TRUE)` +#' ### save_tt() #' -#' Disable Quarto processing of cell content. Setting this global option to `FALSE` may lead to conflicts with some `tinytable` features, but it also allows use of markdown and Quarto-specific code in table cells, such as cross-references. +#' * `tinytable_save_overwrite` #' -#' ```r -#' x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") -#' fn <- function(z) sprintf("", z) -#' tt(x) |> format_tt(i = 1, fn = fn) -#' ``` +#' ### theme_tt() +#' +#' Placement: +#' * `tinytable_theme_placement_float` +#' * `tinytable_theme_placement_horizontal` +#' +#' Resize: +#' * `tinytable_theme_resize_width` +#' * `tinytable_theme_resize_direction` +#' +#' Multipage: +#' * `tinytable_theme_multipage_rowhead` +#' * `tinytable_theme_multipage_rowfoot` +#' +#' Tabular: +#' * `tinytable_theme_tabular_style` +#' +#' ### print.tinytable() +#' +#' * `tinytable_print_output` #' -#' See this link for more details: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing +#' ## Output-specific options #' -#' ## HTML +#' ### HTML #' -#' * `options(tinytable_html_mathjax = TRUE)` -#' - insert MathJax scripts in the HTML document. Warning: This may conflict with other elements of the page if MathJax is otherwise loaded. -#' * `options(tinytable_html_portable = TRUE)` -#' - `plot_tt()` inserts base 64 encoded images directly in the HTML file rather than use external links. +#' * `tinytable_html_mathjax`: Insert MathJax scripts (warning: may conflict if MathJax is loaded elsewhere) +#' * `tinytable_html_portable`: Insert base64 encoded images directly in HTML for `plot_tt()` #' -#' ## PDF +#' ### PDF #' -#' * `options(tinytable_pdf_clean = TRUE)` -#' - deletes temporary and log files. -#' * `options(tinytable_pdf_engine = "xelatex")` -#' - "xelatex", "pdflatex", "lualatex" +#' * `tinytable_pdf_clean`: Delete temporary and log files +#' * `tinytable_pdf_engine`: Choose between "xelatex", "pdflatex", "lualatex" +#' +#' ### Quarto +#' +#' The `format_tt(quarto=TRUE)` argument enables Quarto data processing with some limitations: +#' +#' 1. The `\QuartoMarkdownBase64{}` LaTeX macro may not process references and markdown as expected +#' 2. Quarto processing may conflict with `tinytable` styling/formatting +#' +#' Options: +#' +#' * `tinytable_quarto_disable_processing`: Disable Quarto cell processing +#' * `tinytable_print_rstudio_notebook`: Display tables "inline" or in "viewer" for RStudio notebooks +#' * `tinytable_quarto_figure`: Control Typst figure environment in Quarto +#' +#' Example of Quarto-specific code in cells: +#' +#' ```r +#' x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") +#' fn <- function(z) sprintf("", z) +#' tt(x) |> format_tt(i = 1, fn = fn) +#' ``` #' +#' For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing #' diff --git a/man/format_tt.Rd b/man/format_tt.Rd index a3d50df9..7ec628df 100644 --- a/man/format_tt.Rd +++ b/man/format_tt.Rd @@ -99,64 +99,125 @@ If this function is applied several times to the same cell, the last transformat \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{
}}\preformatted{options(tinytable_tt_digits = 4) +tt(head(iris)) +}\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)} - -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{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") -fn <- function(z) sprintf("", z) -tt(x) |> format_tt(i = 1, fn = fn) -}\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" +} +} + +\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{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") +fn <- function(z) sprintf("", z) +tt(x) |> format_tt(i = 1, fn = fn) +}\if{html}{\out{
}} + +For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing } + } } diff --git a/man/group_tt.Rd b/man/group_tt.Rd index 082335b6..3e1f1653 100644 --- a/man/group_tt.Rd +++ b/man/group_tt.Rd @@ -34,7 +34,7 @@ Warning: The \code{style_tt()} can normally be used to style the group headers, \section{Word and Markdown limitations}{ -Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} arugment is also unavailable +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 diff --git a/man/save_tt.Rd b/man/save_tt.Rd index a443571a..4560a46f 100644 --- a/man/save_tt.Rd +++ b/man/save_tt.Rd @@ -63,64 +63,125 @@ Note: Your document will fail to compile to PDF in Quarto if you enable caching \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{
}}\preformatted{options(tinytable_tt_digits = 4) +tt(head(iris)) +}\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} +} +} + +\subsection{save_tt()}{ +\itemize{ +\item \code{tinytable_save_overwrite} +} } -\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. - -\if{html}{\out{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") -fn <- function(z) sprintf("", z) -tt(x) |> format_tt(i = 1, fn = fn) -}\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{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") +fn <- function(z) sprintf("", z) +tt(x) |> format_tt(i = 1, fn = fn) +}\if{html}{\out{
}} + +For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing } + } } diff --git a/man/style_tt.Rd b/man/style_tt.Rd index bdd077fe..97023bba 100644 --- a/man/style_tt.Rd +++ b/man/style_tt.Rd @@ -127,7 +127,7 @@ This function applies styling to a table created by \code{tt()}. It allows custo \section{Word and Markdown limitations}{ -Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} arugment is also unavailable +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 diff --git a/man/tt.Rd b/man/tt.Rd index ae6bcae3..52e100a6 100644 --- a/man/tt.Rd +++ b/man/tt.Rd @@ -101,7 +101,7 @@ Note: Your document will fail to compile to PDF in Quarto if you enable caching \section{Word and Markdown limitations}{ -Markdown and Word tables only support these styles: italic, bold, strikeout. The \code{width} arugment is also unavailable +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 @@ -112,64 +112,125 @@ 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{
}}\preformatted{options(tinytable_tt_digits = 4) +tt(head(iris)) +}\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)} - -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{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") -fn <- function(z) sprintf("", z) -tt(x) |> format_tt(i = 1, fn = fn) -}\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" +} +} + +\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{
}}\preformatted{x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") +fn <- function(z) sprintf("", z) +tt(x) |> format_tt(i = 1, fn = fn) +}\if{html}{\out{
}} + +For more details on Quarto table processing: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing } + } } diff --git a/vignettes/options.qmd b/vignettes/options.qmd deleted file mode 100644 index 28917663..00000000 --- a/vignettes/options.qmd +++ /dev/null @@ -1,120 +0,0 @@ -# Available Options - -Options can be set with `options()` and change the default behavior of tinytable. For example, to format all tables to 4 digits when calling `tt()`, we can do: - -```r -options(tinytable_tt_digits = 4) -tt(head(iris)) -``` - -You can either set options in a script (usually at the top) or via `.Rprofile`. Note that you want to [be cautious](https://rstats.wtf/r-startup.html) with putting things in `.Rprofile` since they might make results not reproducible (e.g. if you change `tinytable_format_digits` in `.Rprofile`, the table will be formatted differently). - -## Default values for function arguments - -Most options are function specific and allow you to set default values. These all start with `tinytable_X_` where X is `tt`/`format`/`theme`/`print`. See the corresponding help documentation for the what the argument looks like. - -### `tt()` - -Sets default values for `tt()` arguments. - -- `tinytable_tt_digits` -- `tinytable_tt_caption` -- `tinytable_tt_notes` -- `tinytable_tt_width` -- `tinytable_tt_theme` -- `tinytable_tt_rownames` - -### `format_tt()` - -Sets default formats for different kinds of variables. see `format_tt()` - -- `tinytable_format_digits` -- `tinytable_format_num_fmt` -- `tinytable_format_num_zero` -- `tinytable_format_num_suffix` -- `tinytable_format_num_mark_big` -- `tinytable_format_num_mark_dec` -- `tinytable_format_date` -- `tinytable_format_bool` -- `tinytable_format_other` -- `tinytable_format_replace` -- `tinytable_format_escape` -- `tinytable_format_markdown` -- `tinytable_format_quarto` -- `tinytable_format_fn` -- `tinytable_format_sprintf` - -### `save_tt()` - -- `tinytable_save_overwrite` - -### `theme_tt()` - -When using `theme_tt(theme = "theme_name")`, this allows you to set default arguments to the corresponding theme. See `theme_tt()` for details. - -placement: - -- `tinytable_theme_placement_float` -- `tinytable_theme_placement_horizontal` - -resize: - -- `tinytable_theme_resize_width` -- `tinytable_theme_resize_direction` - -multipage: - -- `tinytable_theme_multipage_rowhead` -- `tinytable_theme_multipage_rowfoot` - -tabular: - -- `tinytable_theme_tabular_style` - -### `print.tinytable()` - -`tinytable_print_output` - - -## Global options - -The rest of the options are a set of global options that apply when the tables are being built. - -### HTML - -* `options(tinytable_html_mathjax = TRUE)` - - insert MathJax scripts in the HTML document. Warning: This may conflict with other elements of the page if MathJax is otherwise loaded. -* `options(tinytable_html_portable = TRUE)` - - `plot_tt()` inserts base 64-encoded images directly in the HTML file rather than use external links. - -### PDF - -* `options(tinytable_pdf_clean = TRUE)` - - deletes temporary and log files. -* `options(tinytable_pdf_engine = "xelatex")` - - `"xelatex"`, `"pdflatex"`, `"lualatex"` - -### Quarto - -The `format_tt(quarto=TRUE)` argument activates Quarto data processing for specific cells. This funcationality comes with a few warnings: - -1. Currently, Quarto provides a `\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. -2. Quarto data processing can enter in conflict with `tinytable` styling or formatting options. See below for how to disable it. - -* `options(tinytable_quarto_disable_processing = TRUE)` - - disables Quarto processing of cell content. -* `options(tinytable_print_rstudio_notebook = "inline")` or `"viewer"` - - Display tables inline in the notebook or in the viewer. Inline is an RStudio-only feature. -* `options(tinytable_quarto_figure = FALSE)` - - by default, do not include Typst tables in a figure environment in Quarto. - -Setting this global option to `FALSE` may lead to conflicts with some `tinytable` features, but it also allows use of markdown and Quarto-specific code in table cells, such as cross-references. - -```r -x <- data.frame(Math = "x^2^", Citation = "@Lovelace1842") -fn <- function(z) sprintf("", z) -tt(x) |> format_tt(i = 1, fn = fn) -``` - -See this link for more details: https://quarto.org/docs/authoring/tables.html#disabling-quarto-table-processing - From da7d117a6a7c839debcd4429c9fe555b5955007c Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Thu, 12 Dec 2024 15:07:00 -0500 Subject: [PATCH 10/12] styler --- R/class.R | 1 + man/format_tt.Rd | 39 +++++++++++++----------- man/rbind2-tinytable-tinytable-method.Rd | 4 +-- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/R/class.R b/R/class.R index 88736723..6c60927c 100644 --- a/R/class.R +++ b/R/class.R @@ -16,6 +16,7 @@ setClassUnion("NULLorCharacter", c("NULL", "character")) #' tinytable S4 class #' +#' #' @keywords internal #' @export setClass( diff --git a/man/format_tt.Rd b/man/format_tt.Rd index 7ec628df..0c7374eb 100644 --- a/man/format_tt.Rd +++ b/man/format_tt.Rd @@ -224,38 +224,41 @@ For more details on Quarto table processing: https://quarto.org/docs/authoring/t \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/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 From 0752b6c5110df5f85a11b90c8782e0215f38776e Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Thu, 12 Dec 2024 15:19:43 -0500 Subject: [PATCH 11/12] typst caption --- R/style_string.R | 1 + inst/tinytest/_tinysnapshot/typst-complicated.txt | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/R/style_string.R b/R/style_string.R index c3996ef9..1e78b1eb 100644 --- a/R/style_string.R +++ b/R/style_string.R @@ -76,6 +76,7 @@ style_string_typst <- function(n, styles) { } template <- paste0("text(", paste(sty, collapse = ", "), ", [%s])") out <- sprintf(template, n) + out <- sub("text(, ", "text(", out, fixed = TRUE) return(out) } diff --git a/inst/tinytest/_tinysnapshot/typst-complicated.txt b/inst/tinytest/_tinysnapshot/typst-complicated.txt index e3ef2884..e7f7be92 100644 --- a/inst/tinytest/_tinysnapshot/typst-complicated.txt +++ b/inst/tinytest/_tinysnapshot/typst-complicated.txt @@ -1,6 +1,6 @@ #show figure: set block(breakable: true) #figure( // start figure preamble - caption: [Hello World], + caption: [text([Hello World])], kind: "tinytable", supplement: "Table", // end figure preamble From a54b815698a5840b6512194ed852e967c2e71dd0 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Thu, 12 Dec 2024 15:36:39 -0500 Subject: [PATCH 12/12] style captions and notes. Finalize --- DESCRIPTION | 2 +- NEWS.md | 2 +- R/finalize_typst.R | 2 +- R/style_tt.R | 5 ++++- inst/tinytest/_tinysnapshot/typst-complicated.txt | 2 +- man/style_tt.Rd | 7 ++++++- sandbox/typst.qmd | 7 +++++++ 7 files changed, 21 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index eb6b295a..526cba7e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: tinytable Type: Package Title: Simple and Configurable Tables in 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', and 'Typst' Formats Description: Create highly customized tables with this simple and dependency-free package. Data frames can be converted to 'HTML', 'LaTeX', 'Markdown', 'Word', 'PNG', 'PDF', or 'Typst' tables. The user interface is minimalist and easy to learn. The syntax is concise. 'HTML' tables can be customized using the flexible 'Bootstrap' framework, and 'LaTeX' code with the 'tabularray' package. -Version: 0.6.1.2 +Version: 0.6.1.3 Imports: methods Depends: diff --git a/NEWS.md b/NEWS.md index 11bcee4e..ca14fecd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,7 +8,7 @@ Bugs: New: -* `style_tt("notes")` can style footnotes. +* `style_tt("notes")` and `style_tt("caption")` can style footnotes and captions. Note: This will only style captions handled by the `caption` argument in `tt()`, and not captions created by Quarto. Misc: diff --git a/R/finalize_typst.R b/R/finalize_typst.R index 216b0334..afffef03 100644 --- a/R/finalize_typst.R +++ b/R/finalize_typst.R @@ -10,7 +10,7 @@ setMethod( cap <- x@caption if (length(cap) == 1) { - out <- sub("$TINYTABLE_TYPST_CAPTION", sprintf("caption: [%s],", cap), out, fixed = TRUE) + out <- sub("$TINYTABLE_TYPST_CAPTION", sprintf("caption: %s,", cap), out, fixed = TRUE) } else { out <- sub("$TINYTABLE_TYPST_CAPTION", "", out, fixed = TRUE) } diff --git a/R/style_tt.R b/R/style_tt.R index b905e7b1..4cec207d 100644 --- a/R/style_tt.R +++ b/R/style_tt.R @@ -4,7 +4,10 @@ #' 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. #' #' @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. diff --git a/inst/tinytest/_tinysnapshot/typst-complicated.txt b/inst/tinytest/_tinysnapshot/typst-complicated.txt index e7f7be92..dfefc85f 100644 --- a/inst/tinytest/_tinysnapshot/typst-complicated.txt +++ b/inst/tinytest/_tinysnapshot/typst-complicated.txt @@ -1,6 +1,6 @@ #show figure: set block(breakable: true) #figure( // start figure preamble - caption: [text([Hello World])], + caption: text([Hello World]), kind: "tinytable", supplement: "Table", // end figure preamble diff --git a/man/style_tt.Rd b/man/style_tt.Rd index 97023bba..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{ diff --git a/sandbox/typst.qmd b/sandbox/typst.qmd index ea19181e..0e02396e 100644 --- a/sandbox/typst.qmd +++ b/sandbox/typst.qmd @@ -11,6 +11,13 @@ options(tinytable_quarto_figure = TRUE) options(tinytable_print_output = "typst") ``` +```{r} +tt(head(iris), caption = "Hello World", notes = "This is a note") |> + style_tt("notes", color = "orange", italic = TRUE) |> + style_tt("caption", color = "green", bold = TRUE, strikeout = TRUE) +``` + + ```{r} # Semi-complicated tab <- tt(mtcars[1:4, 1:5], caption = "Hello World") |>
%s%s
%s %s
%s %s
%s %s
%s %s
%s
%s
%s
%s
%s
%s