R/make_node_topology.R

In hydroloom: Utilities to Weave Hydrologic Fabrics

utils::globalVariables(c("fromid", "."))

#' @title Make Node Topology from Edge Topology
#' @description creates a node topology table from an edge topology
#' @param x data.frame network compatible with \link{hydroloom_names}.
#' @details
#'
#' Required attributes: `id`, `toid`
#'
#' @param add_div data.frame of logical containing id and toid diverted paths to add.
#' Should have id and toid fields. If TRUE, the network will be interpreted as
#' a directed acyclic graph with downstream diversions included in the edge
#' topology.
#' @param add logical if TRUE, node topology will be added to x in return.
#' @returns data.frame containing id, fromnode, and tonode attributes or all
#' attributes provided with id, fromnode and tonode in the first three columns.
#'
#' If `add_div` is TRUE, will also add a `divergence` attribute where the
#' provided diverted paths are assigned value 2, existing main paths that
#' emanate from a divergence are assigned value 1, and all other paths
#' are assigned value 0.
#'
#' @seealso [hy_topo], [hy_node], [add_toids()]
#' @export
#' @name make_node_topology
#' @examples
#' x <- sf::read_sf(system.file("extdata/new_hope.gpkg", package = "hydroloom"))
#'
#' y <- dplyr::select(add_toids(x), -ToNode, -FromNode)
#'
#' y <- make_node_topology(y)
#'
#' # just the divergences which have unique fromids in x but don't in new hope.
#' div <- add_toids(dplyr::select(x, COMID, FromNode, ToNode),
#'   return_dendritic = FALSE)
#' div <- div[div$toid %in%
#'   x$COMID[x$Divergence == 2], ]
#'
#' y <- dplyr::select(add_toids(x), -ToNode, -FromNode)
#'
#' y <- make_node_topology(y, add_div = div)
#'
make_node_topology <- function(x, add_div = NULL, add = TRUE) {
  UseMethod("make_node_topology")
}

#' @name make_node_topology
#' @export
make_node_topology.data.frame <- function(x, add_div = NULL, add = TRUE) {

  x <- hy(x)

  orig_names <- attr(x, "orig_names")

  x <- make_node_topology(x, add_div, add)

  if (inherits(x, "hy")) {
    attr(x, "orig_names") <- orig_names
    if (!inherits(x, "hy")) class(x) <- c("hy", class(x))
    hy_reverse(x)
  } else {
    x
  }

}

#' @name make_node_topology
#' @export
make_node_topology.hy <- function(x, add_div = NULL, add = TRUE) {
  hy_classify_and_redispatch(x, "make_node_topology", "hy_topo",
    hy_guidance_topo, add_div = add_div, add = add)
}

#' @name make_node_topology
#' @export
make_node_topology.hy_flownetwork <- function(x, add_div = NULL, add = TRUE) {
  make_node_topology.hy_topo(x, add_div, add)
}

#' @name make_node_topology
#' @export
make_node_topology.hy_topo <- function(x, add_div = NULL, add = TRUE) {

  check_names(x, c(id, toid), "make_node_topology")

  hy_g <- get_hyg(x, add, id)

  x <- st_drop_geometry(x)

  if (length(unique(x$id)) != nrow(x) || isTRUE(add_div)) {
    if (!isTRUE(add_div))
      stop("duplicate identifiers found and 'add_div' is not TRUE")

    out <- make_nondendritic_topology(x)

    if (add) {

      x <- select(x, -all_of(toid)) |>
        distinct()

      x <- left_join(out, x, by = "id")

      rm(out)

      if (!is.null(hy_g)) {
        x <- sf::st_sf(left_join(x, hy_g, by = id))
      }

      orig_names <- attr(x, "orig_names")

      x <- x[, c(id, fromnode, tonode,
        names(x)[!names(x) %in% c(id, fromnode, tonode)])]

      attr(x, "orig_names") <- orig_names

      x <- classify_hy(x)

      return(x)
    }

  } else {

    # NA toid and toid-not-in-id are valid outlet markers under the
    # is_outlet() rule, so no validation of toid values is needed here.
    if (any(c(fromnode, tonode) %in% names(x))) stop("fromnode or tonode already in data")

    x <- sort_network(x)

    head_count <- nrow(x)
    head_nodes <- seq_len(head_count)

    x$fromnode <- head_nodes

    x <- left_join(x, select(x, all_of(c(id = id, tonode = fromnode))),
      by = c(toid = id))

    outlets <- is_outlet(x)

    x$tonode[outlets] <- seq(max(x$tonode, na.rm = TRUE) + 1,
      max(x$tonode, na.rm = TRUE) + sum(outlets))

    if (!is.null(add_div)) {
      # we need to get the node the divergences upstream neighbor goes to
      # first get the new outlet nodes for our old ids
      add_div <- st_drop_geometry(add_div[, 1:2])
      names(add_div)[1:2] <- c(id, toid)
      add_div <- left_join(select(add_div, all_of(c(id, toid))),
        select(x, all_of(c(id, tonode))), by = id)

      div2 <- add_div$toid
      div1 <- x$toid[x$id %in% add_div$id]

      # now join upstream renaming the tonode to fromnode
      x <- left_join(x, select(add_div, all_of(c(toid = toid, new_fromnode = tonode))),
        by = c(id = toid))

      x <- mutate(x, fromnode = ifelse(!is.na(.data$new_fromnode),
        .data$new_fromnode, .data$fromnode))

      x <- select(x, -all_of("new_fromnode"))

      x <- distinct(x)

      x <- mutate(x, divergence = ifelse(id %in% div2, 2, ifelse(id %in% div1, 1, 0)))
    }
  }
  if (add && !isTRUE(add_div)) {

    if (!is.null(hy_g)) {
      x <- sf::st_sf(left_join(x, hy_g, by = id))
    }

    x <- x[, c(id, toid, fromnode, tonode,
      names(x)[!names(x) %in% c(id, toid, fromnode, tonode)])]

    classify_hy(x)

  } else {

    x <- select(x, all_of(c(id, fromnode, tonode)))

    x

  }
}

