R/navigate_network_dfs.R

In hydroloom: Utilities to Weave Hydrologic Fabrics

#' @title Navigate all Paths Depth First
#' @description given a starting node, return all reachable paths. Once visited,
#' a node is marked as visited and will not take part in a future path.
#' @param x data.frame containing hydroloom compatible network or list
#' as returned by \link{make_index_ids} ("to" mode for downstream or "from" mode
#' for upstream). The index list format avoids recreating the index ids for every call
#' to navigate network dfs in the case that it needs to be called many times.
#' @param starts vector with ids from x to start at.
#' @param direction character "up", "upmain", "down", or "downmain". If "upmain" or
#' "downmain", x must contain sufficient information to construct an upmain and
#' downmain network (see details).
#' @param reset logical if TRUE, reset graph for each start such that later paths
#' will have overlapping results.
#'
#' @details
#' `navigate_network_dfs` offers two usage patterns. In the simple case,
#' you can provide an `hy` in which case preprocessing is performed automatically,
#' or you can do the preprocessing ahead of time and provide index ids. The latter
#' is more complicated but can be much faster in certain circumstances.
#'
#' `hy` object:
#'
#' If the function will only be called one or a few times, it can be called
#' with x containing (at a minimum) `id` and `toid`. For "upmain" and "downmain"
#' support, x also requires attributes for determination of the primary upstream
#' and downstream connection across every junction.
#'
#' In this pattern, the `hy` object will be passed to  \link{make_index_ids}
#' called for every call to `navigate_network_dfs` and the resulting index ids
#' will be used for network navigation.
#'
#' Index ids:
#'
#' If the function will be called repeatedly or index_ids are available for
#' other reasons, the index_id list as created by \link{make_index_ids} ("to"
#' mode for downstream or "from" mode for upstream). For "upmain"
#' and "downmain" support, the `main` element must be included.
#'
#' @returns list containing dfs result for each start.
#' @export
#' @examples
#'
#' x <- hy(sf::read_sf(system.file("extdata/new_hope.gpkg", package = "hydroloom")))
#'
#' x <- add_toids(x, return_dendritic = FALSE)
#'
#' navigate_network_dfs(x, 8893402)
#'
#' navigate_network_dfs(x, 8897784, direction = "up")
#'
navigate_network_dfs <- function(x, starts, direction = "down", reset = FALSE) {

  # check if we to index ids or from index ids
  # should this be done with a class attribute?

  if (all(c("to", "lengths", "to_list") %in% names(x))) {

    if (!grepl("down", direction))
      stop("Direction must be 'down' if x contains to index ids")

    if (grepl("main", direction) && !"main" %in% names(x))
      stop("for downmain, index ids must include main element")

  } else if (all(c("froms", "lengths", "froms_list") %in% names(x))) {

    if (!grepl("up", direction))
      stop("Direction must be 'up' if x contains from index ids")

    if (grepl("main", direction) && !"main" %in% names(x))
      stop("for upmain, index ids must include main element")

  } else {

    # prepare the flownetwork for navigation
    # all of this has to be done seperately for the above two cases

    if (!inherits(x, "data.frame"))
      stop("if x is not a length three list as
            returned by make_index_ids
            it must be a data.frame that can be coerced
            to an hy object.")

    x <- hy(x, clean = TRUE)

    x <- try_add_toids(x, flownetwork = grepl("main", direction))

    if (grepl("up", direction)) {
      g <- make_index_ids(x, mode = "from")
    } else {
      g <- make_index_ids(x, mode = "to")
    }

    rm(x) # this can be huge

  }

  if (!exists("g", inherits = FALSE)) {
    g <- x
    rm(x)
  }

  # if we are going upstream, we need to update names
  # the code below assumes the graph is directed where we are going
  if (grepl("up", direction)) {
    names(g)[names(g) == "froms"] <- "to"
    names(g)[names(g) == "froms_list"] <- "to_list"

    names(g$to_list)[names(g$to_list) == "fromindid"] <- "toindid"
  }

  # if the above resulted in dat that won't work
  if (grepl("main", direction) && !"main" %in% names(g))
    stop("main path must be provided for downmain navigation")

  # make sure this will actually work!
  if (!all(starts %in% g$to_list$id)) stop("all starts must be in x")

  main <- grepl("main", direction)

  navigate_network_dfs_internal(g, starts, reset, main)

}

#' @param ind_id_mode logical if TRUE, no id transformations are applied. all_starts is assumed to be in index_id space
#' @noRd
navigate_network_dfs_internal <- function(g, all_starts, reset, main, ind_id_mode = FALSE) {

  if (!ind_id_mode) {
    # these are in indid space
    all_starts <- unique(g$to_list$indid[match(all_starts, g$to_list$id)])
  }

  # if reset is TRUE, we keep all connections in subsequent starts runs
  if (reset) save_to <- g$to

  # Some vectors to track results
  # indexes into the full set from all starts
  # used to pull out members of the DFS
  set_index <-
    # indexes into the current path
    # use to split apart the members of the dfs into paths
    path_index <-
    # used to track which path tops we need to go back to
    # this is pre-allocated much much longer than needed
    # a special pointer is used to interact with this tracking vector
    to_visit_pointer <- rep(0, ncol(g$to))

  # to track where we've been
  visited_tracker <- rep(NA_integer_, ncol(g$to))

  # will store output sets (per start) and paths (per sub path)
  out_list <- rep(list(list()), length(all_starts))

  # output set and path ids used to populate out_list
  set_id <- 1
  path_id <- 1

  for (start in all_starts) {

    # Set up the starting node we change node below so this just tracks for clarity
    node <- start

    # within set node tracker
    node_index <- 1
    # v is a pointer into the to_visit_pointer vector
    visit_index <- 1

    # special handler for empty paths
    none_in_path <- TRUE

    # trigger for making a new path
    new_path <- FALSE

    # only reset if we are explicitely asking for overlapping paths
    if (reset) visited_tracker <- rep(NA_integer_, ncol(g$to))

    while (visit_index > 0) {

      if (is.na(visited_tracker[node])) {
        # this is the first time we've seen this,
        # add it to the set in the current path.
        set_index[node_index] <- node
        path_index[node_index] <- path_id
        node_index <- node_index + 1

        visited_tracker[node] <- node_index

        # this path has stuff
        none_in_path = FALSE
      }

      # now look at what's downtream
      if (main) {

        for (to in seq_len(g$lengths[node])) {
          if (g$to[to, node] != 0 && g$main[to, node]) {
            # Add the next node to visit to the tracking vector
            to_visit_pointer[visit_index] <- g$to[to, node]

            # break the graph where we've been so we stop next time
            g$to[to, node] <- 0

            # add to the visit index
            visit_index <- visit_index + 1
          }
        }

      } else {
        for (to in seq_len(g$lengths[node])) {
          # Add the next node to visit to the tracking vector
          to_visit_pointer[visit_index] <- g$to[to, node]

          # break the graph where we've been so we stop next time
          g$to[to, node] <- 0

          # add to the visit index
          visit_index <- visit_index + 1
        }
      }

      # go to the last element added in to_visit_pointer
      visit_index <- visit_index - 1
      node <- to_visit_pointer[visit_index]

      # if nothing there, just increment to the next visit position
      # this indicates we hit a new path
      while (!node && visit_index > 0) {
        visit_index <- visit_index - 1
        node <- to_visit_pointer[visit_index]
        new_path <- TRUE
      }

      # if we just hit a new path we need to do a little setup
      if (new_path) {
        # increment the path id and set new_path back to FALSE
        path_id <- path_id + 1
        new_path <- FALSE

      }

    }

    if (none_in_path) {
      out_list[[set_id]] <- list()
    } else {
      if (!ind_id_mode) {
        out_list[[set_id]] <- split(
          pull(g$to_list, "id")[set_index[1:(node_index - 1)]],
          path_index[1:(node_index - 1)]
        )
      } else {
        out_list[[set_id]] <- split(set_index[1:(node_index - 1)], path_index[1:(node_index - 1)])
      }
    }

    set_id <- set_id + 1

    # for every start, we need to reset
    if (reset) g$to <- save_to

  }

  out_list

}