R/rolling_window.R

In MartinHoldrege/turnr: Normalization of Test Utilization Rate

# functions for calculating various metrics on a rolling window basis.

#' @import dplyr


# roll over elements of a list --------------------------------------------


roll_list <-  function(x, window, align = "center") {
    # args:
    #   x--a list
    #   window--positive odd integer which is the rolling window width
    #         (ie number of list elements),
    #   align--string if cent4er then moving window where current element
    #       is middle of window, if right it is at the right side of the window.
    # returns:
    #   list the same length of x, where each element consists of
    #   the elements of the list x within that window

    stopifnot(
        is.list(x),
        length(x) >= 1,
        length(window) == 1,
        window >= 1
    )

    if ((window %% 2) != 1 & align == "center") {
        stop("window argument must be a odd positive integer when align = center")
    }

    half_window <- (window-1)/2
    out <- vector("list", length(x))

    for (i in seq_along(x)) {
        # start index
        if (align == "center") {
            start <- max(1, i-half_window)
            end <- min(i + half_window, length(x))
        } else if (align == "right") {
            start <- max(1, i - window + 1)
            end <- i
        } else {
            stop("incorrect value for argument align")
        }
        keep <- start:end # list indices to keep for this list element
        out[[i]] <- x[keep]
    }
    out
}

# epi week moving window --------------------------------------------------

#' Rolling window average across epiweeks.
#'
#' Used for calculating a centered rolling window average at the weekly level,
#' adjusted by the number of days in those weeks
#'
#' @param x numeric vector of tests per epiweek (or tests/device)
#' @param n_days numeric vector, number of days per epi week
#' @param width width (weeks) of rolling window
#' @param na.rm logical of weather to discard NAs.
#' @return Moving average in units/week
#' @examples
#' x <- c(4, 14, 14, 14, 10, 10, 10, 10, 5)
#' n_days <- c(2, rep(7, times = (length(x) -2)), 3)
#' n_days
#' y <- rollapply_epi(x, n_days = n_days)
#' y
#'
#' @export

rollapply_epi <- function(x, n_days, width = 3, na.rm = FALSE) {

    stopifnot(length(x) == length(n_days),
              is.numeric(x),
              is.numeric(n_days),
              length(width) == 1,
              is.logical(na.rm))

    if (any(is.na(n_days) & !is.na(x))){
        stop("n_days argument is NA when x isn't")
    }

    if (!na.rm) {
        days_in_window <- zoo::rollapply(n_days, width = width, FUN= sum,
                                         na.rm = FALSE, partial = TRUE)

        window_sum <- zoo::rollapply(x, width = width, FUN= sum,
                                     na.rm = FALSE, partial = TRUE)
    } else {

        # if window sum is na then thos n_days shouldn't count--only a problem
        # when doing na.rm = TRUE
        n_days[is.na(x) & !is.na(n_days)] <- 0

        days_in_window <- zoo::rollapply(n_days, width = width, FUN= sum,
                                         na.rm = TRUE, partial = TRUE)

        window_sum <- zoo::rollapply(x, width = width, FUN= sum,
                                     na.rm = TRUE, partial = TRUE)

    }


    weeks_in_window <- days_in_window/7

    # moving window average--units (count/week)
    x_mwa <- window_sum/weeks_in_window

    x_mwa
}