runchart: Run Charts with Automatic Rebasing

#'Return a list of the indices of blocks of sequential \code{NAs} in \code{base}.
#'
#'Calling \code{\link{sus}} returns a vector \code{base} with some values
#'\code{NA} and some not. \code{base_gaps()} returns a list of the indices of
#'these blocks of \code{NAs}. This function is used by \code{\link{multi_shift}}.
#'
#'@param base baseline(s) generated by \code{\link{sus}}.
#'@return A list of the indices of blocks of sequential \code{NAs} in
#'  \code{base}. If \code{base} has no \code{NAs}, return \code{NULL}. If a
#'  block of \code{NAs} exists before the first sustained shift it is ignored.
#'@examples
#'runchart:::base_gaps(c(rep(NA,5), rep(3,8), rep(NA,25)))
#'@seealso \code{\link{ticker}} \code{\link{multi_shift}}
#'@keywords internal
#'@noRd

base_gaps <- function(base) {
  stopifnot(
    is.numeric(base),
    length(base) > 0
  )

  if (!any(is.na(base)) | all(is.na(base)))
    return(NULL)

  # wbase - working base
  index <- min(which(!is.na(base)))
  shift <- NULL

  while (TRUE) {

    wbase <- base[index:length(base)]

    if (all(!is.na(wbase)))
      return(shift)

    start <- min(which(is.na(wbase))) + index - 1
    wbase <- base[start:length(base)]

    if (all(is.na(wbase)))
      return(c(shift, list(start:length(base))))

    end <- min(which(!is.na(wbase))) + start - 2
    shift <- append(shift, list(start:end))

    index <- end + 1

  }
}

###############################################################################

#'Iterate through a vector and find the indices of all shifts relative to a
#'single (constant) baseline.
#'
#'Call this function once to iterate through all elements of a vector and return
#'the indices of all shifts relative to a single (constant) baseline. For a
#'changing baseline this function is used multiple times.
#'
#'@param base A numeric vector of length one. The current baseline value.
#'@param val A numeric vector. The vector \code{basic_shift} iterates over.
#'@param trigger The default number of observations for a shift is 6.
#'@return If shifts are found, the indices of these shifts. If not, \code{NULL}.
#'@examples
#'runchart:::basic_shift(base = 2, val = 1:8)
#'runchart:::basic_shift(base = 2, val = 1:7)
#'@seealso \code{\link{multi_shift}}
#'@keywords internal
#'@noRd

basic_shift <- function(base, val, trigger = 6) {
  stopifnot(
    is.numeric(base),
    is.numeric(trigger),
    length(base) == 1,
    length(trigger) == 1,
    length(val) > 1
  )

  if (!is.numeric(val))
    return(NULL)

  if (sum(val %notin% c(NA, base)) < trigger)
    return(NULL)

  start  <- shift <- min(which(base != val))
  updown <- sign(val[start] - base)
  shifts <- non_useful_obs <- NULL

  for (index in (start + 1):length(val)) {

    if (is.na(val[index])) {
      NULL
    }
    else if (val[index] == base) {
      non_useful_obs <- append(non_useful_obs, index)
    }
    else if (sign(val[index] - base) == updown) {
      shift <- append(shift, index)
    }
    else {
      non_useful_obs <- non_useful_obs[non_useful_obs > min(shift)]

      if (length(shift) >= trigger) {
        shifts <- append(shifts, shift)
        shifts <- append(shifts, non_useful_obs)
      }
      shift <- index
      updown <- -updown
    }
  }

  non_useful_obs <- non_useful_obs[non_useful_obs > min(shift)]

  if (length(shift) >= trigger) {
    shifts <- append(shifts, shift)
    shifts <- append(shifts, non_useful_obs)
  }

  if (is.null(shifts)) return(NULL) else return(sort(unique(shifts)))
}

###############################################################################

#'Create shift(s) for \code{val} using baselines generated by
#'\code{\link{sus}}.
#'
#'Shifts occur when 6 or more consecutive useful observations (non-NA and
#'different from the current baseline) land all above/below the baseline.
#'
#'@param val \code{multi_shift()} iterates along the elements of \code{val} to
#'  create shifts.
#'@param base baseline generated by \code{\link{sus}}.
#'@param base_ext extended baseline generated by \code{\link{sus}}.
#'@param trigger Number of data points required to create a shift.
#'@return A vector with all shifts observed in \code{val}. If no shifts observed,
#'  a vector full of \code{NA}s.
#'@examples
#'runchart:::multi_shift(val = c(rep(0,8), rep(1,8)),
#'base = c(rep(0,8), rep(NA,8)), base_ext = rep(0, 16))
#'@seealso \code{\link{basic_shift}}
#'@keywords internal
#'@noRd

multi_shift <- function(val, base, base_ext, trigger = 6) {
  stopifnot(
    is.numeric(trigger),
    length(val) > 0,
    length(base) > 0,
    length(base_ext) > 0,
    length(trigger) == 1
  )

  shift <- base * NA_real_

  if (all(is.na(base)))
    return(shift)

  gaps  <- base_gaps(base)

  if (length(gaps) == 0)
    return(shift)

  for (gap in gaps) {

    if (length(gap) < trigger)
      next

    indices <- basic_shift(base_ext[gap[1]], val[gap]) + gap[1] - 1

    if (is.null(indices))
      next
    else
      shift[indices] <- val[indices]
  }

  return(shift)
}