R/sfnetworks.R

In JosiahParry/sfdep: Spatial Dependence for Simple Features

# Two methods:
# 1. for work in a pipe
# 2. for work with basic objects

# edges -------------------------------------------------------------------

#' Convert to an edge lines object
#'
#' Given geometry and neighbor and weights lists, create an edge list `sf` object.
#'
#' @return
#'
#' Returns an `sf` object with edges represented as a `LINESTRING`.
#'
#' * `from`: node index. This is the row position of `x`.
#' * `to`: node index. This is the neighbor value stored in `nb`.
#' * `i`: node index. This is the row position of `x`.
#' * `j`: node index. This is the neighbor value stored in `nb`.
#' * `wt`: the weight value of `j` stored in `wt`.
#'
#' @details
#'
#' Creating an edge list creates a column for each `i` position and `j` between an observation and their neighbors. You can recreate these values by expanding the `nb` and `wt` list columns.
#'
#' ```{r}
#' library(magrittr)
#' guerry_nb %>%
#'   tibble::as_tibble() %>%
#'   dplyr::select(nb, wt) %>%
#'   dplyr::mutate(i = dplyr::row_number(), .before = 1) %>%
#'   tidyr::unnest(c(nb, wt))
#' ```
#' @export
#' @examples
#'
#' if (requireNamespace("dplyr", quietly = TRUE)) {
#'
#' library(magrittr)
#' guerry %>%
#'   dplyr::mutate(nb = st_contiguity(geometry),
#'          wt = st_weights(nb)) %>%
#'   st_as_edges(nb, wt)
#'
#' }
st_as_edges <- function(x, nb, wt) {
  UseMethod("st_as_edges")
}

#' @param x object of class `sf` or `sfc`.
#' @param nb a neighbor list. If `x` is class `sf`, the unquote named of the column. If `x` is class `sfc`, an object of class `nb` as created from `st_contiguity()`.
#' @param wt optional. A weights list as generated by `st_weights()`.  . If `x` is class `sf`, the unquote named of the column. If `x` is class `sfc`, the weights list itself.
#' @rdname st_as_edges
#' @export
st_as_edges.sf <- function(x, nb, wt) {
  check_pkg_suggests("dplyr")
  nb <- x[[rlang::ensym(nb)]]
  wt <- x[[rlang::ensym(wt)]]

  # If not providing wt, then use nb2lines
  # Early exit in this case.
  if (is.null(wt)) {
    res <- spdep::nb2lines(nb, coords = st_geometry(x))
    res <- dplyr::rename(res, from = i, to = j, i = i_ID, j = j_ID)

    return(res)
  }

  listw <- recreate_listw(nb, wt)


  dplyr::rename(
    spdep::listw2lines(listw, st_geometry(x)),
    from = i, to = j, i = i_ID, j = j_ID)

}

#' @rdname st_as_edges
#' @export
st_as_edges.sfc <- function(x, nb, wt) {
  # if wt is missing use nb2lines
  if (rlang::is_missing(wt)) {
    res <-
      dplyr::rename(spdep::nb2lines(nb, coords = x),
                    from = i, to = j, i = i_ID, j = j_ID)

    return(res)
  }

  listw <- recreate_listw(nb, wt)

  dplyr::rename(spdep::listw2lines(listw, x),
                from = i, to = j, i = i_ID, j = j_ID)

}

#edges <- st_as_edges(st_geometry(guerry), guerry_nb$nb, guerry_nb$wt)


# nodes -------------------------------------------------------------------


#' Convert to a node point object
#'
#' Given geometry and a neighbor list, creates an `sf` object to be used as nodes in an [`sfnetworks::sfnetwork()`]. If the provided geometry is a polygon, [`sf::st_point_on_surface()`] will be used to create the node point.
#'
#' @details
#'
#' `st_as_node()` adds a row `i` based on the attribute `"region.id"` in the `nb` object. If the `nb` object is created with `sfdep`, then the values will always be row indexes.
#'
# @param ... arguments passed to methods.
#' @export
#' @examples
#' if (requireNamespace("dplyr", quitly = TRUE)) {
#' library(magrittr)
#' guerry %>%
#'   dplyr::transmute(nb = st_contiguity(geometry)) %>%
#'   st_as_nodes(nb)
#'  }
#' @return
#' An object of class `sf` with `POINT` geometry.
st_as_nodes <- function(x, nb) {
  UseMethod("st_as_nodes")
}

