1#' Most frequently occurring value
2#'
3#' @param x vector of values
4#' @param na.rm logical.  Should \code{NA} values be removed before processing?
5#' @param ties character. Which value(s) should be returned in the case of ties?
6#' @param \dots optional additional parameters.
7#'
8#' @return vector of the same class as \code{x}
9#'
10#' @examples
11#'
12#' # Character vector
13#' chr_vec <- c("a", "d", "d", "h", "h", NA, NA) # Multiple modes
14#' stat_mode(x = chr_vec)
15#' stat_mode(x = chr_vec, na.rm = FALSE)
16#' stat_mode(x = chr_vec, na.rm = FALSE, ties = "first")
17#' stat_mode(x = chr_vec, na.rm = FALSE, ties = "last")
18#'
19#' # - # Numeric vector
20#' # See that it keeps the original vector type
21#' num_vec <- c(2, 3, 3, 4, 4, NA, NA)
22#' stat_mode(x = num_vec)
23#' stat_mode(x = num_vec, na.rm = FALSE)
24#' stat_mode(x = num_vec, na.rm = FALSE, ties = "first")
25#' stat_mode(x = num_vec, na.rm = FALSE, ties = "last")
26#'
27#' # The default option is ties="all" but it is very easy for the user to control
28#' # the ties without changing this parameter.
29#' # Select always just one mode, being that the first mode
30#' stat_mode(x = num_vec)[1]
31#'
32#' # Select the first and the second stat_mode
33#' stat_mode(x = num_vec)[c(1, 2)]
34#'
35#' # Logical Vectors
36#' stat_mode(x = c(TRUE, TRUE))
37#' stat_mode(x = c(FALSE, FALSE, TRUE, TRUE))
38#'
39#' # - # Single element cases
40#' stat_mode(x = c(NA_real_))
41#' stat_mode(x = 2)
42#' stat_mode(x = NA)
43#' stat_mode(x = c("a"))
44#'
45#' # Not allowing multiple stat_mode, returning NA if that happens
46#' stat_mode(x = c(1, 1, 2, 2), multiple_modes = FALSE) # multiple stat_mode
47#' stat_mode(x = c(1, 1), multiple_modes = FALSE) # single mode
48#'
49#' # Empty vector cases
50#' # The ties of any empty vector will be itself (an empty vector of the same type)
51#' stat_mode(x = double())
52#' stat_mode(x = complex())
53#' stat_mode(x = vector("numeric"))
54#' stat_mode(x = vector("character"))
55#' @importFrom stats na.omit
56#' @export
57stat_mode <- function(x,
58                      na.rm = TRUE,
59                      ties = c("all", "first", "last", "missing"),
60                      ...) {
61  ties <- match.arg(ties)
62
63  if (na.rm) {
64    uv <- unique(na.omit(x))
65  } else {
66    uv <- unique(x)
67  }
68
69  tab <- tabulate(match(x, uv))
70
71  all_modes <- uv[tab == max(tab)]
72
73  if (length(all_modes) > 1) {
74    if (ties == "first") {
75      return(all_modes[1])
76    } else if (ties == "last") {
77      return(all_modes[length(all_modes)])
78    } else if (ties == "all") {
79      return(all_modes)
80    } # ties=="missing"
81    else {
82      return(NA)
83    }
84  }
85  else {
86    return(all_modes)
87  }
88}
89