1040 rtables round type

NAMESPACE

@@ -230,6 +230,7 @@ exportMethods("obj_format<-")
 exportMethods("obj_label<-")
 exportMethods("obj_na_str<-")
 exportMethods("obj_name<-")
+exportMethods("obj_round_type<-")
 exportMethods("obj_stat_names<-")
 exportMethods("prov_footer<-")
 exportMethods("ref_index<-")
@@ -278,6 +279,7 @@ exportMethods(obj_format)
 exportMethods(obj_label)
 exportMethods(obj_na_str)
 exportMethods(obj_name)
+exportMethods(obj_round_type)
 exportMethods(obj_stat_names)
 exportMethods(prov_footer)
 exportMethods(rbind)

NEWS.md

@@ -1,5 +1,9 @@
 ## rtables 0.6.14.9002
 
+### New Features
+ * Allow table objects to have `round_type` instead of needing to specify on export #1040
+ * New `obj_round_type` getter and setter methods.
+
 ## rtables 0.6.14
 
 ### New Features

R/00tabletrees.R

@@ -1290,7 +1290,8 @@ setClass("VTableNodeInfo",
     format = "FormatSpec",
     na_str = "character",
     indent_modifier = "integer",
-    table_inset = "integer"
+    table_inset = "integer",
+    round_type = "character"
   )
 )
 
