fix: round collect_n_subject display values

NAMESPACE

@@ -32,6 +32,7 @@ export(define_observation)
 export(define_parameter)
 export(define_plan)
 export(define_population)
+export(format_number)
 export(get_label)
 export(meta_adam)
 export(meta_add_total)
@@ -44,6 +45,7 @@ export(meta_split)
 export(n_subject)
 export(outdata)
 export(plan)
+export(round_half_away_from_zero)
 export(spec_analysis_population)
 export(spec_call_program)
 export(spec_filename)

NEWS.md

@@ -1,5 +1,7 @@
 # metalite 0.1.4
 
+- Add SAS-compatible rounding and fixed-decimal formatting helpers, and use
+  them for `collect_n_subject()` display values.
 - Fix bug of `n_subject()` for empty factor.
 - Add default mapping for subject level analysis.
 - Update GitHub Actions workflows.

R/collect_n_subject.R

@@ -132,6 +132,11 @@ meta_remove_blank_group <- function(meta,
 #' @param decimal_places_summary Number of decimal places to be displayed in statistical summary values (Mean, SD, Median, Min, Max, Q1 and Q3). Default is 1.
 #' @param decimal_places_percent Number of decimal places to be displayed in percentage values. Default is 1.
 #'
+#' @details
+#' Summary statistics and percentages are calculated without rounding, then
+#' rounded once at the display boundary with [round_half_away_from_zero()].
+#' Decimal ties are rounded away from zero and trailing zeros are retained.
+#'
 #' @return A list containing number of subjects and its subset condition.
 #'
 #' @export
@@ -245,7 +250,7 @@ collect_n_subject <- function(meta,
         q1 = stats::quantile(x, probs = 0.25, na.rm = TRUE, type = quantile_method, names = FALSE),
         q3 = stats::quantile(x, probs = 0.75, na.rm = TRUE, type = quantile_method, names = FALSE)
       )
-      value <- formatC(value, format = "f", digits = decimal_places_summary)
+      value <- format_number(value, digits = decimal_places_summary)
       c(gluestick("{value[['mean']]} ({value[['sd']]})"), gluestick("{value[['median']]} [{value[['min']]}, {value[['max']]}]"), gluestick("{value[['q1']]} to {value[['q3']]}"))
     })
     pop_num <- data.frame(
@@ -260,7 +265,9 @@ collect_n_subject <- function(meta,
     pop_tmp <- pop_n
     for (i in seq(names(pop_n))) {
       if ("integer" %in% class(pop_n[[i]])) {
-        pct <- formatC(pop_n[[i]] / pop_all[[i]] * 100, format = "f", digits = decimal_places_percent, width = 5)
+        pct <- format_number(pop_n[[i]] / pop_all[[i]] * 100,
+          digits = decimal_places_percent, width = 5
+        )
         pop_tmp[[i]] <- gluestick("{pop_n[[i]]} ({pct}%)")
       }
     }
@@ -301,7 +308,9 @@ collect_n_subject <- function(meta,
 
     for (i in seq(names(pop_tmp))) {
       if ("integer" %in% class(pop_tmp[[i]])) {
-        pct <- formatC(pop_tmp[[i]] / pop_all[[i]] * 100, format = "f", digits = decimal_places_percent, width = 5)
+        pct <- format_number(pop_tmp[[i]] / pop_all[[i]] * 100,
+          digits = decimal_places_percent, width = 5
+        )
         pop_tmp[[i]] <- gluestick("{pop_tmp[[i]]} ({pct}%)")
       }
     }

R/meta_inherit.R

@@ -34,10 +34,11 @@
 #'
 #' @export
 meta_inherit <- function(
-    meta,
-    inherit,
-    name,
-    overwrite = FALSE) {
+  meta,
+  inherit,
+  name,
+  overwrite = FALSE
+) {
   mapping <- list()
   for (i in seq_along(name)) {
     x <- collect_adam_mapping(inherit, name[i])

R/rounding.R

@@ -0,0 +1,124 @@
+# Copyright (c) 2023 Merck & Co., Inc., Rahway, NJ, USA and its affiliates.
+# All rights reserved.
+#
+# This file is part of the metalite program.
+#
+# metalite is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+#' Round half away from zero
+#'
+#' Round numeric values to a given number of decimal places, with decimal
+#' ties (for example, 1.25 at `digits = 1`) rounded half away from zero.
+#' This differs from [base::round()], which uses round-to-even for ties.
+#' Values that round to zero, including small negative values, return positive
+#' zero so formatted output does not display negative zero.
+#'
+#' To account for floating-point representation, values within
+#' `sqrt(.Machine$double.eps)` below a tie at the requested precision are
+#' treated as ties. The implementation is adapted from `roundSAS()` in
+#' [pharmaverse/tidytlg](https://github.com/pharmaverse/tidytlg/blob/5f169c76428976f53d2af9e7fe52460348ef6cb7/R/roundSAS.R).
+#'
+#' @param x A numeric vector, matrix, array, or data frame with only numeric
+#'   columns.
+#' @param digits A finite, integer-valued scalar giving the number of decimal
+#'   places. Negative values round to positions left of the decimal point.
+#'
+#' @return A numeric object with the same dimensions, dimension names, and
+#'   names as `x`. A data frame input returns a data frame.
+#'
+#' @export
+#'
+#' @examples
+#' round_half_away_from_zero(c(1.25, -1.25), digits = 1)
+#' round_half_away_from_zero(c(-0.04, NA), digits = 1)
+round_half_away_from_zero <- function(x, digits = 0) {
+  if (!is.numeric(digits) || length(digits) != 1L || is.na(digits) ||
+    !is.finite(digits) || digits %% 1 != 0) {
+    stop("`digits` must be one finite integer.", call. = FALSE)
+  }
+
+  if (is.data.frame(x)) {
+    if (!all(vapply(x, is.numeric, logical(1)))) {
+      stop("All columns of `x` must be numeric.", call. = FALSE)
+    }
+
+    x[] <- lapply(x, function(col) round_half_away_from_zero(col, digits = digits))
+    return(x)
+  }
+
+  if (!is.numeric(x)) {
+    stop("`x` must be numeric.", call. = FALSE)
+  }
+
+  n <- names(x)
+  d <- dim(x)
+  dn <- dimnames(x)
+
+  posneg <- sign(x)
+  z <- abs(x)
+  finite <- is.finite(z)
+  tolerance <- sqrt(.Machine$double.eps) * 10^-digits
+  z[finite] <- z[finite] + pmin(tolerance, .Machine$double.xmax - z[finite])
+  z <- round(z, digits = digits)
+  z <- ifelse(!is.na(z) & z > 0, z * posneg, z)
+
+  dim(z) <- d
+  dimnames(z) <- dn
+  names(z) <- n
+
+  z
+}
+
+#' Format numbers with fixed decimal places
+#'
+#' Round with [round_half_away_from_zero()] and format with a fixed number of
+#' decimal places. Decimal ties round half away from zero, and values that
+#' round to zero display as positive zero (for example, `"0.0"` rather than
+#' `"-0.0"`).
+#'
+#' @param x A numeric vector.
+#' @param digits A non-negative, integer-valued scalar giving the number of
+#'   decimal places.
+#' @param width `NULL`, or a non-negative, integer-valued scalar giving the
+#'   minimum field width passed to [base::formatC()]. The default, `NULL`, does
+#'   not set a minimum width.
+#'
+#' @return A character vector containing the formatted values.
+#'
+#' @export
+#'
+#' @examples
+#' format_number(c(1.25, -1.25), digits = 1)
+#' format_number(c(6.25, -0.04), digits = 1, width = 5)
+format_number <- function(x, digits = 1, width = NULL) {
+  if (!is.numeric(digits) || length(digits) != 1L || is.na(digits) ||
+    !is.finite(digits) || digits %% 1 != 0 || digits < 0) {
+    stop("`digits` must be one non-negative integer.", call. = FALSE)
+  }
+  if (!is.null(width) &&
+    (!is.numeric(width) || length(width) != 1L || is.na(width) ||
+      !is.finite(width) || width %% 1 != 0 || width < 0)) {
+    stop("`width` must be NULL or one non-negative integer.", call. = FALSE)
+  }
+
+  x <- round_half_away_from_zero(x, digits = digits)
+
+  out <- if (is.null(width)) {
+    formatC(x, digits = digits, format = "f")
+  } else {
+    formatC(x, digits = digits, format = "f", width = width)
+  }
+
+  out
+}

_pkgdown.yml

@@ -85,6 +85,10 @@ reference:
 - title: Outdata
   contents:
   - "outdata"
+- title: Formatting
+  contents:
+  - "round_half_away_from_zero"
+  - "format_number"
 - title: Utilities
   contents:
   - "default_apply"

tests/testthat/test-independent-testing-define.R

@@ -69,7 +69,6 @@ test_that("warning if one of name is not in the plan data frame of meta define_o
 })
 
 
-
 test_that("meta_adam class object with list population contains in the object at define_observation", {
   expect_equal(names(z)[4], "observation")
 })

tests/testthat/test-independent-testing-meta_check.R

@@ -4,7 +4,6 @@ test_that("variable 'RACE' checking", {
 })
 
 
-
 test_that("variable 'AEDECOD' checking in population", {
   expect_error(meta_check_var(meta_example(), var = "AEDECOD", type = c("population")))
 })
@@ -15,7 +14,6 @@ test_that("variable 'AEDECOD' checking in observation", {
 })
 
 
-
 test_that("variable 'BMIBL' checking in population or observation", {
   expect_error(meta_check_var(meta_example(), var = "BMIBL", type = c("population", "observation")))
 })

tests/testthat/test-independent-testing-printmeta_adam.R

@@ -37,5 +37,12 @@ meta <- meta_adam(
 
 
 test_that("meta print", {
-  testthat::expect_snapshot(meta |> print())
+  out <- capture.output(print(meta))
+  expect_true(any(grepl("ADaM metadata", out, fixed = TRUE)))
+  expect_true(any(grepl("Population data with 254 subjects", out, fixed = TRUE)))
+  expect_true(any(grepl("Observation data with 1191 records", out, fixed = TRUE)))
+  expect_true(any(grepl("Analysis plan with 1 plans", out, fixed = TRUE)))
+  expect_true(any(grepl("'apat'", out, fixed = TRUE)))
+  expect_true(any(grepl("'wk12'", out, fixed = TRUE)))
+  expect_true(any(grepl("'ae_summary'", out, fixed = TRUE)))
 })