R/format_digits.R

In mintyr: Grouped and Nested Data Pipelines Built on 'data.table'

# WARNING - Generated by {fusen} from dev/flat_summary.Rmd: do not edit by hand # nolint: line_length_linter.

#' Format Numeric Columns to Fixed-Decimal Character Strings
#'
#' @param data        A data.frame or data.table. The input dataset.
#' @param cols        A character or integer vector specifying columns to format.
#'                    If NULL (default), all numeric columns are formatted.
#' @param digits      A non-negative integer specifying decimal places. Defaults to 2.
#' @param percentage  Logical. If TRUE, values are multiplied by 100 and a "%"
#'                    sign is appended. Defaults to FALSE.
#' @param nan_as_na   Logical. If TRUE, NaN is treated identically to NA and
#'                    coerced to NA_character_. If FALSE (default), NaN is
#'                    preserved as the string "NaN".
#'
#' @return A data.table with the specified numeric columns formatted as character
#'         strings. The original object is never modified.
#'
#' @details
#' The function processes columns in the following order:
#' \enumerate{
#'   \item Validates all input parameters with informative error messages.
#'   \item Copies the input only once: data.table inputs are deep-copied via
#'         \code{copy()}; data.frame inputs are copied implicitly by
#'         \code{as.data.table()}, avoiding a redundant second copy.
#'   \item Resolves \code{cols} to a character vector of valid numeric column
#'         names, warning and skipping any non-numeric columns specified.
#'   \item Applies a vectorised formatting function via
#'         \code{lapply(.SD, fn)} and \code{:=}, so all target columns are
#'         dispatched in a single data.table call rather than a column-by-column
#'         loop.
#' }
#'
#' NA and NaN handling:
#' \itemize{
#'   \item \code{NA_real_} is always returned as \code{NA_character_}.
#'   \item \code{NaN} is returned as \code{"NaN"} by default. Set
#'         \code{nan_as_na = TRUE} to coerce it to \code{NA_character_} instead.
#' }
#'
#' Rounding uses explicit \code{round()} before \code{sprintf()} to guarantee
#' consistent results across platforms (Windows, Linux, macOS), where the
#' underlying C library's rounding behaviour may otherwise differ.
#'
#' @note
#' \itemize{
#'   \item \code{data} must be a data.frame or data.table.
#'   \item Integer column indices in \code{cols} are converted to column names
#'         internally; duplicates are silently removed.
#'   \item \code{digits} accepts numeric values such as \code{2.0} and coerces
#'         them to integer; non-integer-valued numbers raise an error.
#'   \item The function depends only on \code{data.table} and base R.
#' }
#'
#' @import data.table
#' @export
#' @examples
#' # Example: Number formatting demonstrations
#'
#' # Setup test data
#' dt <- data.table::data.table(
#'   a = c(0.1234, 0.5678),      # Numeric column 1
#'   b = c(0.2345, 0.6789),      # Numeric column 2
#'   c = c("text1", "text2")     # Text column
#' )
#'
#' # Example 1: Format all numeric columns
#' format_digits(
#'   dt,                         # Input data table
#'   digits = 2                  # Round to 2 decimal places
#' )
#'
#' # Example 2: Format specific column as percentage
#' format_digits(
#'   dt,                         # Input data table
#'   cols = c("a"),              # Only format column 'a'
#'   digits = 2,                 # Round to 2 decimal places
#'   percentage = TRUE           # Convert to percentage
#' )
format_digits <- function(data,
                          cols       = NULL,
                          digits     = 2L,
                          percentage = FALSE,
                          nan_as_na  = FALSE) {
  # -- 1. Input validation ----------------------------------------------------
  if (!is.data.frame(data))
    stop("`data` must be a data.frame or data.table.", call. = FALSE)
  .check_flag(percentage, "percentage")
  .check_flag(nan_as_na, "nan_as_na")
  # Length/type are checked before any scalar comparison, so a vector input
  # gets this message instead of an "invalid 'length' in coercion" error.
  digits <- .check_count(digits, "digits", 0L)

  # -- 2. One copy: the result is modified by reference below ------------------
  result <- if (data.table::is.data.table(data)) data.table::copy(data)
            else data.table::as.data.table(data)

  # -- 3. Target columns --------------------------------------------------------
  if (is.null(cols)) {
    target_cols <- names(result)[vapply(result, is.numeric, logical(1L))]
    if (length(target_cols) == 0L) {
      message("`data` contains no numeric columns. Returning a copy of the input.")
      return(result)
    }
  } else {
    cols   <- .resolve_cols(cols, names(result), "cols")
    is_num <- vapply(cols, function(cn) is.numeric(.subset2(result, cn)), logical(1L))
    if (any(!is_num))
      warning("The following columns are not numeric and will be skipped: ",
              paste(cols[!is_num], collapse = ", "), call. = FALSE)
    target_cols <- cols[is_num]
    if (length(target_cols) == 0L) {
      message("No formattable numeric columns remain. Returning a copy of the input.")
      return(result)
    }
  }

  # -- 4. Formatter -------------------------------------------------------------
  fmt_tpl <- paste0("%.", digits, "f", if (percentage) "%%" else "")
  scale   <- if (percentage) 100 else 1
  fmt_fn  <- function(x) {
    val <- sprintf(fmt_tpl, round(x * scale, digits))
    val <- data.table::fifelse(is.na(x) & !is.nan(x), NA_character_, val)
    if (nan_as_na) val <- data.table::fifelse(is.nan(x), NA_character_, val)
    val
  }

  # -- 5. In-place update -------------------------------------------------------
  result[, (target_cols) := lapply(.SD, fmt_fn), .SDcols = target_cols]
  result[]
}