R/weighted-median.R

In twolodzko/twextras: twextras

#' Weighted median
#' 
#' @param x       numeric vector.
#' @param weights numeric vector of weights the same length as x
#'                giving the weights to use for elements of x.
#' @param na.rm   a logical value indicating whether NA values
#'                should be stripped before the computation proceeds.
#' 
#' @export

weighted.median <- function(x, weights = rep(1/length(x), length(x)), na.rm = FALSE) {
  if (length(x) == 1)
    return(x)
  stopifnot(length(x) == length(weights))
  if (na.rm) {
    nas <- is.na(x)
    x <- x[!nas]
    w <- w[!nas]
  }
  ord <- order(x)
  x <- x[ord]
  w <- w[ord]
  w <- weights / sum(weights)
  csw <- cumsum(w)
  idx <- max(which(csw <= 0.5))
  if (abs(csw[idx+1] - 0.5) <= 1e-6)
    return((x[idx]+x[idx+1])/2)
  x[idx]
}