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