@@ -1326,7 +1327,9 @@ LabelRow <- function(lev = 1L,
                      cinfo = EmptyColInfo,
                      indent_mod = 0L,
                      table_inset = 0L,
-                     trailing_section_div = NA_character_) {
+                     trailing_section_div = NA_character_,
+                     round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   check_ok_label(label)
   new("LabelRow",
     leaf_value = list(),
@@ -1340,7 +1343,8 @@ LabelRow <- function(lev = 1L,
     visible = vis,
     indent_modifier = as.integer(indent_mod),
     table_inset = as.integer(table_inset),
-    trailing_section_div = trailing_section_div
+    trailing_section_div = trailing_section_div,
+    round_type = round_type
   )
 }
 
@@ -1394,11 +1398,13 @@ setClass("LabelRow",
                       indent_mod = 0L,
                       footnotes = list(),
                       table_inset = 0L,
-                      trailing_section_div = NA_character_) {
+                      trailing_section_div = NA_character_,
+                      round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
     name <- label
   }
-  vals <- lapply(vals, rcell)
+  vals <- lapply(vals, rcell, round_type = round_type)
   rlabels <- unique(unlist(lapply(vals, obj_label)))
   if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
     label <- rlabels[nzchar(rlabels)]
@@ -1422,7 +1428,8 @@ setClass("LabelRow",
     indent_modifier = indent_mod,
     row_footnotes = footnotes,
     table_inset = table_inset,
-    trailing_section_div = trailing_section_div
+    trailing_section_div = trailing_section_div,
+    round_type = round_type
   )
   rw <- set_format_recursive(rw, format, na_str, FALSE)
   rw
@@ -1571,6 +1578,22 @@ uniqify_child_names <- function(kidlst) {
   kidlst
 }
 
+# if input round_type is not defined (length 0) retrieve round_type from kids
+# and check all kids have the same round_type
+.determine_round_type <- function(round_type, kids) {
+  if (length(round_type) == 0) {
+    if ((length(kids) > 0)) {
+      round_type <- unique(vapply(kids, obj_round_type, ""))
+      stopifnot(length(round_type) == 1)
+    } else {
+      # no kids and round_type not set
+      ## continue with default value iec
+      round_type <- valid_round_type[1] # iec
+    }
+  }
+  round_type
+}
+
 
 #' Table constructors and classes
 #'
@@ -1607,7 +1630,9 @@ ElementaryTable <- function(kids = list(),
                             header_section_div = NA_character_,
                             hsep = default_hsep(),
                             trailing_section_div = NA_character_,
-                            inset = 0L) {
+                            inset = 0L,
+                            round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   check_ok_label(label)
   if (is.null(cinfo)) {
     if (length(kids) > 0) {
@@ -1641,7 +1666,8 @@ ElementaryTable <- function(kids = list(),
     provenance_footer = prov_footer,
     horizontal_sep = hsep,
     header_section_div = header_section_div,
-    trailing_section_div = trailing_section_div
+    trailing_section_div = trailing_section_div,
+    round_type = round_type
   )
   tab <- set_format_recursive(tab, format, na_str, FALSE)
   table_inset(tab) <- as.integer(inset)
@@ -1708,10 +1734,19 @@ TableTree <- function(kids = list(),
                       hsep = default_hsep(),
                       header_section_div = NA_character_,
                       trailing_section_div = NA_character_,
-                      inset = 0L) {
+                      inset = 0L,
+                      round_type = NULL) {
   check_ok_label(label)
   cinfo <- .calc_cinfo(cinfo, cont, kids)
 
+  # derive appropriate round_type to use
+  # either from input or retrieved from kids
+  round_type <- .determine_round_type(round_type, kids)
+  # also set this round_type to direct kids
+  # note that (some/most) obj_round_type setters will also set round_type of kids
+  # this will ensure only 1 round_type is present on all slots in the resulting tabletree
+  kids <- lapply(kids, `obj_round_type<-`, value = round_type)
+
   kids <- .enforce_valid_kids(kids, cinfo)
   if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
     stop("Got table tree with content table and content position")
@@ -1742,7 +1777,8 @@ TableTree <- function(kids = list(),
       hsep = hsep,
       header_section_div = header_section_div,
       trailing_section_div = trailing_section_div,
-      inset = inset
+      inset = inset,
+      round_type = round_type
     )
   } else {
     tab <- new("TableTree",
@@ -1764,7 +1800,8 @@ TableTree <- function(kids = list(),
       page_title_prefix = page_title,
       horizontal_sep = "-",
       header_section_div = header_section_div,
-      trailing_section_div = trailing_section_div
+      trailing_section_div = trailing_section_div,
+      round_type = round_type
     ) ## this is overridden below to get recursiveness
     tab <- set_format_recursive(tab, format, na_str, FALSE)
 
@@ -1878,7 +1915,8 @@ setClass("PreDataTableLayouts",
     top_left = "character",
     header_section_div = "character",
     top_level_section_div = "character",
-    table_inset = "integer"
+    table_inset = "integer",
+    round_type = "character"
   )
 )
 
@@ -1891,7 +1929,9 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),
                                 prov_footer = character(),
                                 header_section_div = NA_character_,
                                 top_level_section_div = NA_character_,
-                                table_inset = 0L) {
+                                table_inset = 0L,
+                                round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   new("PreDataTableLayouts",
     row_layout = rlayout,
     col_layout = clayout,
@@ -1902,7 +1942,8 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),
     provenance_footer = prov_footer,
     header_section_div = header_section_div,
     top_level_section_div = top_level_section_div,
-    table_inset = table_inset
+    table_inset = table_inset,
+    round_type = round_type
   )
 }
 
@@ -1958,6 +1999,7 @@ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
 #'
 #' @inheritParams lyt_args
 #' @inheritParams rcell
+#' @inheritParams gen_args
 #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.
 #'
 #' @return An object representing the value within a single cell within a populated table. The underlying structure
@@ -1973,7 +2015,9 @@ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
 ## indent_mod: indent modifier to be used for parent row
 CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
                       indent_mod = NULL, footnotes = NULL,
-                      align = NULL, format_na_str = NULL, stat_names = NA_character_) {
+                      align = NULL, format_na_str = NULL, stat_names = NA_character_,
+                      round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   if (is.null(colspan)) {
     colspan <- 1L
   }
@@ -1998,6 +2042,7 @@ CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
     align = align,
     format_na_str = format_na_str,
     stat_names = stat_names,
+    round_type = round_type,
     class = "CellValue"
   )
   ret

R/argument_conventions.R

@@ -47,6 +47,9 @@
 #'   wild-card path but resolve to an individual row will not be considered matching.
 #'   The value "elemtable" indicates an Elementary table, i.e., one representing a
 #'   single variable within an `analyze` call.
+#' @param round_type (`"iec"` (default), `"iec_mod"` or `"sas"`)\cr the type of rounding to perform.
+#' See [formatters::format_value()] for details.
+#'
 #'
 #' @return No return value.
 #'
@@ -57,6 +60,7 @@ gen_args <- function(df, alt_counts_df, spl, pos, tt, tr, verbose, colwidths, ob
                      value, object, path, label, label_pos, # visible_label,
                      cvar, topleft, page_prefix, hsep, indent_size, section_div, na_str, inset,
                      table_inset, tt_type = c("any", "row", "table", "elemtable"),
+                     round_type = valid_round_type,
                      ...) {
   NULL
 }

R/as_html.R

@@ -72,14 +72,15 @@ as_html <- function(x,
                     bold = c("header"),
                     header_sep_line = TRUE,
                     no_spaces_between_cells = FALSE,
-                    expand_newlines = FALSE) {
+                    expand_newlines = FALSE,
+                    round_type = if (is(x, "VTableTree")) obj_round_type(x) else valid_round_type) {
   if (is.null(x)) {
     return(tags$p("Empty Table"))
   }
 
   stopifnot(is(x, "VTableTree"))
 
-  mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)
+  mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines, round_type = round_type)
 
   nlh <- mf_nlheader(mat)
   nc <- ncol(x) + 1

