R/numbers.R

In neatR: Neat Data for Presentation

#' Round a number and display 0 digit in decimals
#' @noRd

nround <- function(x, digits = 1) {
  trimws(format(round(x, digits = digits), nsmall = digits))
}

#' Add comma or dot separation of thousands to chunk large numbers
#' @noRd

chunk_digits <- function(x, digits = 1, thousand_separator = ",") {
  nsmall <- digits
  decimal_separator <- data.table::fifelse(thousand_separator == ".", ",", ".")
  prettyNum(round(x, digits),
    nsmall = nsmall, big.mark = thousand_separator,
    decimal.mark = decimal_separator, scientific = FALSE
  )
}

#' Custom number formatting based on the values
#' @noRd

num_format <- function(n, ul, digits) {
  if (is.na(n)) {
    return(NA_character_)
  }
  ul_spaced <- data.table::fifelse(ul == "", "", paste0(" ", ul))
  k_raw <- log10(abs(n)) / 3
  limit <- length(ul) - 1
  k <- data.table::fifelse(
    n == 0, 0,
    data.table::fifelse(is.finite(k_raw), k_raw, limit + 1)
  )
  mx <- pmax(0, pmin(limit, as.integer(floor(k))))
  sn <- ul_spaced[mx + 1]
  sx <- nround(n / 10^(3 * mx), digits)
  paste0(sx, sn)
}

#' neat representation of numbers
#' @param number an integer or double.
#' @param digits number of digits to round-off. Default value is 1.
#' @param unit unit to which the number to be converted. See examples below.
#' @param unit_labels a vector of strings (optional) that gives the unit label
#' for thousand, million, billion and trillion.
#' @param prefix a string (optional) that can be prepended to the formatted
#' number.
#' @param suffix a string (optional) that can be appended at the end of the
#' formatted number.
#' @param thousand_separator a character (optional) that can be used to chunk
#' thousands to display large numbers. Default is set as comma, dot, comma or
#' underscore can be used.
#' @return String representation of numbers with suffix denoting
#' K for thousands,Mn for millions, Bn for billions, Tn for trillions.
#' A number lower than thousand is represented as it is.
#' @examples
#' x <- c(
#'   10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000,
#'   1000000000
#' )
#' nnumber(x)
#' nnumber(123456789.123456, digits = 1)
#' nnumber(123456789.123456, digits = 1, unit = "Mn", prefix = "$")
#' @export

