Outliers

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gpindex
 Title: Generalized Price and Quantity Indexes
-Version: 0.6.3.9002
+Version: 0.6.3.9004
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
     email = "marberts@protonmail.com",
@@ -33,4 +33,4 @@ Collate: 'helpers.R' 'means.R' 'weights.R' 'contributions.R' 'price_indexes.R'
 Config/testthat/edition: 3
 VignetteBuilder: quarto
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3

NAMESPACE

@@ -48,6 +48,7 @@ export(nested_contributions2)
 export(nested_mean)
 export(nested_transmute)
 export(nested_transmute2)
+export(outliers)
 export(paasche_index)
 export(quantity_index)
 export(quartile_method)

NEWS.md

@@ -2,6 +2,9 @@
 
 - Fixed a bug where `hb_transform()` would give an error with missing values.
 
+- Added a new function `outliers()` to replace existing outlier functions, which
+are now deprecated.
+
 ## gpindex 0.6.3
 
 - Bumped minimum version of R to >= 4.1.

R/outliers.R

@@ -2,27 +2,32 @@
 #'
 #' Standard cutoff-based methods for detecting outliers with price relatives.
 #'
-#' Each of these functions constructs an interval of the form \eqn{[b_l(x) -
+#' This function constructs an interval of the form \eqn{[b_l(x) -
 #' c_l \times l(x), b_u(x) + c_u \times u(x)]}{[bl(x) - cl * l(x), bu(x) + cu *
 #' u(x)]} and assigns a value in `x` as `TRUE` if that value does not
-#' belong to the interval, `FALSE` otherwise. The methods differ in how
-#' they construct the values \eqn{b_l(x)}{bl(x)}, \eqn{b_u(x)}{bu(x)},
+#' belong to the interval, `FALSE` otherwise. The different methods differ in
+#' how they construct the values \eqn{b_l(x)}{bl(x)}, \eqn{b_u(x)}{bu(x)},
 #' \eqn{l(x)}, and \eqn{u(x)}. Any missing values in `x` are ignored when
 #' calculating the cutoffs, but will return `NA`.
 #'
-#' The fixed cutoff method is the simplest, and just uses the interval
-#' \eqn{[c_l, c_u]}{[cl, cu]}.
-#'
 #' The quartile method and Tukey algorithm are described in paragraphs 5.113 to
 #' 5.135 of the CPI manual (2020), as well as by Rais (2008) and Hutton (2008).
 #' The resistant fences method is an alternative to the quartile method, and is
 #' described by Rais (2008) and Hutton (2008). The Kimber method is yet another
 #' alternative. Quantile-based methods often
 #' identify price relatives as outliers because the distribution is
-#' concentrated around 1; setting `a > 0` puts a floor on the minimum
+#' concentrated around 1; setting `scale > 0` puts a floor on the minimum
 #' dispersion between quantiles as a fraction of the median. See the references
 #' for more details.
+# nolint start
+#'
+#' |                  | \eqn{b_l(x)}{bl(x)} | \eqn{b_u(x)}{bu(x)} | \eqn{l(x)}            | \eqn{u(x)}            |
+#' | ---              | --                  | ---                 | ---                   | ---                   |
+#' | Quartile         | \eqn{Q_2(x)}        | \eqn{Q_2(x)}        | \eqn{Q_2(x) - Q_1(x)} | \eqn{Q_3(x) - Q_2(x)} |
+#' | Resistant fences | \eqn{Q_1(x)}        | \eqn{Q_3(x)}        | \eqn{Q_3(x) - Q_1(x)} | \eqn{Q_3(x) - Q_1(x)} |
+#' | Kimber           | \eqn{Q_1(x)}        | \eqn{Q_3(x)}        | \eqn{Q_2(x) - Q_1(x)} | \eqn{Q_3(x) - Q_2(x)} |
 #'
+# nolint end
 #' The robust Z-score is the usual method to identify relatives in the
 #' (asymmetric) tails of the distribution, simply replacing the mean with the
 #' median, and the standard deviation with the median absolute deviation.
@@ -40,12 +45,14 @@
 #'
 #' @param x A numeric vector, usually of price relatives. These can be
 #'   made with, e.g., [back_period()].
