From 84e590c92e87c9270e4fd26d498bb00508b05020 Mon Sep 17 00:00:00 2001 From: Vincent Arel-Bundock Date: Sat, 7 Dec 2024 14:40:53 -0500 Subject: [PATCH] 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) }