R/sort_network.R

In hydroloom: Utilities to Weave Hydrologic Fabrics

#' Sort Network
#' @description given a network with an id and and toid, returns a sorted
#' and potentially split set of output. Sort is from top to bottom so
#' traversing the response from top to bottom will go from upstream to
#' downstream.
#'
#' Can also be used as a very fast implementation of upstream
#' with tributaries navigation. The full network from each
#' outlet is returned in sorted order.
#'
#' If a network includes diversions, all flowlines downstream of
#' the diversion are visited prior to continuing upstream. See
#' note on the `outlets` parameter for implications of this
#' implementation detail.
#'
#' @export
#' @param x data.frame network compatible with \link{hydroloom_names}.
#' @details
#'
#' Required attributes: `id`, `toid`
#'
#' @param split logical if TRUE, the result will be split into
#' independent networks identified by the id of their outlet. The
#' outlet id of each independent network is added as a "terminal_id"
#' attribute.
#' @param outlets same as id in x. if specified, only the network
#' emanating from these outlets will be considered and returned.
#' NOTE: If outlets does not include all outlets from a given
#' network containing diversions, a partial network may be returned.
#' @returns data.frame containing a topologically sorted version
#' of the requested network and optionally a terminal id.
#' @name sort_network
#' @examples
#' x <- sf::read_sf(system.file("extdata/new_hope.gpkg", package = "hydroloom"))
#'
#' g <- add_toids(x)
#'
#' head(g <- sort_network(g))
#'
#' g$topo_sort <- nrow(g):1
#'
#' plot(g['topo_sort'])
#'
#' g <- add_toids(x, return_dendritic = FALSE)
#'
#' g <- sort_network(g)
#'
#' g$topo_sort <- nrow(g):1
#'
#' plot(g['topo_sort'])
#'
sort_network <- function(x, split = FALSE, outlets = NULL) {
  UseMethod("sort_network")
}

#' @name sort_network
#' @export
#'
sort_network.data.frame <- function(x, split = FALSE, outlets = NULL) {
  hy_as_dataframe(x, "sort_network", split = split, outlets = outlets)
}

#' @name sort_network
#' @export
sort_network.hy <- function(x, split = FALSE, outlets = NULL) {
  hy_classify_and_redispatch(x, "sort_network", "hy_topo", hy_guidance_topo,
    split = split, outlets = outlets)
}

#' @name sort_network
#' @export
sort_network.hy_node <- function(x, split = FALSE, outlets = NULL) {
  hy_node_to_topo(x, "sort_network", split = split, outlets = outlets)
}

#' Topological sort implementation
#' @description Shared algorithm body for sort_network. Works on any data.frame
#' with id and toid columns (including non-unique id). Uses make_index_ids_impl()
#' to avoid S3 dispatch loops.
#' @param x data.frame with id, toid columns (geometry already dropped)
#' @param split logical
#' @param outlets optional outlet ids
#' @returns sorted data.frame (no class stamp, no geometry)
#' @noRd
sort_network_impl <- function(x, split = FALSE, outlets = NULL) {

  # index for fast traversal (no dispatch, no validation)
  index_ids <- make_index_ids_impl(x, mode = "both")

  if (!is.null(outlets)) {
    starts <- which(index_ids$to$to_list$id %in% outlets)
  } else {
    # All the start nodes -- outlets are rows whose toid does not refer to
    # any id in the network (tolerates any reserved-value convention).
    starts <- which(index_ids$to$to_list$id %in% x$id[is_outlet(x)])

    if (length(starts) == 0L) {
      warning("no outlets detected in network -- sort may produce incomplete ",
        "results. A future release will treat this as an error.",
        call. = FALSE)
    }
  }

  # Some vectors to track results
  to_visit <- out <- rep(0, length(index_ids$to$to_list$id))

  # Use to track if a node is ready to be visited.
  # will subtract from this and not visit the upstream until ready element = 1
  ready <- index_ids$to$lengths

  if (split) {
    set <- out
    out_list <- rep(list(list()), length(starts))
  }

  # output order tracker
  o <- 1
  set_id <- 1

  for (s in starts) {

    # Set up the starting node
    node <- s

    # within set node tracker for split = TRUE
    n <- 1
    # v is a pointer into the to_visit vector
    v <- 1

    trk <- 1

    while (v > 0) {

      # track the order that nodes were visited
      out[node] <- o
      # increment to the next node
      o <- o + 1

      if (split) {
        set[n] <- node
        n <- n + 1
      }

      # loop over upstream catchments
      # does nothing if froms_l[node] == 0

      for (from in seq_len(index_ids$from$lengths[node])) {

        # grab the next upstream node
        next_node <- index_ids$from$froms[from, node]

        # check if we have a node to visit
        if (!is.na(next_node)) {

          if (ready[next_node] == 1) {
            # Add the next node to visit to the tracking vector
            to_visit[v] <- next_node

            v <- v + 1
          } else {
            # we don't want to visit an upstream neighbor until all its
            # downstream neighbors have been visited. Ready is initialized
            # to the length of downstream neighbors and provides a check.
            ready[next_node] <- ready[next_node] - 1
          }

        }
      }

      # go to the last element added in to_visit
      v <- v - 1
      node <- to_visit[v]

      trk <- trk + 1

      if (trk > length(index_ids$to$to_list$id) * 2) {
        stop("runaway while loop, something wrong with the network?")
      }

    }

    if (split) {
      out_list[[set_id]] <- index_ids$to$to_list$id[set[1:(n - 1)]]
      set_id <- set_id + 1
    }
  }

  if (split) names(out_list) <- index_ids$to$to_list$id[starts]

  ### rewrites x into the correct order. ###
  id_order <- unique(x$id)[which(out != 0)]
  out <- out[out != 0]

  if (split && o - 1 != length(id_order)) stop("Are two or more outlets within the same network?")

  if (is.null(outlets) && length(unique(x$id)) != length(out))
    warning("some features missed in sort. Are there loops in the network?")

  x <- filter(x, .data$id %in% id_order) |>
    left_join(tibble(id = id_order, sorter = out), by = "id") |>
    arrange(desc(.data$sorter)) |>
    select(-"sorter")

  if (split) {

    # this is only two columns
    ids <- as(names(out_list), class(pull(x[1, 1])))

    out_list <- data.frame(ids = ids) |>
      mutate(set = out_list) |>
      unnest("set")

    names(out_list) <- c(terminal_id, id)

    ### adds grouping terminalID to x ###
    x <- left_join(x, out_list, by = names(x)[1])

  }

  x

}