R/colby_constructors.R

@@ -2027,6 +2027,7 @@ list_wrap_df <- function(f) {
 #' Every layout must start with a basic table.
 #'
 #' @inheritParams constr_args
+#' @inheritParams gen_args
 #' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of
 #'   applied to data. `NA`, the default, indicates that the `show_colcounts`
 #'   argument(s) passed to the relevant calls to `split_cols_by*`
@@ -2096,7 +2097,9 @@ basic_table <- function(title = "",
                         colcount_format = "(N=xx)",
                         header_section_div = NA_character_,
                         top_level_section_div = NA_character_,
-                        inset = 0L) {
+                        inset = 0L,
+                        round_type = valid_round_type) {
+  round_type <- match.arg(round_type)
   inset <- as.integer(inset)
   if (is.na(inset) || inset < 0L) {
     stop("Got invalid table_inset value, must be an integer > 0")
@@ -2111,7 +2114,8 @@ basic_table <- function(title = "",
     prov_footer = prov_footer,
     header_section_div = header_section_div,
     top_level_section_div = top_level_section_div,
-    table_inset = as.integer(inset)
+    table_inset = as.integer(inset),
+    round_type = round_type
   )
 
   ## unconditional now, NA case is handled in cinfo construction

R/format_rcell.R

@@ -3,7 +3,7 @@
 #' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects
 #'
 #' @inheritParams lyt_args
-#' @inheritParams formatters::format_value
+#' @inheritParams gen_args
 #' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value.
 #' @param format (`string` or `function`)\cr the format label or formatter function to
 #'   apply to `x`.
@@ -33,13 +33,19 @@ format_rcell <- function(x, format,
                          na_str = obj_na_str(x) %||% "NA",
                          pr_row_format = NULL,
                          pr_row_na_str = NULL,
-                         round_type = c("iec", "sas"),
+                         round_type,
                          shell = FALSE) {
   # Check for format and parent row format
   format <- if (missing(format)) obj_format(x) else format
   if (is.null(format) && !is.null(pr_row_format)) {
     format <- pr_row_format
   }
+  if (missing(round_type) && !is.null(obj_round_type(x))) {
+    round_type <- obj_round_type(x)
+  }
+  if (missing(round_type) && is.null(obj_round_type(x))) {
+    round_type <- valid_round_type[1]
+  }
   # Check for na_str from parent
   if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
     na_str <- pr_row_na_str