-#' @param cu,cl A number giving the upper and lower cutoffs for each
-#'   element of `x`.
-#' @param a A number between 0 and 1 giving the scale factor for the
+#' @param upper,lower,cu,cl A number giving the upper and lower cutoffs for
+#'   each element of `x`.
+#' @param method The outlier detection method, one `"quartile"` (the default),
+#'   `"resistant-fences"`, `"kimber"`, `"robust-z"`, or `"tukey"`.
+#' @param scale,a A number between 0 and 1 giving the scale factor for the
 #'   median to establish the minimum dispersion between quartiles for each
 #'   element of `x`. The default does not set a minimum dispersion.
-#' @param type See [quantile()].
+#' @param quantile_type,type See [quantile()].
 #'
 #' @returns
 #' A logical vector, the same length as `x`, that is `TRUE` if the
@@ -79,181 +86,164 @@
 #'
 #' x <- rlnorm(10)
 #'
-#' fixed_cutoff(x)
-#' robust_z(x)
-#' quartile_method(x)
-#' resistant_fences(x) # always identifies fewer outliers than above
-#' tukey_algorithm(x)
+#' outliers(x, method = "robust-z")
+#' outliers(x, method = "quartile")
+#' # Always identifies fewer outliers than above.
+#' outliers(x, method = "resistant-fences")
+#' outliers(x, method = "tukey")
 #'
 #' log(x)
 #' hb_transform(x)
 #'
 #' # Works the same for grouped data.
 #'
 #' f <- c("a", "b", "a", "a", "b", "b", "b", "a", "a", "b")
-#' grouped(quartile_method)(x, group = f)
+#' grouped(outliers)(x, group = f)
 #'
-#' @name outliers
 #' @export
-quartile_method <- function(x, cu = 2.5, cl = cu, a = 0, type = 7) {
+outliers <- function(
+  x,
+  upper = 2.5,
+  lower = upper,
+  method = c(
+    "quartile",
+    "resistant-fences",
+    "kimber",
+    "robust-z",
+    "tukey"
+  ),
+  scale = 0,
+  quantile_type = 7
+) {
+  method <- match.arg(method)
   x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
+  upper <- as.numeric(upper)
+  if (upper < 0) {
+    stop("'upper' must be greater than 0")
   }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
+  lower <- as.numeric(lower)
+  if (lower < 0) {
+    stop("'lower' must be greater than 0")
   }
-  a <- as.numeric(a)
-  if (a < 0 || a > 1) {
-    stop("'a' must be between 0 and 1")
+  scale <- as.numeric(scale)
+  if (scale < 0 || scale > 1) {
+    stop("'scale' must be between 0 and 1")
   }
+  if (method %in% c("quartile", "resistant-fences", "kimber")) {
+    q <- stats::quantile(
+      x,
+      c(0.25, 0.5, 0.75),
+      names = FALSE,
+      na.rm = TRUE,
+      type = quantile_type
+    )
+    if (method == "quartile") {
+      u <- q[2L] + upper * pmax.int(q[3L] - q[2L], abs(scale * q[2L]))
+      l <- q[2L] - lower * pmax.int(q[2L] - q[1L], abs(scale * q[2L]))
+    } else if (method == "resistant-fences") {
+      iqr <- pmax.int(q[3L] - q[1L], abs(scale * q[2L]))
+      u <- q[3L] + upper * iqr
+      l <- q[1L] - lower * iqr
+    } else {
+      u <- q[3L] + upper * pmax.int(q[3L] - q[2L], abs(scale * q[2L]))
+      l <- q[1L] - lower * pmax.int(q[2L] - q[1L], abs(scale * q[2L]))
+    }
+  } else if (method == "robust-z") {
+    med <- stats::quantile(
+      x,
+      0.5,
+      names = FALSE,
+      na.rm = TRUE,
+      type = quantile_type
+    )
+    s <- pmax.int(stats::mad(x, med, na.rm = TRUE), abs(scale * med))
+    u <- med + upper * s
+    l <- med - lower * s
+  } else if (method == "tukey") {
+    q <- stats::quantile(
+      x,
+      c(0.05, 0.95),
+      names = FALSE,
+      na.rm = TRUE,
+      type = quantile_type
+    )
+    tail <- x < q[1L] | x > q[2L]
+    ts <- x[x != 1 & !tail]
+    if (length(ts) == 0L) {
+      return(tail)
+    }
+    # In some versions m is the median.
+    m <- mean(ts, na.rm = TRUE)
+    u <- min(m + upper * (mean(ts[ts >= m], na.rm = TRUE) - m), q[2L])
+    l <- max(m - lower * (m - mean(ts[ts <= m], na.rm = TRUE)), q[1L])
+  }
+  x > u | x < l
+}
 
-  q <- stats::quantile(
-    x,
-    c(0.25, 0.5, 0.75),
-    names = FALSE,
-    na.rm = TRUE,
-    type = type
+#' Quartile method
+#' @rdname outliers
+#' @export
+quartile_method <- function(x, cu = 2.5, cl = cu, a = 0, type = 7) {
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
   )
-  x <- x - q[2L]
-  u <- cu * pmax.int(q[3L] - q[2L], abs(a * q[2L]))
-  l <- -cl * pmax.int(q[2L] - q[1L], abs(a * q[2L]))
-  x > u | x < l
+  outliers(x, cu, cl, method = "quartile", a, type)
 }
 
 #' Resistant fences
 #' @rdname outliers
 #' @export
 resistant_fences <- function(x, cu = 2.5, cl = cu, a = 0, type = 7) {
-  x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
-  }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
-  }
-  a <- as.numeric(a)
-  if (a < 0 || a > 1) {
-    stop("'a' must be between 0 and 1")
-  }
-
-  q <- stats::quantile(
-    x,
-    c(0.25, 0.5, 0.75),
-    names = FALSE,
-    na.rm = TRUE,
-    type = type
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
   )
-  iqr <- pmax.int(q[3L] - q[1L], abs(a * q[2L]))
-  u <- q[3L] + cu * iqr
-  l <- q[1L] - cl * iqr
-  x > u | x < l
+  outliers(x, cu, cl, method = "resistant-fences", a, type)
 }
 
 #' Kimber method
 #' @rdname outliers
 #' @export
 kimber_method <- function(x, cu = 2.5, cl = cu, a = 0, type = 7) {
-  x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
-  }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
-  }
-  a <- as.numeric(a)
-  if (a < 0 || a > 1) {
-    stop("'a' must be between 0 and 1")
-  }
-
-  q <- stats::quantile(
-    x,
-    c(0.25, 0.5, 0.75),
-    names = FALSE,
-    na.rm = TRUE,
-    type = type
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
   )