#' @importFrom data.table setorder rbindlist
#' @noRd
make_nondendritic_topology <- function(x) {

  network_ids <- x$id

  # Create a unique node id that groups on sets of downstream ids. Two
  # fromids with identical downstream sets legitimately share a graph node
  # (the divergence or confluence they both resolve to). But fromids whose
  # downstream set is empty after dropping outlet rows do NOT share a graph
  # node with each other -- they are independent terminal flowlines, each
  # with its own pendant endpoint. Giving them a unique per-fromid node_id
  # prevents the spurious collapse that otherwise creates a single super-hub
  # node incident to every terminal in the partition. Outlet rows are
  # identified by membership (toid not present in network_ids) so this
  # works for any outlet convention, including unique-per-outlet identifiers.
  n <- select(x, all_of(c(fromid = id, toid))) |>
    filter(!is.na(.data$fromid) & !is.na(.data$toid))

  # Vectorized key construction: a single %in% over the full toid vector and
  # a single data.table grouped paste, replacing a group_by + mutate that
  # recomputed `toid %in% network_ids` per group and didn't scale to
  # multi-million-edge networks. Pre-sorting by (fromid, toid) means the
  # grouped paste produces sorted-collapsed keys without per-group sort().
  dt <- as.data.table(n)
  setorder(dt, fromid, toid)
  keyed <- dt[toid %in% network_ids,
    .(node_id = paste(toid, collapse = "-")),
    by = fromid]

  # Fromids whose only edges are to outlets get a per-fromid "__tl__" key so
  # they remain independent pendant endpoints (see comment block above).
  tl_fromids <- setdiff(unique(n$fromid), keyed$fromid)
  if (length(tl_fromids)) {
    keyed <- rbindlist(list(
      keyed,
      data.table(fromid = tl_fromids,
        node_id = paste0("__tl__", tl_fromids))))
  }

  n <- left_join(n, as_tibble(keyed), by = "fromid")

  hw <- unique(n$fromid[!n$fromid %in% n$toid])
  tl <- unique(n$toid[!n$toid %in% n$fromid])

  # now get an integer for the nodes
  node <- data.frame(node = seq(1, length(unique(n$node_id))),
    node_id = unique(n$node_id))

  # join the integer id in.
  n <- left_join(n, node, by = "node_id")

  # need to create nodes at the edge of the network so these don't end up NA
  hw_node <- data.frame(id = hw, fromnode = seq((max(n$node) + 1), length.out = length(hw)))
  tl_node <- data.frame(id = tl, tonode = seq((max(hw_node$fromnode) + 1), length.out = length(tl)))

  # create to and from attributes to join to flowlines
  to <- distinct(select(n, id = "fromid", tonode = "node")) |>
    bind_rows(tl_node) |>
    distinct()
  from <- select(n, id = toid, fromnode = "node") |>
    bind_rows(hw_node) |>
    distinct()

  # create a rudimentary node based topology.
  # The c(x$id, x$toid) anchor pulls outlet pseudo-ids into the join so the
  # synthetic terminal nodes get joined; the trailing filter drops them.
  # Filtering by membership in the original network ids (rather than equality
  # to a reserved value) supports any outlet convention, including
  # unique-per-outlet identifiers.
  out <- distinct(data.frame(id = c(x$id, x$toid))) |>
    left_join(to, by = id) |>
    left_join(from, by = id) |>
    select(all_of(c(id, fromnode, tonode))) |>
    filter(.data$id %in% x$id)

  if (inherits(x, "hy")) {
    class(out) <- c("hy", class(out))
    attr(out, "orig_names") <- attr(x, "orig_names")
  }

  out
}