#' @name sort_network
#' @export
sort_network.hy_flownetwork <- function(x, split = FALSE, outlets = NULL) {

  hy_g <- get_hyg(x, add = TRUE, id = id)

  x <- check_hy_outlets(x, fix = FALSE)

  x <- select(st_drop_geometry(x), id, toid, everything())

  x <- sort_network_impl(x, split, outlets)

  put_hyg(x, hy_g)

}

#' @name sort_network
#' @export
sort_network.hy_topo <- function(x, split = FALSE, outlets = NULL) {

  hy_g <- get_hyg(x, add = TRUE, id = id)

  x <- check_hy_outlets(x, fix = FALSE)

  if (!isTRUE(check_hy_graph(x))) {
    stop("found one or more pairs of features that reference eachother.
          Run check_hy_graph to identify issues.")
  }

  x <- select(st_drop_geometry(x), id, toid, everything())

  x <- sort_network_impl(x, split, outlets)

  x <- put_hyg(x, hy_g)

  classify_hy(x)

}

#' Add topo_sort
#' @description calls \link{sort_network} without support for splitting the network
#' and adds a `nrow:1` topo_sort attribute.
#' @param x data.frame network compatible with \link{hydroloom_names}.
#' @param outlets same as id in x. if specified, only the network
#' emanating from these outlets will be considered and returned.
#' @details
#'
#' Required attributes: `id`, `toid`
#'
#' @returns data.frame containing a topo_sort attribute.
#' @name add_topo_sort
#' @export
add_topo_sort <- function(x, outlets = NULL) {
  UseMethod("add_topo_sort")
}

#' @name add_topo_sort
#' @export
#'
add_topo_sort.data.frame <- function(x, outlets = NULL) {
  hy_as_dataframe(x, "add_topo_sort", outlets = outlets)
}

#' @name add_topo_sort
#' @export
add_topo_sort.hy <- function(x, outlets = NULL) {
  hy_classify_and_redispatch(x, "add_topo_sort", "hy_topo", hy_guidance_topo,
    outlets = outlets)
}

#' @name add_topo_sort
#' @export
add_topo_sort.hy_node <- function(x, outlets = NULL) {
  hy_node_to_topo(x, "add_topo_sort", outlets = outlets)
}

#' @name add_topo_sort
#' @export
add_topo_sort.hy_flownetwork <- function(x, outlets = NULL) {

  out <- sort_network(x, outlets = outlets)

  ids <- unique(out$id)

  dplyr::left_join(out,
    data.frame(id = ids,
      topo_sort = seq(from = length(ids), to = 1, by = -1)),
    by = "id")

}

#' @name add_topo_sort
#' @export
add_topo_sort.hy_topo <- function(x, outlets = NULL) {

  out <- sort_network(x, outlets = outlets)

  ids <- unique(out$id)

  out <- dplyr::left_join(out,
    data.frame(id = ids,
      topo_sort = seq(from = length(ids), to = 1, by = -1)),
    by = "id")

  classify_hy(out)

}