R/backtrace_values.R

In dschoenig/IDENTcc: Catch and correct errors in IDENT datasets

#' Backtrace values
#'
#' `backtrace_values()` traces a chain of entries with the same value backwards through a vector.
#'
#' Supplied with a vector `starts` of starting points (e.g. as returned by
#' `detect_transitions()`), this function traces a value `backtrace_val`
#' backwards within a vector `x`. This defines a chain of entries whose value is
#' equal to the traced value. The output may be coerced to a logical vector and
#' used for indexing the original sequence (see examples).
#'
#' @param x A vector in which a value is to be traced backwards.
#' @param backtrace_val The value to be traced.
#' @param starts An integer vector of the same length as `x`, with starting
#'   points of a backwards chain being `1` and all other entries being `0`.
#'   As returned by `detect_transitions`
#' @return An integer vector of the same length as `x`, with values of `1` if the
#'   entry belongs to a chain, and `0` otherwise.
#' @examples
#' # Determine the start of a "Dead" to "Alive" transition for a sequence of
#' # mortality measurements
#' x <- c("Alive", "Almost dead", "Dead", "Dead", "Dead", "Alive", "Dead",
#'             "Dead", "Alive", "Dead", "Cut and Resprout", "Dead", "Alive")
#' da_starts <- detect_transitions(x, c("Dead", "Alive"))
#'
#' # Backtrace all values equal to "Dead"
#' backtrace_values(x, "Dead", da_starts)
#'
#' # Extract positions of the traced values
#' trace <- as.logical(backtrace_values(x, "Dead", da_starts))
#' which(trace)
#' x[trace]
#' @export
backtrace_values <- function(x, backtrace_val, starts) {
    if(length(backtrace_val) != 1) {
        stop("`backtrace_val` must be a vector of length `1`")
    }
    if(is.factor(x)) {
        x <- as.character(x)
    }

    n <- length(x)

    x_classified <- x
    x_classified[x == backtrace_val] <- 1
    x_classified[x != backtrace_val] <- 0
    x_classified <- as.integer(x_classified)

    # Matrix to connect each entry to the preceding one
    sb <- matrix(0, n, n)
    sb[seq(2, n^2, n+1)] <- 1

    # Create a network with entries of x as nodes, and edges between all entries
    # equal to `backtrace_val`. Then, for each node, restrict possible edges in
    # the network to the backwards nearest neighbor.
    x_adj <- outer(x_classified,x_classified) * sb

    # Length of uninterrupted backward paths that connect `backtrace_val` nodes
    x_graph <- igraph::graph_from_adjacency_matrix(x_adj)
    x_paths <- igraph::shortest.paths(x_graph, mode = "out")

    # Create vector of chains based on starting points supllied with `starts`
    x_paths <- x_paths + 1
    x_paths[x_paths == Inf] <- 0
    x_paths[x_paths > 0] <- 1
    backtrace_m <- starts %*% x_paths
    backtrace <- as.integer(drop(backtrace_m))

    return(backtrace)
}