R/unidirectional_edges.R

In obrl-soil/h3jsr: Access Uber's H3 Library

#' check if H3 cells are neighbours
#'
#' This function checks whether two H3 cells share an edge.
#' @param origin Character; 15-character cell index generated by H3. A vector of
#'   indexes can also be supplied.
#' @param destination Character; 15-character cell index generated by H3. A vector
#'   of indexes can also be supplied.
#' @param simple Logical; whether to return a vector of outputs or a data frame
#'   containing both inputs and outputs.
#' @return Logical; \code{TRUE} if neighbours.
#' @note
#' \itemize{
#' \item{The number of indexes supplied to origin and destination must be
#' equal.}
#' \item{This function will always return false if the indexes are of different
#' resolutions.}
#'  }
#' @examples
#' # Are the following cells neighbours?
#' are_neighbours(origin = '86be8d12fffffff', destination = '86be8d127ffffff')
#'
#' @import V8
#' @export
#'
are_neighbours <- function(origin = NULL, destination = NULL, simple = TRUE) {

  if(any(is_valid(c(origin, destination)) == FALSE)) {
    stop('Invalid H3 index detected.')
  }

  if(any(is.null(origin), is.null(destination))) {
    stop('Missing required input.')
  }

  if(length(origin) != length(destination)) {
    stop('Uneven origin and destination indexes supplied.')
  }

  sesh$assign('evalThis', data.frame(origin, destination,
                                     stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.areNeighborCells(evalThis[0].origin, evalThis[0].destination)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_neighbours = h3.areNeighborCells(evalThis[i].origin, evalThis[i].destination);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_neighbours
  } else {
    sesh$get('evalThis')
  }

}

#' Get a unidirectional edge index
#'
#' Returns an H3 index representing a unidirectional edge for a given origin and
#' destination cell pair.
#' @inheritParams are_neighbours
#' @return By default, character vector of unidirectional edge indexes.
#' @note The number of cell indexes supplied to origin and destination must be
#'   equal.
#' @examples
#' # Return the unidirectional edge representing the transition between these two cells:
#' get_udedge(origin = '86be8d12fffffff', destination = '86be8d127ffffff')
#'
#' @import V8
#' @export
#'
get_udedge <- function(origin = NULL, destination = NULL, simple = TRUE) {

  if(any(is_valid(c(origin, destination)) == FALSE)) {
    stop('Invalid H3 index detected.')
  }

  if(any(is.null(origin), is.null(destination))) {
    stop('Missing required input.')
  }

  if(length(origin) != length(destination)) {
    stop('Uneven origin and destination indexes supplied.')
  }

  sesh$assign('evalThis', data.frame(origin, destination,
                                     stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.cellsToDirectedEdge(evalThis[0].origin, evalThis[0].destination)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_edge = h3.cellsToDirectedEdge(evalThis[i].origin, evalThis[i].destination);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_edge
  } else {
    sesh$get('evalThis')
  }

  }

#' Check H3 unidirectional edge index
#'
#' This function checks whether an H3 unidirectional edge index is valid.
#' @param h3_edge Character; address of unidirectional edge.
#' @param simple Logical; whether to return a vector of outputs or a data frame
#'   containing both inputs and outputs.
#' @return By default, a logical vector of \code{length(h3_edge)}.
#' @examples
#' # is the following unidirectional edge index valid?
#' is_valid_edge(h3_edge = '166be8d12fffffff')
#'
#' @import V8
#' @export
#'
is_valid_edge <- function(h3_edge = NULL, simple = TRUE) {

  sesh$assign('evalThis', data.frame(h3_edge, stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.isValidDirectedEdge(evalThis[0].h3_edge)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_edge_valid = h3.isValidDirectedEdge(evalThis[i].h3_edge);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_edge_valid
  } else {
    sesh$get('evalThis')
  }
}

#' Get origin cell index from directed edge
#'
#' Get an H3 cell index representing the origin of a directed edge.
#' @inheritParams is_valid_edge
#' @return By default, character vector of H3 indexes.
#' @examples
#' # Get the origin cell of this directed edge
#' get_udorigin(h3_edge = '166be8d12fffffff')
#'
#' @import V8
#' @export
#'
get_udorigin <- function(h3_edge = NULL, simple = TRUE) {

  if(any(is_valid_edge(h3_edge) == FALSE)) {
    stop('Invalid H3 edge index detected.')
  }

  sesh$assign('evalThis', data.frame(h3_edge, stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.getDirectedEdgeOrigin[0].h3_edge)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_origin = h3.getDirectedEdgeOrigin(evalThis[i].h3_edge);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_origin
  } else {
    sesh$get('evalThis')
  }

  }

#' Get destination cell from directed edge
#'
#' Get an H3 index representing the destination of a directed edge.
#' @inheritParams is_valid_edge
#' @return By default, character vector of h3 cell indexes.
#' @examples
#' # Get the destination cell index of this directed edge index
#' get_uddest(h3_edge = '166be8d12fffffff')
#'
#' @import V8
#' @export
#'
get_uddest <- function(h3_edge = NULL, simple = TRUE) {

  if(any(is_valid_edge(h3_edge) == FALSE)) {
    stop('Invalid H3 edge index detected.')
  }

  sesh$assign('evalThis', data.frame(h3_edge, stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.getDirectedEdgeDestination(evalThis[0].h3_edge)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_destination = h3.getDirectedEdgeDestination(evalThis[i].h3_edge);
};')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_destination
  } else {
    sesh$get('evalThis')
  }
}

#' Get origin and destination indexes of directed edge
#'
#' Get H3 cell indexes representing the origin and destination of a directed
#' edge index.
#' @inheritParams is_valid_edge
#' @return By default, character matrix of h3 cell indexes.
#' @examples
#' # Get the origin and destination of this directed edge
#' get_udends(h3_edge = '166be8d12fffffff')
#'
#' @import V8
#' @export
#'
get_udends <- function(h3_edge = NULL, simple = TRUE) {

  if(any(is_valid_edge(h3_edge) == FALSE)) {
    stop('Invalid H3 edge index detected.')
  }

  sesh$assign('evalThis', data.frame(h3_edge, stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.directedEdgeToCells(evalThis[0].h3_edge)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_ends = h3.directedEdgeToCells(evalThis[i].h3_edge);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_ends
  } else {
    sesh$get('evalThis')
  }
}

#' Get all directed edge indexes for a given H3 cell
#'
#' Get all directed edge indexes for a given H3 cell index.
#' @inheritParams is_valid
#' @return By default, list of \code{length(h3_address)}. Each list contains a
#'   character vector of H3 edge indexes.
#' @examples
#' # Get all the edge indexes for this cell
#' get_udedges(h3_address = '86be8d12fffffff')
#'
#' @import V8
#' @export
#'
get_udedges <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address) == FALSE)) {
    stop('Invalid H3 address detected.')
  }

  sesh$assign('evalThis', data.frame(h3_address, stringsAsFactors = FALSE))

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.originToDirectedEdges(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_edges = h3.originToDirectedEdges(evalThis[i].h3_address);
            };')

  if(simple == TRUE) {
    sesh$get('evalThis')$h3_edges
  } else {
    sesh$get('evalThis')
  }
}

