1#' Calculates the weighted medians for each row (column) in a matrix 2#' 3#' Calculates the weighted medians for each row (column) in a matrix. 4#' 5#' The implementations of these methods are optimized for both speed and 6#' memory. If no weights are given, the corresponding 7#' \code{\link{rowMedians}}()/\code{colMedians()} is used. 8#' 9#' @inheritParams rowAlls 10#' @inheritParams rowDiffs 11#' @inheritParams rowWeightedMeans 12#' 13#' @param ... Additional arguments passed to \code{\link{weightedMedian}}(). 14#' 15#' @return Returns a \code{\link[base]{numeric}} \code{\link[base]{vector}} of 16#' length N (K). 17#' 18#' @example incl/rowWeightedMedians.R 19#' 20#' @author Henrik Bengtsson 21#' 22#' @seealso Internally, \code{\link{weightedMedian}}() is used. 23#' See \code{\link{rowMedians}}() and \code{colMedians()} for non-weighted 24#' medians. 25#' 26#' @keywords array iteration robust univar 27#' @export 28rowWeightedMedians <- function(x, w = NULL, rows = NULL, cols = NULL, 29 na.rm = FALSE, ..., useNames = NA) { 30 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 31 # Validate arguments 32 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 33 # Argument 'x': 34 if (!is.matrix(x)) defunctShouldBeMatrix(x) 35 36 # Argument 'w': 37 has_weights <- !is.null(w) 38 if (has_weights) { 39 n <- ncol(x) 40 if (length(w) != n) { 41 stop(sprintf("The length of argument '%s' does not match the number of %s in '%s': %d != %d", "w", "columns", "x", length(w), n)) #nolint 42 } 43 if (!is.numeric(w)) { 44 stop(sprintf("Argument '%s' is not numeric: %s", "w", mode(w))) 45 } 46 if (any(!is.na(w) & w < 0)) { 47 stop(sprintf("Argument '%s' must not contain negative values", "w")) 48 } 49 } 50 51 # Apply subset on x 52 if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE] 53 else if (!is.null(rows)) x <- x[rows, , drop = FALSE] 54 else if (!is.null(cols)) x <- x[, cols, drop = FALSE] 55 56 # Apply subset on w 57 if (!is.null(w) && !is.null(cols)) w <- w[cols] 58 59 60 if (has_weights) { 61 # Allocate results 62 m <- nrow(x) 63 if (m == 0L) 64 return(double(0L)) 65 66 res <- apply(x, MARGIN = 1L, FUN = function(x) { 67 weightedMedian(x, w = w, na.rm = na.rm, ...) 68 }) 69 70 # Preserve names attribute? 71 if (!(is.na(useNames) || useNames)) { 72 names(res) <- NULL 73 } 74 75 w <- NULL # Not needed anymore 76 } else { 77 res <- rowMedians(x, na.rm = na.rm, useNames = useNames) 78 } 79 80 res 81} 82 83 84#' @rdname rowWeightedMedians 85#' @export 86colWeightedMedians <- function(x, w = NULL, rows = NULL, cols = NULL, 87 na.rm = FALSE, ..., useNames = NA) { 88 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 89 # Validate arguments 90 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 91 # Argument 'x': 92 if (!is.matrix(x)) defunctShouldBeMatrix(x) 93 94 # Argument 'w': 95 has_weights <- !is.null(w) 96 if (has_weights) { 97 n <- nrow(x) 98 if (length(w) != n) { 99 stop(sprintf("The length of argument '%s' does not match the number of %s in '%s': %d != %d", "w", "rows", "x", length(w), n)) #nolint 100 } 101 if (!is.numeric(w)) { 102 stop(sprintf("Argument '%s' is not numeric: %s", "w", mode(w))) 103 } 104 if (any(!is.na(w) & w < 0)) { 105 stop(sprintf("Argument '%s' must not contain negative values", "w")) 106 } 107 } 108 109 # Apply subset on x 110 if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE] 111 else if (!is.null(rows)) x <- x[rows, , drop = FALSE] 112 else if (!is.null(cols)) x <- x[, cols, drop = FALSE] 113 114 # Apply subset on w 115 if (!is.null(w) && !is.null(rows)) w <- w[rows] 116 117 if (has_weights) { 118 # Allocate results 119 m <- ncol(x) 120 if (m == 0L) 121 return(double(0L)) 122 123 res <- apply(x, MARGIN = 2L, FUN = function(x) { 124 weightedMedian(x, w = w, na.rm = na.rm, ...) 125 }) 126 127 # Preserve names attribute? 128 if (!(is.na(useNames) || useNames)) { 129 names(res) <- NULL 130 } 131 132 w <- NULL # Not needed anymore 133 } else { 134 res <- colMedians(x, na.rm = na.rm, useNames = useNames) 135 } 136 137 res 138} 139