336 nearest value round (#246)

now with a new name, same great taste --------- Signed-off-by: Gabe Becker <[email protected]> Signed-off-by: Davide Garolini <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Joe Zhu <[email protected]> Co-authored-by: Joe Zhu <[email protected]> Co-authored-by: Davide Garolini <[email protected]>
insightsengineering · Feb 28, 2025 · 96c883f · 96c883f
1 parent b8300db
commit 96c883f
Show file tree

Hide file tree

Showing 9 changed files with 134 additions and 47 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -46,6 +46,8 @@ Config/Needs/verdepcheck: insightsengineering/formatters,
     tidyverse/tibble, mllg/checkmate, tidyverse/dplyr, yihui/knitr,
     r-lib/lifecycle, rstudio/rmarkdown, gagolews/stringi, r-lib/testthat,
     r-lib/withr
+Remotes:
+    insightsengineering/formatters@main
 Config/Needs/website: insightsengineering/nesttemplate
 Config/testthat/edition: 3
 Encoding: UTF-8

diff --git a/R/rlistings.R b/R/rlistings.R
@@ -303,7 +303,12 @@ get_keycols <- function(df) {
 #' @export
 setMethod(
   "matrix_form", "listing_df",
-  rix_form <- function(obj, indent_rownames = FALSE, expand_newlines = TRUE, fontspec = font_spec, col_gap = 3L) {
+  rix_form <- function(obj,
+                       indent_rownames = FALSE,
+                       expand_newlines = TRUE,
+                       fontspec = font_spec,
+                       col_gap = 3L,
+                       round_type = c("iec", "sas")) {
     ##  we intentionally silently ignore indent_rownames because listings have
     ## no rownames, but formatters::vert_pag_indices calls matrix_form(obj, TRUE)
     ## unconditionally.
@@ -325,7 +330,10 @@ setMethod(
     for (i in seq_along(keycols)) {
       kcol <- keycols[i]
       kcolvec <- listing[[kcol]]
-      kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec))
+      kcolvec <- vapply(kcolvec, format_value, "",
+                        format = obj_format(kcolvec),
+                        na_str = obj_na_str(kcolvec),
+                        round_type = round_type)
       curkey <- paste0(curkey, kcolvec)
       disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1))
       bodymat[disp, kcol] <- kcolvec[disp]
@@ -335,7 +343,10 @@ setMethod(
     if (length(nonkeycols) > 0) {
       for (nonk in nonkeycols) {
         vec <- listing[[nonk]]
-        vec <- vapply(vec, format_value, "", format = obj_format(vec), na_str = obj_na_str(vec))
+        vec <- vapply(vec, format_value, "",
+                      format = obj_format(vec),
+                      na_str = obj_na_str(vec),
+                      round_type = round_type)
         bodymat[, nonk] <- vec
       }
     }

diff --git a/R/rlistings_methods.R b/R/rlistings_methods.R
@@ -13,41 +13,52 @@ dflt_courier <- font_spec("Courier", 9, 1)
 #'
 #' @export
 #' @name listing_methods
-print.listing_df <- function(x, widths = NULL, tf_wrap = FALSE, max_width = NULL, fontspec = NULL, col_gap = 3L, ...) {
-  tryCatch(
-    {
-      cat(
-        toString(
-          matrix_form(x, fontspec = fontspec, col_gap = col_gap),
-          widths = widths,
-          tf_wrap = tf_wrap,
-          max_width = max_width,
-          fontspec = fontspec,
-          col_gap = col_gap,
-          ...
-        )
+print.listing_df <- function(x,
+                             widths = NULL,
+                             tf_wrap = FALSE,
+                             max_width = NULL,
+                             fontspec = NULL,
+                             col_gap = 3L,
+                             round_type = c("iec", "sas"),
+                             ...) {
+  tryCatch({
+    cat(
+      toString(
+        matrix_form(x, fontspec = fontspec, col_gap = col_gap),
+        widths = widths,
+        tf_wrap = tf_wrap,
+        max_width = max_width,
+        fontspec = fontspec,
+        col_gap = col_gap,
+        round_type = round_type,
+        ...
       )
-    },
-    error = function(e) {
-      if (nrow(x) == 0) {
-        print("No observation in the listing object.")
-      } else {
-        stop(e)
-      }
+    )
+  }, error = function(e) {
+    if (nrow(x) == 0) {
+      print("No observation in the listing object.")
+    } else {
+      stop(e)
     }
-  )
+  })
   invisible(x)
 }
 
 #' @exportMethod toString
 #' @name listing_methods
 #' @aliases toString,listing_df-method
-setMethod("toString", "listing_df", function(x, widths = NULL, fontspec = NULL, col_gap = 3L, ...) {
+setMethod("toString", "listing_df", function(x,
+                                             widths = NULL,
+                                             fontspec = NULL,
+                                             col_gap = 3L,
+                                             round_type = c("iec", "sas"),
+                                             ...) {
   toString(
-    matrix_form(x, fontspec = fontspec, col_gap = col_gap),
+    matrix_form(x, fontspec = fontspec, col_gap = col_gap, round_type = round_type),
     fontspec = fontspec,
     col_gap = col_gap,
     widths = widths,
+    round_type = round_type,
     ...
   )
 })
@@ -70,7 +81,7 @@ basic_run_lens <- function(x) {
 #'
 #' @rdname vec_nlines
 #' @keywords internal
-format_colvector <- function(df, colnm, colvec = df[[colnm]]) {
+format_colvector <- function(df, colnm, colvec = df[[colnm]], round_type = c("iec", "sas")) {
   if (missing(colvec) && !(colnm %in% names(df))) {
     stop("column ", colnm, " not found")
   }
@@ -79,7 +90,7 @@ format_colvector <- function(df, colnm, colvec = df[[colnm]]) {
     na_str <- rep("-", max(1L, length(na_str)))
   }
 
-  strvec <- vapply(colvec, format_value, "", format = obj_format(colvec), na_str = na_str)
+  strvec <- vapply(colvec, format_value, "", format = obj_format(colvec), na_str = na_str, round_type = round_type)
   strvec
 }
 
@@ -94,19 +105,23 @@ format_colvector <- function(df, colnm, colvec = df[[colnm]]) {
 #'   needed to render the elements of `vec` to width `max_width`.
 #'
 #' @keywords internal
-setGeneric("vec_nlines", function(vec, max_width = NULL, fontspec = dflt_courier) standardGeneric("vec_nlines"))
+setGeneric("vec_nlines", function(vec, max_width = NULL, fontspec = dflt_courier, round_type = c("iec", "sas")) {
+  standardGeneric("vec_nlines")
+})
 
 #' @param vec (`vector`)\cr a vector.
 #'
 #' @rdname vec_nlines
 #' @keywords internal
-setMethod("vec_nlines", "ANY", function(vec, max_width = NULL, fontspec = dflt_courier) {
+setMethod("vec_nlines", "ANY", function(vec, max_width = NULL, fontspec = dflt_courier, round_type = c("iec", "sas")) {
+  round_type <- match.arg(round_type)
   if (is.null(max_width)) {
     max_width <- floor(0.9 * getOption("width")) # default of base::strwrap
     # NB: flooring as it is used as <= (also in base::strwrap)
   }
   # in formatters for characters
-  unlist(lapply(format_colvector(colvec = vec), nlines, max_width = max_width, fontspec = fontspec))
+  unlist(lapply(format_colvector(colvec = vec, round_type = round_type), nlines,
+                max_width = max_width, fontspec = fontspec))
 })
 
 ## setMethod("vec_nlines", "character", function(vec, max_width = NULL) {
@@ -121,6 +136,8 @@ setMethod("vec_nlines", "ANY", function(vec, max_width = NULL, fontspec = dflt_c
 ##   ret[is.na(ret)] <- format_value(NA_character
 ## })
 
+
+
 #' Make pagination data frame for a listing
 #'
 #' @inheritParams formatters::make_row_df
@@ -148,7 +165,8 @@ setMethod(
            repr_inds = integer(),
            sibpos = NA_integer_,
            nsibs = NA_integer_,
-           fontspec = dflt_courier) {
+           fontspec = dflt_courier,
+           round_type = c("iec", "sas")) {
     ## assume sortedness by keycols
     keycols <- get_keycols(tt)
     dispcols <- listing_dispcols(tt)
@@ -174,7 +192,7 @@ setMethod(
     ## if that column has any rows wider than the previously recorded extent.
     for (col in dispcols) {
       ## duplicated from matrix_form method, refactor!
-      col_ext <- vec_nlines(tt[[col]], max_width = colwidths[col], fontspec = fontspec)
+      col_ext <- vec_nlines(tt[[col]], max_width = colwidths[col], fontspec = fontspec, round_type = round_type)
       extents <- ifelse(col_ext > extents, col_ext, extents)
     }
     ret <- data.frame(

diff --git a/inst/WORDLIST b/inst/WORDLIST
@@ -1,22 +1,26 @@
 ADAE
+api
 Biomarker
 Cheatsheet
-Forkers
-Hoffmann
-ORCID
-README
-Repo
-Rua
-WIP
-api
 cheatsheet
 csv
 customizations
 de
 droppage
+Forkers
 formatter
 funder
+Hoffmann
+IEC
+iec
+ORCID
 pagesize
 paginations
+peforms
 pre
+README
+Repo
 repo
+Rua
+sas
+WIP
diff --git a/man/listing_methods.Rd b/man/listing_methods.Rd
diff --git a/man/make_row_df-listing_df-method.Rd b/man/make_row_df-listing_df-method.Rd
diff --git a/man/matrix_form-listing_df-method.Rd b/man/matrix_form-listing_df-method.Rd
diff --git a/man/vec_nlines.Rd b/man/vec_nlines.Rd
diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R
@@ -3,6 +3,10 @@ testthat::test_that("Listing print correctly", {
     add_listing_col("ARM")
 
   res <- strsplit(toString(matrix_form(lsting), hsep = "-"), "\\n")[[1]]
+  ## regression
+  printout <- capture.output(print(lsting, hsep = "-"))
+  testthat::expect_false(any(grepl("iec", printout, fixed = TRUE)))
+  testthat::expect_identical(res, printout)
 
   testthat::expect_snapshot(res)
 })
@@ -160,3 +164,19 @@ testthat::test_that("listings supports wrapping", {
   # Fix C stack inf rec loop
   testthat::expect_silent(toString(lsting, widths = c(10, 10, 1)))
 })
+
+
+testthat::test_that("sas rounding support", {
+  df <- data.frame(id = 1:3 + 0.845, value = 0.845)
+  lsting <- as_listing(df, key_cols = "id", default_formatting = list(all = fmt_config("xx.xx")))
+  txt1 <- export_as_txt(lsting)
+  txtlns1 <- strsplit(txt1, "\n", fixed = TRUE)[[1]]
+  expect_true(all(grepl(".*84.*84 $", txtlns1[3:5])))
+  expect_false(any(grepl("85", txtlns1)))
+  txt2 <- export_as_txt(lsting, round_type = "sas")
+  txtlns2 <- strsplit(txt2, "\n", fixed = TRUE)[[1]]
+  expect_true(all(grepl(".*85.*85 $", txtlns2[3:5])))
+  expect_false(any(grepl("84", txtlns2)))
+  expect_identical(export_as_txt(lsting, round_type = "sas"),
+                   toString(lsting, round_type = "sas"))
+})