#' Get the geometry of an H3 edge
#'
#' This function takes an H3 unidirectional edge address and returns the
#' coordinates of its geometry in WGS84.
#' @inheritParams is_valid_edge
#' @return By default, an object of type `sfc_LINESTRING`.
#' @import V8
#' @examples
#' # get me the shape of this edge
#' udedge_to_line(h3_edge = '166be8d12fffffff')
#'
#' @importFrom sf st_linestring st_sfc st_sf
#' @export
#'
udedge_to_line <- function(h3_edge = NULL, simple = TRUE) {

  # in case a list output from another function is supplied
  h3_edge <- unlist(h3_edge, use.names = FALSE)

  if(any(is_valid_edge(h3_edge) == FALSE)) {
    stop('Invalid H3 directed edge index detected.')
  }

  sesh$assign('evalThis', data.frame(h3_edge, stringsAsFactors = FALSE),
              digits = NA)

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis))')
  # sesh$eval('console.log(JSON.stringify(h3.directedEdgeToBoundary(evalThis[0].h3_edge)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].geometry = h3.directedEdgeToBoundary(evalThis[i].h3_edge, formatAsGeoJson = true);
            };')

  coords <- sesh$get('evalThis')

  coords$geometry <- lapply(coords$geometry, function(x) {
    sf::st_linestring(x)
  })
  coords$geometry <- sf::st_sfc(coords$geometry, crs = 4326)

  if(simple == TRUE) {
    coords$geometry
  } else {
    sf::st_sf(coords, stringsAsFactors = FALSE)
  }
}