nnumber <- function(
  number, digits = 1, unit = "custom",
  unit_labels = list(
    thousand = "K", million = "Mn",
    billion = "Bn", trillion = "Tn"
  ),
  prefix = "", suffix = "", thousand_separator = ","
) {
  # Handle default logical NA
  if (is.logical(number) && all(is.na(number))) {
    number <- as.numeric(number)
  }

  if (!is.numeric(number)) {
    stop("number must be a numeric type variable (vector).
    Try as.numeric(x) to convert to numeric type variable")
  }
  int_singleton_check(digits)
  str_singleton_check(unit)
  lst_str_check(unit_labels)
  str_singleton_check(prefix)
  str_singleton_check(suffix)

  if (!any(thousand_separator %in% c(",", ".", "_", "'", " "))) {
    stop(paste0(
      "thousand_separator can take any of the below values",
      " `.`, `,`, `_` Default is set as comma`,`"
    ))
  }
  ul <- unname(unlist(c(
    "",
    coalesce(unit_labels[["thousand"]], "K"),
    coalesce(unit_labels[["million"]], "Mn"),
    coalesce(unit_labels[["billion"]], "Bn"),
    coalesce(unit_labels[["trillion"]], "Tn")
  )))

  unit_factor <- c(1, 1e-3, 1e-6, 1e-9, 1e-12)
  is_na_mask <- is.na(number)


  if (unit == "custom") {
    y <- sapply(number, function(val) num_format(val, ul, digits))
  } else {
    if (unit == "auto") {
      k <- data.table::fifelse(number == 0, 0, log10(abs(number)) / 3)
      limit <- length(ul) - 1
      mx <- pmax(0, pmin(limit, as.integer(floor(k))))
      mode_mx <- which.max(tabulate(mx + 1)) - 1
      unit_idx <- mode_mx + 1
      fmt <- ul[unit_idx]
      ytemp <- chunk_digits(
        round(number * unit_factor[unit_idx], digits),
        digits = digits,
        thousand_separator
      )
      ytemp <- data.table::fifelse(ytemp == "0", "<0.1", ytemp)
      y <- paste0(ytemp, " ", fmt)
    } else {
      unit_idx <- match(unit, ul)
      if (is.na(unit_idx)) {
        stop(paste0(
          "`unit` parameter must be one of the following, ",
          "'', 'K', 'Mn', 'Bn', 'Tn' or 'auto' or 'custom'",
          "value in the `unit_labels` list."
        ))
      }
      fmt <- ul[unit_idx]
      ytemp <- chunk_digits(
        round(number * unit_factor[unit_idx], digits),
        digits = digits,
        thousand_separator
      )
      ytemp <- data.table::fifelse(ytemp == "0", "<0.1", ytemp)
      y <- paste0(ytemp, " ", fmt)
    }
  }
  out <- sandwich(y, prefix = prefix, suffix = suffix)
  out[is_na_mask] <- NA_character_
  out
}

#' Pretty printing of percentages
#' @noRd

pct <- function(x, is_decimal = TRUE) {
  if (is_decimal) {
    x <- x * 100
  }
  x
}


#' Add + or - sign before the number
#' @noRd

add_sign <- function(x, plus_sign = TRUE) {
  ifelse(plus_sign & x > 0, paste0("+", x), x)
}

#' Add percentage symbol at the end of the number
#' @noRd

add_psym <- function(x) {
  paste0(x, "%")
}

#' Show percentage in basis points
#' @noRd

num_sign <- function(x) {
  ifelse(x >= 0, "+", "-")
}

#' Growth label based on the sign of the value
#' @noRd

sign_label <- function(x) {
  ifelse(x == 0, "Flat", ifelse(x > 0, "Growth", "Drop"))
}

#' Basis point calculation
#' @noRd

nbps <- function(x) {
  paste0(ifelse(x >= 0, "+", ""), x * 10000, " bps")
}


#' neat representation of percentage
#' @param percent an integer or double representing percentage
#' @param is_ratio a Boolean variable. If the percent is raw,
#' the value to set as TRUE. See examples below.
#' If the percent variable is already pre-multiplied by 100
#' then the value to be set as FALSE.
#' @param digits number of digits to round-off
#' @param show_growth_factor an optional Boolean variable.
#' @param show_bps an optional parameter to get the percentage as basis points
#' If the percent exceeds |100%| then a string representing growth or drop as
#' readable factors. See examples below.
#' @param show_plus_sign a Boolean variable. If the percent is positive
#' then setting show_plus_sign = TRUE, includes an explicit + sign before the
#' percent
#' @return String representation of the percentages.
#' @examples
#' # Formatting 22.3%
#' npercent(0.223, is_ratio = TRUE, digits = 1)
#' npercent(22.3, is_ratio = FALSE, digits = 1)
#' # Formatting percentages with growth factors
#' npercent(c(-4.01, 2.56), is_ratio = TRUE, show_growth_factor = TRUE)
#' # Formatting percentages as basis points
#' npercent(
#'   c(-1, -0.5, -0.1, -0.01, 0, 0.01, 0.1, 0.5, 1),
#'   is_ratio = TRUE, show_bps = TRUE
#' )
#' @param is_decimal Deprecated. Use 'is_ratio' instead.
#' @param plus_sign Deprecated. Use 'show_plus_sign' instead.
#' @param factor_out Deprecated. Use 'show_growth_factor' instead.
#' @param basis_points_out Deprecated. Use 'show_bps' instead.
#' @export


npercent <- function(
  percent, is_ratio = TRUE, digits = 1,
  show_plus_sign = TRUE, show_growth_factor = FALSE, show_bps = FALSE,
  is_decimal = NULL, plus_sign = NULL, factor_out = NULL,
  basis_points_out = NULL
) {
  is_ratio <- .handle_deprecated_args(
    is_decimal, is_ratio, "is_decimal", "is_ratio"
  )
  show_plus_sign <- .handle_deprecated_args(
    plus_sign, show_plus_sign,
    "plus_sign", "show_plus_sign"
  )
  show_growth_factor <- .handle_deprecated_args(
    factor_out, show_growth_factor,
    "factor_out",
    "show_growth_factor"
  )
  show_bps <- .handle_deprecated_args(
    basis_points_out, show_bps,
    "basis_points_out", "show_bps"
  )

  # Handle default logical NA
  if (is.logical(percent) && all(is.na(percent))) {
    percent <- as.numeric(percent)
  }

  if (!is.numeric(percent)) {
    stop("percent must be of numeric type representing a percentage.
         Try as.numeric(x) to convert to numeric type")
  }
  is_na_mask <- is.na(percent)
  bool_singleton_check(is_ratio)
  int_singleton_check(digits)
  bool_singleton_check(show_plus_sign)
  bool_singleton_check(show_growth_factor)

  out <- percent |>
    pct(is_ratio)

  if (show_bps) {
    bp <- inpar(nbps(percent))
  } else {
    bp <- rep("", length(percent))
  }

  if (show_growth_factor) {
    gtemp <- out / 100
    gtemp_abs <- abs(gtemp)
    gfactor <- ifelse(gtemp >= 1,
      inpar(paste0(round(gtemp_abs, 1), "x Growth")),
      ifelse(gtemp <= -1,
        inpar(paste0(round(gtemp_abs, 1), "x Drop")),
        inpar(sign_label(gtemp))
      )
    )
  } else {
    gfactor <- rep("", length(percent))
  }

  final_out <- out |>
    nround(digits = digits) |>
    add_sign(plus_sign = show_plus_sign) |>
    add_psym()

  out <- paste0(final_out, gfactor, bp)
  out[is_na_mask] <- NA_character_
  out
}