1040 rtables round type

NAMESPACE

@@ -22,6 +22,7 @@ export("obj_format<-")
 export("obj_label<-")
 export("obj_na_str<-")
 export("obj_name<-")
+export("obj_round_type<-")
 export("page_titles<-")
 export("prov_footer<-")
 export("subtitles<-")
@@ -83,6 +84,7 @@ export(obj_format)
 export(obj_label)
 export(obj_na_str)
 export(obj_name)
+export(obj_round_type)
 export(open_font_dev)
 export(padstr)
 export(pag_indices_inner)
@@ -107,6 +109,7 @@ export(subtitles)
 export(table_inset)
 export(toString)
 export(undebug_font_dev)
+export(valid_round_type)
 export(var_labels)
 export(var_labels_remove)
 export(var_relabel)
@@ -123,6 +126,7 @@ exportMethods("obj_align<-")
 exportMethods("obj_format<-")
 exportMethods("obj_label<-")
 exportMethods("obj_na_str<-")
+exportMethods("obj_round_type<-")
 exportMethods("page_titles<-")
 exportMethods("prov_footer<-")
 exportMethods("subtitles<-")
@@ -139,6 +143,7 @@ exportMethods(obj_align)
 exportMethods(obj_format)
 exportMethods(obj_label)
 exportMethods(obj_na_str)
+exportMethods(obj_round_type)
 exportMethods(page_titles)
 exportMethods(prov_footer)
 exportMethods(subtitles)

NEWS.md

@@ -2,8 +2,12 @@
 * Optimized pagination sub-routines to avoid `matrix_form()` calls when not needed.
 * Optimized pagination sub-routine `.compress_mat()` to reduce computing time for long listings.
 * Fixed bug in pagination of listings caused by newlines in column values.
-* Added `"default"` format label which will behave like `"xx"` but can
-  inherit formatting from parent structures in upstream code.
+* Added `"default"` format label which behaves like `"xx"` in `format_value` but indicates formatting behavior can be inherited from parent structures in upstream code.
+* `round_type = "sas"` no longer displays a negative sign when negative values are rounded to zero.
+* Added new `round_type`, `"iec_mod"`. Provides IEC style rounding but will not display negative sign when rounding to zero.
+* New exported `valid_round_type` object for use as default value/with `match.arg` in upstream packages.
+* New `obj_round_type` and `obj_round_type<-` generics for objects which carry around a round_type.
+* Updated default round type value to retrieve the object's round type for all generics and relevant methods which accept round_type.
 
 ## formatters 0.5.11
 * Fixed a bug in `mform_handle_newlines` that caused string matrix column names to be removed. This prevented paginated listing key column info from being repeated when vertically spanning multiple pages.

R/format_value.R

@@ -164,6 +164,10 @@ sprintf_format <- function(format) {
   }
 }
 
+#' @rdname round_fmt
+#' @export
+valid_round_type <- c("iec", "iec_mod", "sas")
+
 #' Round and prepare a value for display
 #'
 #' This function is used within [format_value()] to prepare numeric values within
