strict format_tt

vincentarelbundock · Dec 13, 2024 · e64d69c · e64d69c
1 parent 5d902f1
commit e64d69c
Show file tree

Hide file tree

Showing 4 changed files with 76 additions and 64 deletions.
diff --git a/R/format_tt.R b/R/format_tt.R
@@ -29,7 +29,6 @@
 #' @param fn Function for custom formatting. Accepts a vector and returns a character vector of the same length.
 #' @param quarto Logical. Enable Quarto data processing and wrap cell content in a `data-qmd` span (HTML) or `\QuartoMarkdownBase64{}` macro (LaTeX). See warnings in the Global Options section below.
 #' @param sprintf String passed to the `?sprintf` function to format numbers or interpolate strings with a user-defined pattern (similar to the `glue` package, but using Base R).
-#' @param ... Additional arguments are ignored.
 #' @inheritParams tt
 #' @inheritParams style_tt
 #' @template global_options
@@ -85,24 +84,34 @@ format_tt <- function(x,
                       num_suffix = get_option("tinytable_format_num_suffix", default = FALSE),
                       num_mark_big = get_option("tinytable_format_num_mark_big", default = ""),
                       num_mark_dec = get_option("tinytable_format_num_mark_dec", default = getOption("OutDec", default = ".")),
-                      date = get_option("tinytable_format_date", default = "%Y-%m-%d"),
-                      bool = get_option("tinytable_format_bool", default = function(column) tools::toTitleCase(tolower(column))),
+                      date = get_option("tinytable_format_date", default = NULL),
+                      bool = get_option("tinytable_format_bool", default = NULL),
                       math = get_option("tinytable_format_math", default = FALSE),
-                      other = get_option("tinytable_format_other", default = as.character),
-                      replace = get_option("tinytable_format_replace", default = TRUE),
+                      other = get_option("tinytable_format_other", default = NULL),
+                      replace = get_option("tinytable_format_replace", default = FALSE),
                       escape = get_option("tinytable_format_escape", default = FALSE),
                       markdown = get_option("tinytable_format_markdown", default = FALSE),
                       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
+                      sprintf = get_option("tinytable_format_sprintf", default = NULL)) {
 
-  dots <- list(...)
-  if ("replace_na" %in% names(dots)) {
-    replace <- dots[["replace_na"]]
-    warning("The `replace_na` argument was renamed `replace`.", call. = FALSE)
-  }
+  assert_integerish(digits, len = 1, 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, null.ok = TRUE)
+  assert_function(bool, null.ok = TRUE)
+  assert_function(identity, null.ok = TRUE)
+  assert_function(other, null.ok = TRUE)
+  assert_flag(markdown)
+  assert_flag(quarto)
+  assert_function(fn, null.ok = TRUE)
+  assert_string(sprintf, null.ok = TRUE)
+  replace <- sanitize_replace(replace)
+  sanity_num_mark(digits, num_mark_big, num_mark_dec)
+
+  out <- x
 
   if (inherits(out, "tinytable")) {
     cal <- call("format_tt_lazy",
@@ -159,27 +168,27 @@ format_tt <- function(x,
 }
 
 format_tt_lazy <- function(x,
-                           i = NULL,
-                           j = NULL,
+                           i,
+                           j,
                            digits,
-                           num_fmt = "significant",
-                           num_zero = FALSE,
-                           num_suffix = FALSE,
-                           num_mark_big = "",
-                           num_mark_dec = NULL,
-                           replace = TRUE,
-                           fn = NULL,
-                           sprintf = NULL,
-                           url = FALSE,
-                           date = "%Y-%m-%d",
-                           bool = identity,
-                           math = FALSE,
-                           escape = FALSE,
-                           markdown = FALSE,
-                           quarto = quarto,
-                           other = as.character,
-                           inull = FALSE,
-                           jnull = FALSE) {
+                           num_fmt,
+                           num_zero,
+                           num_suffix,
+                           num_mark_big,
+                           num_mark_dec,
+                           replace,
+                           fn,
+                           sprintf,
+                           url,
+                           date,
+                           bool,
+                           math,
+                           escape,
+                           markdown,
+                           quarto,
+                           other,
+                           inull,
+                           jnull) {
   # format_tt() supports vectors
   if (isTRUE(check_atomic_vector(x))) {
     atomic_vector <- TRUE
@@ -198,21 +207,6 @@ format_tt_lazy <- function(x,
     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)
@@ -230,15 +224,15 @@ format_tt_lazy <- function(x,
       out[i, col] <- base::sprintf(sprintf, ori[i, col, drop = TRUE])
     } else {
       # logical
-      if (is.logical(ori[i, col])) {
+      if (!is.null(bool) && is.logical(ori[i, col])) {
         out[i, col] <- bool(ori[i, col, drop = TRUE])
 
-        # date
-      } else if (inherits(ori[i, col], "Date")) {
+      # date
+      } else if (!is.null(date) && 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])) {
+      # numeric
+      } else if (!is.null(digits) && is.numeric(ori[i, col, drop = TRUE])) {
         tmp <- format_numeric(ori[i, col],
           num_suffix = num_suffix,
           digits = digits,
@@ -249,8 +243,8 @@ format_tt_lazy <- function(x,
         )
         if (!is.null(tmp)) out[i, col] <- tmp
 
-        # other
-      } else {
+      # other
+      } else if (is.function(other)) {
         out[i, col] <- other(ori[i, col, drop = TRUE])
       }
     }

diff --git a/R/sanity.R b/R/sanity.R
@@ -12,6 +12,25 @@ sanity_align <- function(align, i) {
 }
 
 
+sanitize_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) {
+    out <- seq_len(nrow(x))
+    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_i <- function(i, x, pre_group_i = FALSE, lazy = TRUE) {
   if (is.character(i)) {
     assert_choice(i, c("notes", "caption"))

diff --git a/inst/tinytest/test-format_tt.R b/inst/tinytest/test-format_tt.R
@@ -196,6 +196,7 @@ expect_true(grepl("IQ==", x))
 
 
 # Website scaling example
+pkgload::load_all()
 thumbdrives <- data.frame(
   date_lookup = as.Date(c("2024-01-15", "2024-01-18", "2024-01-14", "2024-01-16")),
   price = c(18.49, 19.99, 24.99, 24.99),
@@ -211,6 +212,8 @@ tab <- tt(thumbdrives) |>
   format_tt(j = 5, fn = scales::label_percent()) |>
   format_tt(escape = TRUE) |>
   print("dataframe")
+tab
+
 expect_true("$18.49" %in% tab$price)
 expect_true("16 GB" %in% tab$memory)
 expect_true("99%" %in% tab$speed_benchmark)

diff --git a/man/format_tt.Rd b/man/format_tt.Rd