From 96c883fbd0b6390404f15d8fd08c254a316ed7b0 Mon Sep 17 00:00:00 2001 From: Gabe Becker Date: Fri, 28 Feb 2025 00:47:56 -0800 Subject: [PATCH] 336 nearest value round (#246) now with a new name, same great taste --------- Signed-off-by: Gabe Becker Signed-off-by: Davide Garolini Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Joe Zhu Co-authored-by: Joe Zhu Co-authored-by: Davide Garolini --- DESCRIPTION | 2 + R/rlistings.R | 17 ++++-- R/rlistings_methods.R | 78 +++++++++++++++++----------- inst/WORDLIST | 20 ++++--- man/listing_methods.Rd | 14 ++++- man/make_row_df-listing_df-method.Rd | 7 ++- man/matrix_form-listing_df-method.Rd | 7 ++- man/vec_nlines.Rd | 16 ++++-- tests/testthat/test-print.R | 20 +++++++ 9 files changed, 134 insertions(+), 47 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b949fa84..209e00f7 100644 --- 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 index f749b615..a5c1a06c 100644 --- 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 index d1b70da7..147bc5c9 100644 --- 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 index 02351d79..e60bd98f 100644 --- 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 index e4dd1e5e..dfe55cb8 100644 --- a/man/listing_methods.Rd +++ b/man/listing_methods.Rd @@ -23,10 +23,18 @@ max_width = NULL, fontspec = NULL, col_gap = 3L, + round_type = c("iec", "sas"), ... ) -\S4method{toString}{listing_df}(x, widths = NULL, fontspec = NULL, col_gap = 3L, ...) +\S4method{toString}{listing_df}( + x, + widths = NULL, + fontspec = NULL, + col_gap = 3L, + round_type = c("iec", "sas"), + ... +) \S4method{[}{listing_df}(x, i, j, drop = FALSE) @@ -67,6 +75,10 @@ calculating string widths and heights, as returned by \code{\link[formatters:fon \item{col_gap}{(\code{numeric(1)})\cr space (in characters) between columns.} +\item{round_type}{(\code{"iec"} or \code{"sas"})\cr the type of rounding to perform. iec, +the default, peforms rounding compliant with IEC 60559 (see details), while +sas performs nearest-value rounding consistent with rounding within SAS.} + \item{...}{additional parameters passed to \code{\link[formatters:tostring]{formatters::toString()}}.} \item{i}{(\code{any})\cr object passed to base \code{[} methods.} diff --git a/man/make_row_df-listing_df-method.Rd b/man/make_row_df-listing_df-method.Rd index a2f43955..3053fc81 100644 --- a/man/make_row_df-listing_df-method.Rd +++ b/man/make_row_df-listing_df-method.Rd @@ -16,7 +16,8 @@ repr_inds = integer(), sibpos = NA_integer_, nsibs = NA_integer_, - fontspec = dflt_courier + fontspec = dflt_courier, + round_type = c("iec", "sas") ) } \arguments{ @@ -45,6 +46,10 @@ non-visible structural elements.} \item{fontspec}{(\code{font_spec})\cr a font_spec object specifying the font information to use for calculating string widths and heights, as returned by \code{\link[formatters:font_spec]{font_spec()}}.} + +\item{round_type}{(\code{"iec"} or \code{"sas"})\cr the type of rounding to perform. iec, +the default, peforms rounding compliant with IEC 60559 (see details), while +sas performs nearest-value rounding consistent with rounding within SAS.} } \value{ a \code{data.frame} with pagination information. diff --git a/man/matrix_form-listing_df-method.Rd b/man/matrix_form-listing_df-method.Rd index 35e42b4b..55bd6123 100644 --- a/man/matrix_form-listing_df-method.Rd +++ b/man/matrix_form-listing_df-method.Rd @@ -9,7 +9,8 @@ indent_rownames = FALSE, expand_newlines = TRUE, fontspec = font_spec, - col_gap = 3L + col_gap = 3L, + round_type = c("iec", "sas") ) } \arguments{ @@ -26,6 +27,10 @@ calculating string widths and heights, as returned by \code{\link[formatters:fon \item{col_gap}{(\code{numeric(1)})\cr the gap to be assumed between columns, in number of spaces with font specified by \code{fontspec}.} + +\item{round_type}{(\code{"iec"} or \code{"sas"})\cr the type of rounding to perform. iec, +the default, peforms rounding compliant with IEC 60559 (see details), while +sas performs nearest-value rounding consistent with rounding within SAS.} } \value{ a \link[formatters:MatrixPrintForm]{formatters::MatrixPrintForm} object. diff --git a/man/vec_nlines.Rd b/man/vec_nlines.Rd index c62339c7..0e468f6f 100644 --- a/man/vec_nlines.Rd +++ b/man/vec_nlines.Rd @@ -6,11 +6,21 @@ \alias{vec_nlines,ANY-method} \title{Utilities for formatting a listing column} \usage{ -format_colvector(df, colnm, colvec = df[[colnm]]) +format_colvector(df, colnm, colvec = df[[colnm]], round_type = c("iec", "sas")) -vec_nlines(vec, max_width = NULL, fontspec = dflt_courier) +vec_nlines( + vec, + max_width = NULL, + fontspec = dflt_courier, + round_type = c("iec", "sas") +) -\S4method{vec_nlines}{ANY}(vec, max_width = NULL, fontspec = dflt_courier) +\S4method{vec_nlines}{ANY}( + vec, + max_width = NULL, + fontspec = dflt_courier, + round_type = c("iec", "sas") +) } \arguments{ \item{df}{(\code{listing_df})\cr the listing.} diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index c1f1283d..ee92dba8 100644 --- 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")) +})