@@ -173,9 +177,14 @@ sprintf_format <- function(format) {
 #' @param digits (`numeric(1)`)\cr number of digits to round to, or `NA` to convert to a
 #'   character value with no rounding.
 #' @param na_str (`string`)\cr the value to return if `x` is `NA`.
-#' @param round_type (`"iec"` or `"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.
+#' @param round_type (`string`)\cr .
+#' \cr The type of rounding to perform. Allowed values: (`"iec"`, `"iec_mod"` or `"sas"`)
+#' \cr iec, the default, and iec_mod performs rounding compliant with IEC 60559
+#'   (see notes in [round_fmt()]), while
+#'   sas performs nearest-value rounding consistent with rounding within SAS.\cr
+#'   In addition, the rounding of a negative number that rounds to zero will be presented as 0
+#'   (with the appropriate number of trailing zeros) for both `sas` and `iec_mod`,
+#'   while for `iec`, it will be presented as -0 (with the appropriate number of trailing zeros).
 #'
 #' @details
 #' This function combines rounding behavior with the strict decimal display of
@@ -214,10 +223,13 @@ sprintf_format <- function(format) {
 #' round_fmt(2.765923, digits = NA)
 #' round_fmt(0.845, digits = 2)
 #' round_fmt(0.845, digits = 2, round_type = "sas")
+#' round_fmt(-0.001, digits = 2, round_type = "iec")
+#' round_fmt(-0.001, digits = 2, round_type = "sas")
+#' round_fmt(-0.001, digits = 2, round_type = "iec_mod")
 #'
 #' @export
 #' @aliases rounding
-round_fmt <- function(x, digits, na_str = "NA", round_type = c("iec", "sas")) {
+round_fmt <- function(x, digits, na_str = "NA", round_type = valid_round_type) {
   round_type <- match.arg(round_type)
   if (!is.na(digits) && digits < 0) {
     stop("round_fmt currently does not support non-missing values of digits < 0")
@@ -229,6 +241,7 @@ round_fmt <- function(x, digits, na_str = "NA", round_type = c("iec", "sas")) {
   } else {
     rndx <- switch(round_type,
       iec = round(x, digits),
+      iec_mod = round_iec_mod(x, digits),
       sas = round_sas(x, digits)
     )
     sprfmt <- paste0("%.", digits, "f")
@@ -248,13 +261,28 @@ round_sas <- function(x,
   z <- z + 0.5 + sqrt(.Machine$double.eps)
   z <- trunc(z)
   z <- z / 10^digits
-  z <- z * posneg
+  # only include sign when rounded value is not zero
+  if (z != 0) z <- z * posneg
+  ## return numeric vector of rounded values
+  z
+}
+
+#' @inheritParams round_fmt
+#'
+round_iec_mod <- function(x,
+                          digits = 0) {
+  # perform default rounding ----------------------------------------------------
+  posneg <- sign(x)
+  z <- round(abs(x), digits)
+  # only include sign when rounded value is not zero
+  if (z != 0) z <- z * posneg
   ## return numeric vector of rounded values
   z
 }
 
 
-val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE, round_type = c("iec", "sas")) {
+val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE, round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   if (pct) {
     x[2] <- x[2] * 100
   }
@@ -269,7 +297,8 @@ val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE, round_type = c("ie
   )
 }
 
-sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL, round_type = c("iec", "sas")) {
+sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL, round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str, round_type = round_type),
     collapse = sep
   )
@@ -312,7 +341,7 @@ sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL, round_type =
 #' format_value(c(NA, 1, NA), format = "xx.x (xx.x - xx.x)", na_str = c("NE", "<missing>"))
 #'
 #' @export
-format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA", round_type = c("iec", "sas")) {
+format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA", round_type = valid_round_type) {
   ## if(is(x, "CellValue"))
   ##     x = x[[1]]
 

R/generics.R

@@ -68,7 +68,7 @@ setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE,
                                    max_width = NULL,
                                    fontspec = font_spec(),
                                    col_gap = 3L,
-                                   round_type = c("iec", "sas")) {
+                                   round_type = obj_round_type(tt)) {
   standardGeneric("make_row_df")
 })
 
@@ -85,7 +85,7 @@ setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visib
                                                      max_width = NULL,
                                                      fontspec = font_spec(),
                                                      col_gap = mf_colgap(tt) %||% 3L,
-                                                     round_type = c("iec", "sas")) {
+                                                     round_type = obj_round_type(tt)) {
   msg <- paste0(
     "make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
     "generated objects (MatrixPrintForm)."
@@ -127,7 +127,7 @@ setGeneric("matrix_form", function(obj,
                                    indent_size = 2,
                                    fontspec = NULL,
                                    col_gap = NULL,
-                                   round_type = c("iec", "sas")) {
+                                   round_type = obj_round_type(obj)) {
   standardGeneric("matrix_form")
 })
 
@@ -140,7 +140,7 @@ setMethod("matrix_form", "MatrixPrintForm", function(obj,
                                                      indent_size = 2,
                                                      fontspec = NULL,
                                                      col_gap = NULL,
-                                                     round_type = c("iec", "sas")) {
+                                                     round_type = obj_round_type(obj)) {
   if (!is.null(fontspec)) {
     mf_fontspec(obj) <- fontspec
   }
@@ -737,3 +737,66 @@ setMethod(
     obj
   }
 )
+
+
+# obj_round_type ---------------------------------------------------------------
+
+#' Rounding Type
+#'
+#' When called on a table-like object using the formatters framework, this method returns the
+#' rounding type of the object.
+#'
+#' @param obj (`ANY`)\cr a table-like object.
+#'
+#' @return The rounding type of the object (see [round_fmt()] for details).
+#' @rdname obj_round_type
+#' @export
+setGeneric("obj_round_type", function(obj) standardGeneric("obj_round_type"))
+
+#' @rdname obj_round_type
+#' @export
+setMethod(
+  "obj_round_type", "MatrixPrintForm", function(obj) obj$round_type
+)
+
+#' @rdname obj_round_type
+#' @export
+setMethod("obj_round_type", "list", function(obj) {
+  if (!.is_list_of_tables_or_listings(obj)) {
+    stop("got a list that doesn't appear to contain (only) tables or listings")
+  }
+  obj_round_type(obj[[1]])
+})
+
+# obj_round_type setter ---------------------------------------------------------------
+#' @rdname obj_round_type
+#' @param value The new rounding type of the object (see [round_fmt()] for details)
+#' @note The setter method should only be created/used for pre-MatrixPrintForm objects,
+#' as resetting the rounding type after rounding occurs (which is during MPF creation)
+#' will not effect output when printing/exporting.
+#' @export
+setGeneric("obj_round_type<-", function(obj, value) standardGeneric("obj_round_type<-"))
+
+#' @rdname obj_round_type
+#' @export
+setMethod("obj_round_type<-", "list", function(obj, value) {
+  if (!.is_list_of_tables_or_listings(obj)) {
+    stop("got a list that doesn't appear to contain (only) tables or listings")
+  }
+  obj <- lapply(obj, function(x) {
+    obj_round_type(x) <- value
+    x
+  })
+  obj
+})
+
+#' @rdname obj_round_type
+#' @export
+#' @note round_type cannot not be updated on a `MatrixPrintForm` object
+#' as rounding occurs during creation of MatrixPrintForm object
+setMethod("obj_round_type<-", "MatrixPrintForm", function(obj, value) {
+  stop(
+    "Cannot alter round type on a `MatrixPrintForm` object as it was ",
+    "constructed after rounding occurred."
+  )
+})

R/matrix_form.R

@@ -260,6 +260,9 @@ disp_from_spans <- function(spans) {
 #' @param indent_size (`numeric(1)`)\cr number of spaces to be used per level of indent (if supported by
 #'   the relevant method). Defaults to 2.
 #' @param rep_cols (`numeric(1)`)\cr number of columns to be repeated as context during horizontal pagination.
+#' @param round_type (`string`)\cr
+#' The type of rounding to perform. Allowed values: (`"iec"`, `"iec_mod"` or `"sas"`)
+#' See [round_fmt()] for details.
 #'
 #' @return An object of class `MatrixPrintForm`. Currently this is implemented as an S3 class inheriting
 #'   from list with the following elements:
@@ -325,7 +328,9 @@ MatrixPrintForm <- function(strings = NULL,
                             colwidths = NULL,
                             indent_size = 2,
                             fontspec = font_spec(),
-                            rep_cols = 0L) {
+                            rep_cols = 0L,
+                            round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   display <- disp_from_spans(spans)
 
   ncs <- if (has_rowlabs) ncol(strings) - 1 else ncol(strings)
@@ -353,7 +358,8 @@ MatrixPrintForm <- function(strings = NULL,
       indent_size = indent_size,
       col_widths = colwidths,
       fontspec = fontspec,
-      num_rep_cols = rep_cols
+      num_rep_cols = rep_cols,
+      round_type = round_type
     ),
     nrow_header = nrow_header,
     ncols = ncs,
@@ -915,6 +921,9 @@ mf_has_rlabels <- function(mf) ncol(mf$strings) > mf_ncol(mf)
 #' @param num_rep_cols (`numeric(1)`)\cr Number of columns to be treated as repeating columns.
 #'   Defaults to `0` for `basic_matrix_form` and `length(keycols)` for
 #'   `basic_listing_mf`. Note repeating columns are separate from row labels if present.
+#' @param round_type (`string`)\cr
+#' The type of rounding to perform. Allowed values: (`"iec"`, `"iec_mod"` or `"sas"`)
+#' See [round_fmt()] for details.
 #'
 #' @return A valid `MatrixPrintForm` object representing `df` that is ready for
 #'   ASCII rendering.
@@ -950,14 +959,16 @@ basic_matrix_form <- function(df,
                               fontspec = font_spec(),
                               split_labels = NULL,
                               data_labels = NULL,
-                              num_rep_cols = 0L) {
+                              num_rep_cols = 0L,
+                              round_type = valid_round_type) {
   checkmate::assert_data_frame(df)
   checkmate::assert_flag(indent_rownames)
   checkmate::assert_character(parent_path, null.ok = TRUE)
   checkmate::assert_flag(ignore_rownames)
   checkmate::assert_flag(add_decoration)
   checkmate::assert_character(split_labels, null.ok = TRUE)
   checkmate::assert_character(data_labels, null.ok = TRUE)
+  round_type <- match.arg(round_type)
 
   # Some defaults
   row_classes <- "DataRow" # Default for all rows
@@ -1016,7 +1027,7 @@ basic_matrix_form <- function(df,
   bodystrs <- mapply(function(x, coli_fmt) {
     coli_fmt[coli_fmt == "-"] <- "xx"
     sapply(seq_along(x), function(y) {
-      format_value(x[y], format = coli_fmt[y])
+      format_value(x[y], format = coli_fmt[y], round_type = round_type)
     })
   }, x = df, coli_fmt = fmts)
 
@@ -1111,7 +1122,8 @@ basic_matrix_form <- function(df,
     fontspec = fontspec,
     col_gap = 3,
     indent_size = indent_size,
-    rep_cols = num_rep_cols
+    rep_cols = num_rep_cols,
+    round_type = round_type
   )
 
   # Check for ncols
@@ -1146,7 +1158,9 @@ basic_matrix_form <- function(df,
 basic_listing_mf <- function(df,
                              keycols = names(df)[1],
                              add_decoration = TRUE,
-                             fontspec = font_spec()) {
+                             fontspec = font_spec(),
+                             round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   checkmate::assert_data_frame(df)
   checkmate::assert_subset(keycols, colnames(df))
 
@@ -1156,7 +1170,8 @@ basic_listing_mf <- function(df,
     ignore_rownames = TRUE,
     add_decoration = add_decoration,
     num_rep_cols = length(keycols),
-    fontspec = fontspec
+    fontspec = fontspec,
+    round_type = round_type
   )
 
   # keycols addition to MatrixPrintForm (should happen in the constructor)