R/look_back.r

In davefol/streakR: Utilities for Analyzing Streaks in Sequences

#' Find the average of the transformation of n previous elements.
#'
#' @param x input vector
#' @param length number of elements to look back (size of window)
#' @param rule an "adherance" function that transforms each element of the sequence
#' @param decay a function that describes how the importance of an observation should decrease with distance
#' @return numeric vector giving the average of the transformation of (length) previous elements
#' @examples
#' look_back(c(1,0,1,1,1,0,1,1,0,1,1))
#' look_back(c(1,2,3,4,5,6), rule = function(j){j>3}, decay = function(d){1/d})

#' @export
look_back <- function(x,length = 1,rule = function(j){j},decay = function(distance){rep(1,length(distance))}) {
  if (length > length(x)) stop("length of x must be greater than length parameter")

  summing <- mean

  # lag accepts a vector x and an int n and returns a vector y which is x shifted by n with NA filling
  lag <- function(x,n=1) {
    c(rep(NA,n),x[-(length(x):(length(x)-n+1))])
  }

  # Apply the adherance rule to each element of x.
    adherance <- lapply(x, rule)

    adherance <- unlist(adherance)

  # copy the adherance columns (length) times
    adherance.matrix <- rep(adherance, length)  # repeat
    adherance.matrix <- matrix(adherance.matrix,length(x))  # form into matrix
    split.adherance <- split(adherance.matrix,col(adherance.matrix)) # split a list of vectors

  # Lag each adherance column
  # A single row in x.windows shows the previous (length) elements for an element of x with the same index
    lag.adherance <- mapply(function(x,n){as.double(lag(x,n))},
           x = split.adherance,
           n = 1:length,
           SIMPLIFY = TRUE)

  # Apply the rule to each element of each row, reducing each row to an average of the rules output.
    apply(lag.adherance,MARGIN = 1, FUN = function(j){stats::weighted.mean(j,decay(1:length(j)))})
}