#' @importFrom rlang :=
#' @inheritParams st_as_edges.sfc
#' @rdname st_as_nodes
#' @export
st_as_nodes.sf <- function(x, nb) {
  # if required packages are missing fail

  check_pkg_suggests(c("vctrs", "dplyr", "sf"))

  nb <- x[[rlang::ensym(nb)]]

  curr_names <- rlang::names2(x)

  new_names <- vctrs::vec_as_names(c("i", curr_names), repair = "universal")
  i_col <- new_names[1]
  # this is based on spdep::nb2lines
  geo_class <- class(st_geometry(x))

  if (any(geo_class %in% c("sfc_MULTIPOLYGON", "sfc_POLYGON"))) {
    sf::st_geometry(x) <- sf::st_point_on_surface(sf::st_geometry(x))
  }

  dplyr::mutate(x, "{i_col}" := attr(nb, "region.id"), .before = 1)

}

# guerry_nb %>%
#   st_as_nodes(nb)

#' @rdname st_as_nodes
#' @export
st_as_nodes.sfc <- function(x, nb) {
  if (inherits(x, "sfc")) {
    if (!inherits(x, "sfc_POINT")) {
      if (inherits(x, "sfc_POLYGON") || inherits(x,"sfc_MULTIPOLYGON"))
        x <- sf::st_point_on_surface(x)
      else stop("Point-conforming geometries required")
    }
  }
    dplyr::mutate(sf::st_as_sf(x), i = attr(nb, "region.id"), .before = 1)

}

# st_geometry(guerry) %>%
#   st_as_nodes(guerry_nb$nb)
#
#
# nb <- guerry_nb$nb
# wt <- guerry_nb$wt
# geo <- st_geometry(guerry)
#
# st_as_nodes(geo, nb)
# st_as_edges(geo, nb, wt)
# gg <- st_as_graph(geo, nb, wt)
#


# graph -------------------------------------------------------------------

#' Create an sfnetwork
#'
#' Given an `sf` or `sfc` object and neighbor and weights lists, create an `sfnetwork` object.
#'
#' @seealso [st_as_nodes()] and [st_as_edges()]
#' @export
#' @examples
#'
#' if (requireNamespace("dplyr", quietly = TRUE)) {
#' library(magrittr)
#'
#' guerry_nb %>%
#'   st_as_graph(nb, wt)
#'}
#' @returns an `sfnetwork` object
st_as_graph <- function(x, nb, wt) {
  UseMethod("st_as_graph")
}


#' @inheritParams st_as_edges.sf
#' @rdname st_as_graph
#' @export
st_as_graph.sf <- function(x, nb, wt) {
  check_pkg_suggests("sfnetworks")

  if (!inherits(x, "sf")) rlang::abort("`x` must be an object of `sf` class.")

  nb <- x[[rlang::ensym(nb)]]
  wt <- x[[rlang::ensym(wt)]]

  nodes <- st_as_nodes(x, nb)
  edges <- st_as_edges(x, nb, wt)

  sfnetworks::sfnetwork(nodes, edges, directed = FALSE)
}

#
# guerry_nb %>%
#   st_as_graph(nb, wt)

#' @inheritParams st_as_edges.sfc
#' @rdname st_as_graph
#' @export
st_as_graph.sfc <- function(x, nb, wt) {
  if (!inherits(x, "sfc")) rlang::abort("`x` must be an object of class `sf` or `sfc`")

  sfnetworks::sfnetwork(
    st_as_nodes(x, nb),
    st_as_edges(x, nb, wt),
    directed = FALSE
  )
}