Meta

NAMESPACE

@@ -1,11 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(print,tinytable_bootstrap)
-S3method(print,tinytable_markdown)
-S3method(print,tinytable_tabularray)
+S3method(print,tinytable)
 export(group_tt)
-export(knit_print.tinytable_bootstrap)
-export(knit_print.tinytable_tabularray)
+export(knit_print.tinytable)
 export(save_tt)
 export(style_tt)
 export(tt)

R/group_bootstrap.R

@@ -11,12 +11,12 @@ group_bootstrap <- function(x, i, j, indent = 1, ...) {
 
 group_bootstrap_col <- function(x, i, j, ...) {
 
-  att <- attributes(x)
+  m <- meta(x)
   out <- strsplit(x, "\\n")[[1]]
   header <- NULL
 
 
-  miss <- as.list(setdiff(seq_len(attr(x, "ncol")), unlist(j)))
+  miss <- as.list(setdiff(seq_len(m$ncols), unlist(j)))
   miss <- stats::setNames(miss, rep(" ", length(miss)))
   j <- c(j, miss)
 
@@ -33,36 +33,36 @@ group_bootstrap_col <- function(x, i, j, ...) {
 
   out <- paste(out, collapse = "\n")
 
-  attributes(out) <- att
   class(out) <- class(x)
+  attr(out, "tinytable_meta") <- m
   return(out)
 }
 
 
 group_bootstrap_row <- function(x, i, j, indent = 1, ...) {
   label <- names(i)
 
+  m <- meta(x)
+
   # reverse order is important
   i <- rev(sort(i))
 
-  ncol <- attr(x, "ncol")
-  att <- attributes(x)
-  att$nrow <- att$nrow + length(label)
+
   tab <- strsplit(x, "\\n")[[1]]
   out <- x
 
   for (g in seq_along(i)) {
     js <- sprintf(
       "window.addEventListener('load', function () { insertSpanRow(%s, %s, '%s') });",
       # 0-indexing
-      i[g] + attr(x, "nhead") - 1,
-      attr(x, "ncol"),
+      i[g] + m$nhead - 1,
+      m$ncols,
       names(i)[g])
     out <- bootstrap_setting(out, new = js, component = "cell")
   }
 
   # add rows to attributes BEFORE style_tt
-  attr(out, "nrow") <- attr(out, "nrow") + length(label)
+  out <- meta(out, "nrows", m$nrows + length(label))
 
   # need unique function names in case there are
   # multiple tables in one Rmarkdown document
@@ -72,7 +72,7 @@ group_bootstrap_row <- function(x, i, j, indent = 1, ...) {
     out,
     fixed = TRUE)
 
-  idx <- insert_values(seq_len(attr(x, "nrow")), rep(NA, length(i)), i)
+  idx <- insert_values(seq_len(m$nrows), rep(NA, length(i)), i)
   idx_old <- idx$new[!is.na(idx$old)]
   idx_new <- idx$new[is.na(idx$old)]
   out <- style_tt(out, i = idx_old, j = 1, indent = indent)
@@ -84,5 +84,6 @@ group_bootstrap_row <- function(x, i, j, indent = 1, ...) {
     out <- do.call(style_tt, args)
   }
 
+  # do not override meta since we modified it here above
   return(out)
 }

R/group_tabularray.R

@@ -8,17 +8,15 @@ group_tabularray <- function(x, i, j, indent, ...) {
 }
 
 
-
-
 group_tabularray_col <- function(x, j, ...) {
 
-  dots <- list(...)
+  m <- meta(x)
 
-  att <- attributes(x)
+  dots <- list(...)
 
   out <- strsplit(x, split = "\\n")[[1]]
 
-  header <- rep("", attr(x, "ncol"))
+  header <- rep("", m$ncols)
   for (n in names(j)) {
     header[min(j[[n]])] <- n
   }
@@ -39,12 +37,11 @@ group_tabularray_col <- function(x, j, ...) {
            out[(idx + 1):length(out)])
   out <- paste(out, collapse = "\n")
 
-  attributes(out) <- att
   class(out) <- class(x)
 
   for (k in seq_along(j)) {
     z <- min(j[[k]])
-    idx <- 1 - attr(x, "nhead")
+    idx <- 1 - m$nhead
     args <- list(x = out,
                  i = idx,
                  j = z,
@@ -56,59 +53,55 @@ group_tabularray_col <- function(x, j, ...) {
     out <- do.call(style_tt, args)
   }
 
+  attr(out, "tinytable_meta") <- m
   return(out)
 
 }
 
 
 group_tabularray_row <- function(x, i, indent, ...) {
+
+  m <- meta(x)
+
   if (is.null(names(i))) {
     msg <- "`i` must be a named integer vector."
   }
   label <- names(i)
 
-  ## we don't appear to need to reverse in tabularray
-  # i <- rev(sort(i))
-
-  ncol <- attr(x, "ncol")
-  att <- attributes(x)
-  att$nrow <- att$nrow + length(label)
+  m$nrows <- m$nrows + length(label)
   tab <- strsplit(x, "\\n")[[1]]
 
   # store the original body lines when creating the table, and use those to guess the boundaries.
   # a hack, but probably safer than most regex approaches I can think of.
-  body <- which(tab %in% attr(x, "body"))
+  body <- which(tab %in% m$body)
   top <- tab[1:(min(body) - 1)]
   mid <- tab[min(body):max(body)]
   bot <- tab[(max(body) + 1):length(tab)]
 
   # separator rows
   # add separator rows so they are treated as body in future calls
-  new <- paste(label, strrep("&", ncol), "\\\\")
-  att$body <- c(att$body, new)
+  new <- paste(label, strrep("&", m$ncols), "\\\\")
+  m$body <- c(m$body, new)
   idx <- insert_values(mid, new, i)
 
   # rebuild table
   tab <- c(top, idx$vec, bot)
   tab <- paste(tab, collapse = "\n")
-  attributes(tab) <- att
+  attr(tab, "tinytable_meta") <- m
   class(tab) <- class(x)
 
-  # add rows to attributes BEFORE style_tt
-  attr(tab, "nrow") <- attr(tab, "nrow") + length(label)
-
   cellspec <- sprintf("cell{%s}{%s}={%s}{%s},",
-    idx$new[is.na(idx$old)] + attr(x, "nhead"),
+    idx$new[is.na(idx$old)] + m$nhead,
     1,
-    paste0("c=", ncol),
+    paste0("c=", m$ncols),
     ""
   )
   cellspec <- paste(cellspec, collapse = "")
   tab <- style_tabularray(tab, inner = cellspec)
 
   # we also want to indent the header
-  i <- idx$new[!is.na(idx$old)] + attr(x, "nhead")
-  if (attr(x, "nhead") > 0) i <- c(1:attr(x, "nhead"), i)
+  i <- idx$new[!is.na(idx$old)] + m$nhead 
+  if (m$nhead > 0) i <- c(1:m$nhead, i)
   cellspec <- sprintf("cell{%s}{%s}={%s},", i, 1, sprintf("preto={\\hspace{%sem}}", indent))
   cellspec <- paste(cellspec, collapse = "")
   tab <- style_tabularray(tab, inner = cellspec)

R/group_tt.R

@@ -7,11 +7,12 @@
 #' @param ... All additional arguments (ex: `italic`, `bold`, `color`) are automatically passed to the `style_tt()` function and applied to the labels.
 group_tt <- function(x, i, j, indent = 1, ...) {
 
-  out <- x
+  # sanity x
+  m <- meta(x)
+  if (is.null(m)) stop("`x` must be generated by `tinytable::tt()`.", call. = FALSE)
+  if (!isTRUE(m$output %in% c("html", "latex"))) return(x)
 
-  if (inherits(out, "tinytable_tabularray") && inherits(out, "tinytable_bootstrap")) {
-    return(x)
-  }
+  out <- x
 
   assert_integerish(indent, lower = 1)
   if ((missing(i) && missing(j)) || (!missing(i) && !missing(j))) {
@@ -21,15 +22,15 @@ group_tt <- function(x, i, j, indent = 1, ...) {
   if (missing(i)) i <- NULL
   if (missing(j)) j <- NULL
 
-  i <- sanitize_group_index(i, hi = attr(x, "nrow") + 1)
-  j <- sanitize_group_index(j, hi = attr(x, "ncol"))
+  i <- sanitize_group_index(i, hi = attr(x, "nrow") + 1, orientation = "row")
+  j <- sanitize_group_index(j, hi = attr(x, "ncol"), orientation = "column")
 
   # we don't need this as a list, and we use some sorting later
   i <- unlist(i)
 
-  if (inherits(out, "tinytable_tabularray")) {
+  if (m$output == "latex") {
     out <- group_tabularray(out, i = i, j = j, indent = indent, ...)
-  } else if (inherits(out, "tinytable_bootstrap")) {
+  } else if (m$output == "html") {
     out <- group_bootstrap(out, i = i, j = j, indent = indent, ...)
   }
 
@@ -40,11 +41,15 @@ group_tt <- function(x, i, j, indent = 1, ...) {
 
 
 
-sanitize_group_index <- function(idx, hi) {
+sanitize_group_index <- function(idx, hi, orientation) {
   if (is.null(idx)) return(idx)
   assert_list(idx, named = TRUE)
   for (n in names(idx)) {
-    assert_integerish(idx[[n]], lower = 1, upper = hi, name = n)
+    if (orientation == "row") {
+      assert_integerish(idx[[n]], len = 1, lower = 1, upper = hi, name = n)
+    } else {
+      assert_integerish(idx[[n]], lower = 1, upper = hi, name = n)
+    }
   }
   if (anyDuplicated(unlist(idx)) > 0) stop("Duplicate group indices.", call. = FALSE)
   out <- lapply(idx, function(x) min(x):max(x))

R/print.R

@@ -2,59 +2,50 @@
 #'
 #' @keywords internal
 #' @export
-knit_print.tinytable_bootstrap <- function(x, ...) {
-  # from htmltools:::html_preserve
-  # GPL3
-  inline <- grepl(x, "\n", fixed = TRUE)
-  if (inline) {
-    out <- sprintf("`%s`{=html}", x)
-  } else {
-    out <- sprintf("\n```{=html}\n%s\n```\n", x)
-  }
-  # from knitr::asis_output
-  # GPL3
-  class(out) <- "knit_asis"
-  return(out)
-}
+knit_print.tinytable <- function(x, ...) {
+  m <- meta(x)
 
+  if (m$output == "html") {
+    # from htmltools:::html_preserve
+    # GPL3
+    inline <- grepl(x, "\n", fixed = TRUE)
+    if (inline) {
+      out <- sprintf("`%s`{=html}", x)
+    } else {
+      out <- sprintf("\n```{=html}\n%s\n```\n", x)
+    }
+
+  } else if (m$output %in% c("latex", "markdown")) {
+    out <- x
+  }
 
-#' Print a tinytable object in knitr 
-#'
-#' @keywords internal
-#' @export
-knit_print.tinytable_tabularray <- function(x, ...) {
-  out <- x
-  # from knitr::asis_output
-  # GPL3
   class(out) <- "knit_asis"
   return(out)
 }
 
 
 #' @export
-print.tinytable_tabularray <- function(x, ...) {
-  out <- x
-  class(out) <- "character"
-  cat(out, "
-")
-}
+print.tinytable <- function(x, ...) {
+  m <- meta(x)
 
+  if (m$output %in% c("markdown", "latex")) {
+    out <- x
+    class(out) <- "character"
+    cat("\n")
+    cat(out)
+    cat("\n")
 
-#' @export
-print.tinytable_bootstrap <- function(x, ...) {
-  dir <- tempfile()
-  dir.create(dir)
-  htmlFile <- file.path(dir, "index.html")
-  cat(x, file = htmlFile)
-  if (check_dependency("rstudioapi") && rstudioapi::isAvailable()) {
-    rstudioapi::viewer(htmlFile)
-  } else {
-    utils::browseURL(htmlFile)
+  } else if (m$output == "html") {
+    dir <- tempfile()
+    dir.create(dir)
+    htmlFile <- file.path(dir, "index.html")
+    cat(x, file = htmlFile)
+    if (check_dependency("rstudioapi") && rstudioapi::isAvailable()) {
+      rstudioapi::viewer(htmlFile)
+    } else {
+      utils::browseURL(htmlFile)
+    }
   }
-}
 
-#' @export
-print.tinytable_markdown <- function(x, ...) {
-    cat("\n")
-    cat(x, sep = "\n")
 }
+

R/save_tt.R

@@ -1,7 +1,6 @@
 #' Save a Tiny Table to File
 #'
-#' This function saves an object of class tinytable_bootstrap, tinytable_tabularray, 
-#' or tinytable_markdown to a specified file, with an option to overwrite existing files.
+#' This function saves an object of class tinytable to a specified file, with an option to overwrite existing files.
 #'
 #' @param x The tinytable object to be saved.
 #' @param filename A string representing the path to the file where the object should be saved.
@@ -18,19 +17,19 @@
 #' }
 #'
 save_tt <- function(x, filename, overwrite = FALSE) {
-  # Check if x is of the required classes
-  if (!inherits(x, c("tinytable_bootstrap", "tinytable_tabularray", "tinytable_markdown"))) {
-    stop("`x` must be an object produced by the `tinytable::tt()` function.", call. = FALSE)
-  }
+
+  m <- meta(x)
+
+
   assert_string(filename)
   assert_flag(overwrite)
-
-  # Check for file existence and handle the overwrite parameter
   if (file.exists(filename) && !overwrite) {
     stop("File already exists and overwrite is set to FALSE.", call. = FALSE)
   }
+  if (is.null(m)) {
+    stop("`x` must be an object produced by the `tinytable::tt()` function.", call. = FALSE)
+  }
 
-  # Write x to file
   write(x, file = filename)
 
   return(invisible(TRUE))