Lazy format (#81)

everything lazy

R/build_tt.R

@@ -0,0 +1,39 @@
+# internal function
+# style_tt() stores style calls and we only want to evaluate them at the end because 
+# some rows may be added, which changes how the style is applied
+build_tt <- function(x) {
+  m <- meta(x)
+
+  out <- x
+
+  # format data before drawing the table
+  for (l in m$lazy_format) {
+    tmp <- out
+    class(tmp) <- "data.frame"
+    l[["x"]] <- tmp
+    out <- eval(l)
+  }
+
+  # draw the table
+  lazy_tt <- meta(x, "lazy_tt")
+  lazy_tt[["x"]] <- out
+  out <- eval(lazy_tt)
+
+  # group the table (before style)
+  for (l in m$lazy_group) {
+    l[["x"]] <- out
+    out <- eval(l)
+  }
+
+  # style the table
+  for (l in m$lazy_style) {
+    l[["x"]] <- out
+    out <- eval(l)
+  }
+
+  m <- meta(x)
+  m$lazy_style <- list()
+  attr(out, "tinytable_meta") <- m
+
+  return(out)
+}

R/format_tt.R

@@ -35,7 +35,7 @@
 #'  num_mark_big = " ")
 #' tt(tab)
 #'
-format_tt <- function(x = NULL,
+format_tt <- function(x,
                       j = NULL,
                       output = NULL,
                       digits = getOption("digits"),
@@ -51,9 +51,59 @@ format_tt <- function(x = NULL,
                       other = identity
                       ) {
 
-  if (inherits(x, "tinytable")) {
-    msg <- "`format_tt()` must be called *before* `tt()`. You must format your dataset before drawing a table."
+  out <- x
+
+  if (inherits(out, "tinytable")) {
+    cal <- call("format_tt_lazy", 
+                j = j,
+                output = output,
+                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,
+                sprintf = sprintf,
+                url = url,
+                date = date,
+                bool = bool,
+                other = other)
+    out <- meta(out, "lazy_format", c(meta(out)$lazy_format, list(cal)))
+  } else {
+
+    out <- format_tt_lazy(out,
+                          j = j,
+                          output = output,
+                          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,
+                          sprintf = sprintf,
+                          url = url,
+                          date = date,
+                          bool = bool,
+                          other = other)
   }
+  return(out)
+}
+
+format_tt_lazy <- function(x,
+                           j = NULL,
+                           output = NULL ,
+                           digits,
+                           num_fmt = "significant",
+                           num_zero = FALSE,
+                           num_suffix = FALSE,
+                           num_mark_big = "",
+                           num_mark_dec = NULL,
+                           sprintf = NULL,
+                           url = FALSE,
+                           date = "%Y-%m-%d",
+                           bool = identity,
+                           other = identity
+                           ) {
 
   if (isTRUE(check_atomic_vector(x))) {
     atomic_vector <- TRUE
@@ -93,7 +143,6 @@ format_tt <- function(x = NULL,
 
   # format each column
   for (col in j) {
-
     # sprintf() is self-contained
     if (!is.null(sprintf)) {
       x[[col]] <- base::sprintf(sprintf, x[[col]])

R/group_tabularray.R

@@ -1,22 +1,20 @@
-group_tabularray <- function(x, i, j, indent, ...) {
+group_tabularray <- function(x, i, j, indent) {
   out <- x
   # columns first to count headers properly
   if (!is.null(j)) {
-    out <- group_tabularray_col(out, j, ...)
+    out <- group_tabularray_col(out, j)
   }
   if (!is.null(i)) {
-    out <- group_tabularray_row(out, i, indent, ...)
+    out <- group_tabularray_row(out, i, indent)
   } 
   return(out)
 }
 
 
-group_tabularray_col <- function(x, j, ...) {
+group_tabularray_col <- function(x, j) {
 
   m <- meta(x)
 
-  dots <- list(...)
-
   out <- strsplit(x, split = "\\n")[[1]]
 
   header <- rep("", m$ncols)
@@ -46,16 +44,14 @@ group_tabularray_col <- function(x, j, ...) {
 
   for (k in seq_along(j)) {
     z <- min(j[[k]])
-    args <- list(x = out,
+    args <- list(tt_build_now = TRUE,
+                 x = out,
                  # the new header is always first row and 
                  # style_tt always adds nhead to index
                  i = 1 - meta(out)$nhead,
                  j = z,
+                 align = "c",
                  colspan = max(j[[k]]) - min(j[[k]]) + 1)
-    if (!"halign" %in% names(dots)) {
-      args["align"] <- "c" 
-    }
-    args <- c(args, dots)
     out <- do.call(style_tt, args)
   }
 
@@ -64,7 +60,7 @@ group_tabularray_col <- function(x, j, ...) {
 }
 
 
-group_tabularray_row <- function(x, i, indent, ...) {
+group_tabularray_row <- function(x, i, indent) {
 
   m <- meta(x)
 
@@ -73,12 +69,13 @@ group_tabularray_row <- function(x, i, indent, ...) {
   }
   label <- names(i)
 
-  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% m$body)
+  body_min <- max(grep("TinyTableHeader|toprule|inner close", tab)) + 1
+  body_max <- min(grep("bottomrule|end.tblr", tab))
+  body <- body_min:body_max
   top <- tab[1:(min(body) - 1)]
   mid <- tab[min(body):max(body)]
   bot <- tab[(max(body) + 1):length(tab)]
@@ -107,16 +104,10 @@ group_tabularray_row <- function(x, i, indent, ...) {
   # we also want to indent the header
   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 <- sprintf("cell{%s}{%s}={%s},\n", i, 1, sprintf("preto={\\hspace{%sem}}", indent))
   cellspec <- paste(cellspec, collapse = "")
   tab <- tabularray_insert(tab, content = cellspec, type = "inner")
 
-  dots <- list(...)
-  if (length(dots) > 0) {
-    args <- c(list(x = tab, i = idx$new[is.na(idx$old)]), dots)
-    tab <- do.call(style_tt, args)
-  }
-
   return(tab)
 }
 

R/group_tt.R

@@ -4,8 +4,7 @@
 #' @inheritParams tt
 #' @inheritParams style_tt
 #' @param indent integer number of `pt` to use when indenting the non-labelled rows.
-#' @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 = NULL, j = NULL, indent = 1, ...) {
+group_tt <- function(x, i = NULL, j = NULL, indent = 1) {
 
   if (is.null(meta(x))) stop("`x` must be generated by `tinytable::tt()`.", call. = FALSE)
   if (!isTRUE(meta(x, "output") %in% c("html", "latex"))) return(x)
@@ -24,11 +23,13 @@ group_tt <- function(x, i = NULL, j = NULL, indent = 1, ...) {
   i <- unlist(i)
 
   if (meta(out)$output == "latex") {
-    out <- group_tabularray(out, i = i, j = j, indent = indent, ...)
+    cal <- call("group_tabularray", i = i, j = j, indent = indent)
   } else if (meta(out)$output == "html") {
-    out <- group_bootstrap(out, i = i, j = j, indent = indent, ...)
+    cal <- call("group_bootstrap", i = i, j = j, indent = indent)
   }
 
+  out <- meta(out, "lazy_group", c(meta(out)$lazy_group, list(cal)))
+
   return(out)
 }
 

R/print.R

@@ -4,7 +4,7 @@
 #' @export
 knit_print.tinytable <- function(x, ...) {
   # lazy styles get evaluated here, at the very end
-  out <- eval_style(x)
+  out <- build_tt(x)
 
   if (meta(out)$output == "html") {
     # from htmltools:::html_preserve
@@ -25,7 +25,7 @@ knit_print.tinytable <- function(x, ...) {
 #' @export
 print.tinytable <- function(x, ...) {
   # lazy styles get evaluated here, at the very end
-  out <- eval_style(x)
+  out <- build_tt(x)
 
   if (meta(out, "output") == "latex") {
     class(out) <- "character"

R/save_tt.R

@@ -33,7 +33,7 @@ file_ext <- tools::file_ext(filename)
 sanity_file_extension(x, file_ext)
 
 # evaluate styles at the very end of the pipeline, just before writing
-x <- eval_style(x)
+x <- build_tt(x)
 
 if (file_ext %in% c("html", "tex", "md", "Rmd", "qmd", "txt")) {
   write(x, file = filename)

R/style_tt.R

@@ -30,6 +30,7 @@
 #' @param bootstrap_css_rule A string with complete CSS rules that apply to the table class specified using the `theme` argument of the `tt()` function.
 #' @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 ... extra arguments are ignored
 #' @return Returns a modified `tinytable` object with the applied styles.
 #' @template latex_preamble
 #' @export
@@ -59,7 +60,9 @@ style_tt <- function (x,
                       tabularray_inner = NULL,
                       tabularray_outer = NULL,
                       bootstrap_css = NULL,
-                      bootstrap_css_rule = NULL) {
+                      bootstrap_css_rule = NULL,
+                      ...) {
+
   out <- x
   cal <- call("style_tt_lazy",
   # out <- style_tt_lazy(
@@ -83,7 +86,11 @@ style_tt <- function (x,
               bootstrap_css = bootstrap_css,
               bootstrap_css_rule = bootstrap_css_rule)
 
-  out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal)))
+  if (isTRUE(list(...)[["tt_build_now"]])) {
+    out <- eval(cal)
+  } else {
+    out <- meta(out, "lazy_style", c(meta(out)$lazy_style, list(cal)))
+  }
 
   return(out)
 }

R/tt.R

@@ -35,7 +35,7 @@
 #' @export
 tt <- function(x,
                output = NULL,
-               digits = getOption("digits"),
+               digits = NULL,
                caption = NULL,
                width = NULL,
                notes = NULL,
@@ -49,45 +49,43 @@ tt <- function(x,
   assert_numeric(width, len = 1, lower = 0, upper = 1, null.ok = TRUE)
   assert_integerish(digits, len = 1, null.ok = TRUE)
 
-  # formatting options are limited here
-  if (!is.null(digits)) {
-    x <- format_tt(x, digits = digits)
-  }
 
   # notes can be a single string or a (named) list of strings
   if (is.character(notes) && length(notes)) {
     notes <- list(notes)
   }
   assert_list(notes, null.ok = TRUE)
 
-  out <- x
+  # before style_tt() call for align
+  out <- x 
+  out <- meta(out, "x_character", data.frame(lapply(x, as.character)))
+  out <- meta(out, "output", output)
+  out <- meta(out, "colnames", names(x))
+  out <- meta(out, "xdim", dim(x))
+  out <- meta(out, "output", output)
+  out <- meta(out, "id", get_id("tinytable_"))
+  out <- meta(out, "nhead", if (is.null(colnames(x))) 0 else 1)
+  out <- meta(out, "nrows", nrow(x))
+  out <- meta(out, "ncols", ncol(x))
+  class(out) <- c("tinytable", class(out))
 
   # build table
   if (output == "latex") {
-    out <- tt_tabularray(out, caption = caption, theme = theme, width = width, notes = notes)
+    cal <- call("tt_tabularray", x = out, caption = caption, theme = theme, width = width, notes = notes, placement = placement)
 
   } else if (output == "html"){
-    out <- tt_bootstrap(out, caption = caption, theme = theme, width = width, notes = notes)
+    cal <- call("tt_bootstrap", x = out, caption = caption, theme = theme, width = width, notes = notes)
 
   } else {
-    out <- tt_markdown(out, caption = caption)
+    cal <- call("tt_markdown", x = out, caption = caption)
   }
 
-  # before style_tt() call for align
-  out <- meta(out, "colnames", names(x))
-  out <- meta(out, "xdim", dim(x))
-  out <- meta(out, "output", output)
-  out <- meta(out, "id", get_id("tinytable_"))
-  out <- meta(out, "nhead", if (is.null(colnames(x))) 0 else 1)
-  out <- meta(out, "nrows", nrow(x))
-  out <- meta(out, "ncols", ncol(x))
-  out <- meta(out, "lazy_style", list())
+  out <- meta(out, "lazy_tt", cal)
 
-  # placement
-  assert_string(placement, null.ok = TRUE)
-  if (!is.null(placement)) {
-    # dollar sign to avoid [H][H] when we style multiple times
-    out <- sub("\\\\begin\\{table\\}", sprintf("\\\\begin{table}[%s]\n", placement), out)
+  # formatting options are limited here
+  # after creating the table since the new lazy system
+  if (!is.null(digits)) {
+    out <- format_tt(out, digits = digits)
   }
 
   return(out)

R/tt_bootstrap.R

@@ -1,6 +1,7 @@
 tt_bootstrap <- function(x, caption, theme, width, notes) {
 
   template <- template_bootstrap(theme)
+  m <- meta(x)
 
 
   # caption
@@ -98,6 +99,7 @@ tt_bootstrap <- function(x, caption, theme, width, notes) {
   out <- paste(template, collapse = "\n")
 
   class(out) <- c("tinytable", "knit_asis", class(out))
+  attr(out, "tinytable_meta") <- m
   return(out)
 }