-  u <- q[3L] + cu * pmax.int(q[3L] - q[2L], abs(a * q[2L]))
-  l <- q[1L] - cl * pmax.int(q[2L] - q[1L], abs(a * q[2L]))
-  x > u | x < l
+  outliers(x, cu, cl, method = "kimber", a, type)
 }
 
 #' Robust z-score
 #' @rdname outliers
 #' @export
 robust_z <- function(x, cu = 2.5, cl = cu) {
-  x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
-  }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
-  }
-
-  med <- stats::median(x, na.rm = TRUE)
-  s <- stats::mad(x, na.rm = TRUE)
-  x <- x - med
-  u <- cu * s
-  l <- -cl * s
-  x > u | x < l
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
+  )
+  outliers(x, cu, cl, method = "robust-z")
 }
 
 #' Fixed cutoff
 #' @rdname outliers
 #' @export
 fixed_cutoff <- function(x, cu = 2.5, cl = 1 / cu) {
-  x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
-  }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
-  }
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
+  )
   x > cu | x < cl
 }
 
 #' Tukey's algorithm
 #' @rdname outliers
 #' @export
 tukey_algorithm <- function(x, cu = 2.5, cl = cu, type = 7) {
-  x <- as.numeric(x)
-  cu <- as.numeric(cu)
-  if (cu < 0) {
-    stop("'cu' must be greater than 0")
-  }
-  cl <- as.numeric(cl)
-  if (cl < 0) {
-    stop("'cl' must be greater than 0")
-  }
-
-  q <- stats::quantile(
-    x,
-    c(0.05, 0.95),
-    names = FALSE,
-    na.rm = TRUE,
-    type = type
+  warning(
+    "this function is deprecated and will be removed in a future version;",
+    " use 'outliers()' instead"
   )
-  tail <- x < q[1L] | x > q[2L]
-  ts <- x[x != 1 & !tail]
-  if (length(ts) == 0L) {
-    return(tail)
-  }
-  # In some versions m is the median.
-  m <- mean(ts, na.rm = TRUE)
-  x <- x - m
-  u <- cu * (mean(ts[ts >= m], na.rm = TRUE) - m)
-  l <- -cl * (m - mean(ts[ts <= m], na.rm = TRUE))
-  x > u | x < l | tail
+  outliers(x, cu, cl, method = "tukey", quantile_type = type)
 }
 
 #' HB transform