Added percent functions.

DESCRIPTION

@@ -56,5 +56,5 @@ Encoding: UTF-8
 Language: en-GB
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
 VignetteBuilder: knitr

NAMESPACE

@@ -1,8 +1,17 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[",percent)
+S3method(Math,percent)
+S3method(Ops,percent)
+S3method(as.character,percent)
+S3method(format,percent)
+S3method(print,percent)
+S3method(rep,percent)
+S3method(unique,percent)
 export(age_calculate)
 export(age_from_chi)
 export(age_group)
+export(as_percent)
 export(chi_check)
 export(chi_pad)
 export(create_age_groups)

R/percent.R

@@ -0,0 +1,194 @@
+#' Percentages
+#'
+#' @description
+#' `percent` is a lightweight S3 class allowing for pretty
+#' printing of proportions as percentages.
+#'
+#' @param x [numeric] vector of proportions.
+#'
+#' @returns
+#' A class of object `percent`.
+#'
+#' @details
+#' By default all percentages are formatted to 2 decimal places which can be
+#' overwritten using `format()`. It's worth noting that the digits argument in
+#' `format.percent` uses decimal rounding instead of significant digit rounding.
+#'
+#' @examples
+#' library(phsmethods)
+#'
+#' # Convert proportions to percentages
+#' as_percent(seq(0, 1, 0.1))
+#'
+#' # You can use round() as usual
+#' p <- as_percent(15.56 / 100)
+#' round(p)
+#' round(p, digits = 1)
+#'
+#' p2 <- as_percent(0.0005)
+#' signif(p2, 2)
+#' floor(p2)
+#' ceiling(p2)
+#'
+#' # We can do basic math operations as usual
+#'
+#' # Order of operations matters
+#' 10 * as_percent(c(0, 0.5, 2))
+#' as_percent(c(0, 0.5, 2)) * 10
+#'
+#' as_percent(0.1) + as_percent(0.2)
+#'
+#' # Formatting options
+#' format(as_percent(2.674 / 100), digits = 2, symbol = " (%)")
+#' # Prints nicely in data frames (and tibbles)
+#' library(dplyr)
+#' starwars %>%
+#'   count(eye_color) %>%
+#'   mutate(perc = as_percent(n/sum(n))) %>%
+#'   arrange(desc(perc))  %>% # We can do numeric sorting with percent vectors
+#'   mutate(perc_rounded = round(perc))
+#' @export
+#' @rdname percent
+as_percent <- function(x){
+  if (!is.numeric(x)){
+    stop("x must be a numeric vector of proportions")
+  }
+  new_percent(x)
+}
+new_percent <- function(x){
+  class(x) <- "percent"
+  x
+}
+round_half_up <- function(x, digits = 0){
+  if (is.null(digits) || (length(digits) == 1 && digits == Inf)){
+    return(x)
+  }
+  trunc(
+    abs(x) * 10^digits + 0.5 +
+      sqrt(.Machine$double.eps)
+  ) /
+    10^digits * sign(x)
+}
+signif_half_up <- function(x, digits = 6){
+  if (is.null(digits) || (length(digits) == 1 && digits == Inf)){
+    return(x)
+  }
+  round_half_up(x, digits - ceiling(log10(abs(x))))
+}
+
+#' @export
+as.character.percent <- function(x, digits = 2, ...){
+  if (length(x) == 0){
+    character()
+  } else {
+    paste0(unclass(round(x, digits) * 100), "%")
+  }
+}
+
+#' @export
+format.percent <- function(x, symbol = "%", trim = TRUE,
+                           digits = 2,
+                           ...){
+  if (length(x) == 0){
+    out <- character()
+  } else {
+    out <- paste0(format(unclass(round(x, digits) * 100), trim = trim, digits = NULL, ...),
+                  symbol)
+  }
+  names(out) <- names(x)
+  out
+}
+
+#' @export
+print.percent <- function(x, max = NULL, trim = TRUE,
+                          digits = 2,
+                          ...){
+  out <- x
+  N <- length(out)
+  if (N == 0){
+    print("percent(numeric())")
+    return(invisible(x))
+  }
+  if (is.null(max)) {
+    max <- getOption("max.print", 9999L)
+  }
+  suffix <- character()
+  max <- min(max, N)
+  if (max < N) {
+    out <- out[seq_len(max)]
+    suffix <- paste(" [ reached 'max' / getOption(\"max.print\") -- omitted",
+                    N - max, "entries ]\n")
+  }
+  print(format(out, trim = trim, digits = digits), ...)
+  cat(suffix)
+  invisible(x)
+}
+
+#' @export
+`[.percent` <- function(x, ..., drop = TRUE){
+  cl <- oldClass(x)
+  class(x) <- NULL
+  out <- NextMethod("[")
+  class(out) <- cl
+  out
+}
+
+#' @export
+unique.percent <- function(x, incomparables = FALSE,
+                           fromLast = FALSE, nmax = NA, ...){
+  cl <- oldClass(x)
+  class(x) <- NULL
+  out <- NextMethod("unique")
+  class(out) <- cl
+  out
+}
+
+#' @export
+rep.percent <- function(x, ...){
+  cl <- oldClass(x)
+  class(x) <- NULL
+  out <- NextMethod("rep")
+  class(out) <- cl
+  out
+}
+
+#' @export
+Ops.percent <- function(e1, e2){
+  math <- switch(.Generic,
+                 `+` =,
+                 `-` =,
+                 `*` =,
+                 `/` =,
+                 `^` =,
+                 `%%` =,
+                 `%/%` = TRUE, FALSE)
+  if (inherits(e2, "percent") && !inherits(e1, "percent")){
+    e1 <- unclass(e1)
+    e2 <- unclass(e2)
+  }
+  NextMethod(.Generic)
+}
+#' @export
+Math.percent <- function(x, ...){
+  rounding_math <- switch(.Generic,
+                          `floor` =,
+                          `ceiling` =,
+                          `trunc` =,
+                          `round` =,
+                          `signif` = TRUE, FALSE)
+  x <- unclass(x)
+  if (rounding_math){
+    x <- x * 100
+    if (.Generic == "round"){
+      out <- do.call(round_half_up, list(x, ...))
+    } else if (.Generic == "signif"){
+      out <- do.call(signif_half_up, list(x, ...))
+    } else {
+      out <- NextMethod(.Generic)
+    }
+    new_percent(out / 100)
+  } else {
+    out <- NextMethod(.Generic)
+    new_percent(out)
+  }
+}