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