Nothing
#' get parent H3 cell index
#'
#' This function returns the parent of a particular H3 cell index at the requested
#' resolution.
#' @param h3_address Character; 15-character index generated by H3.
#' @param res Integer; Desired H3 resolution. See
#' \url{https://h3geo.org/docs/core-library/restable/} for allowable values and related dimensions.
#' @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_address)}.
#' @examples
#' # What is the parent of this cell at resolution 6?
#' get_parent(h3_address = '8abe8d12acaffff', res = 6)
#' @import V8
#' @export
#'
get_parent <- function(h3_address = NULL, res = NULL, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
if(!any(res %in% seq(0, 15))) {
stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
}
# frame up for JSON conversion
eval_this <- data.frame(h3_address, 'h3_res' = res, stringsAsFactors = FALSE)
# send df to js env as JSON
sesh$assign('evalThis', eval_this)
# do the thing
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.cellToParent(evalThis[0].h3_parent)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_parent = h3.cellToParent(evalThis[i].h3_address, evalThis[i].h3_res);
};')
# retrieve the result
if(simple == TRUE) {
sesh$get('evalThis')$h3_parent
} else {
sesh$get('evalThis')
}
}
#' get child H3 cell indices
#'
#' This function returns the children of a particular H3 cell at the
#' requested resolution.
#' @inheritParams get_parent
#' @return By default, a list of \code{length(h3_address)}. Each list element contains
#' a vector of H3 cell indexes.
#' @note The number of cells returned for each request is \code{7 ^ (parent_res -
#' child_res)}, so jumping three levels will return 343 indexes per request.
#' This can cause memory issues with larger requests.
#' @examples
#' # What are the children of this resolution 6 cell index at resolution 8?
#' get_children(h3_address = '86be8d12fffffff', res = 8)
#' @import V8
#' @export
#'
get_children <- function(h3_address = NULL, res = NULL, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
if(!any(res %in% seq(0, 15))) {
stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
}
eval_this <- data.frame(h3_address, 'h3_res' = res, stringsAsFactors = FALSE)
sesh$assign('evalThis', eval_this)
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.cellToChildren(evalThis[0].h3_address, evalThis[0].res)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_children = h3.cellToChildren(evalThis[i].h3_address, evalThis[i].h3_res);
};')
if(simple == TRUE) {
sesh$get('evalThis')$h3_children
} else {
sesh$get('evalThis')
}
}
#' get central child H3 cell index
#'
#' This function returns the central child of a particular H3 cell index at the
#' requested resolution.
#' @inheritParams get_parent
#' @return By default, a list of \code{length(h3_address)}. Each list element contains
#' a vector of H3 cells.
#' @examples
#' # What is the central child of this resolution 6 index at resolution 8?
#' get_centerchild(h3_address = '86be8d12fffffff', res = 8)
#' @import V8
#' @export
#'
get_centerchild <- function(h3_address = NULL, res = NULL, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
if(!any(res %in% seq(0, 15))) {
stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
}
eval_this <- data.frame(h3_address, 'h3_res' = res, stringsAsFactors = FALSE)
sesh$assign('evalThis', eval_this)
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.cellToCenterChild(evalThis[0].h3_address, evalThis[0].res)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_centerchild = h3.cellToCenterChild(evalThis[i].h3_address, evalThis[i].h3_res);
};')
if(simple == TRUE) {
sesh$get('evalThis')$h3_centerchild
} else {
sesh$get('evalThis')
}
}
#' Get nearby H3 cell indices
#'
#' This function returns all the H3 cell indices within a specified number of
#' steps from the index supplied.
#' @param h3_address Character; 15-character cell index generated by H3.
#' @param ring_size Character; number of steps away from the central cell.
#' Defaults to 1.
#' @param simple Logical; whether to return a vector of outputs or a data frame
#' containing both inputs and outputs.
#' @return By default, a list of \code{length(h3_address)}. Each list element
#' contains a character vector of H3 cells.
#' @note The number of cells returned for each input index conforms to the
#' \href{https://en.wikipedia.org/wiki/Centered_hexagonal_number}{centered
#' hexagonal number sequence}, so at \code{ring_size = 5}, 91 addresses are
#' returned. The first address returned is the input address, the rest follow
#' in a spiral anticlockwise order.
#' @examples
#' # What are all the neighbours of this cell within two steps?
#' get_disk(h3_address = '86be8d12fffffff', ring_size = 2)
#' @import V8
#' @export
#'
get_disk <- function(h3_address = NULL, ring_size = 1, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 address detected.')
}
eval_this <- data.frame(h3_address, ring_size, stringsAsFactors = FALSE)
sesh$assign('evalThis', eval_this)
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.gridDisk(evalThis[0].h3_address, evalThis[0].ring_size)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_disk = h3.gridDisk(evalThis[i].h3_address, evalThis[i].ring_size);
};')
if(simple == TRUE) {
sesh$get('evalThis')$h3_disk
} else {
sesh$get('evalThis')
}
}
#' Get nearby H3 cell indexes separated by distance
#'
#' This function returns all the H3 cell indexes within a specified number of steps
#' from the address supplied, grouped by step.
#' @inheritParams get_disk
#' @return By default, a list of \code{length(h3_address)}. Each list element
#' contains a list of \code{length(ring_size + 1)}. Each of those lists
#' contains a character vector of H3 cell indices belonging to that step away
#' from the input cell.
#' @note In total, the number of indices returned for each input cell conforms
#' to the
#' \href{https://en.wikipedia.org/wiki/Centered_hexagonal_number}{centered
#' hexagonal number sequence}, so at \code{ring_size = 5}, 91 cells are
#' returned. Cells are returned in separate lists, one for each step.
#' @examples
#' # What are the nested neighbours of this cell within two steps?
#' get_disk_list(h3_address = '86be8d12fffffff', ring_size = 2)
#' @import V8
#' @export
#'
get_disk_list <- function(h3_address = NULL, ring_size = 1, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
eval_this <- data.frame(h3_address, ring_size, stringsAsFactors = FALSE)
sesh$assign('evalThis', eval_this)
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.gridDiskDistances(evalThis[0].h3_address, evalThis[0].ring_size)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_disks = h3.gridDiskDistances(evalThis[i].h3_address, evalThis[i].ring_size);
};')
if(simple == TRUE) {
sesh$get('evalThis')$h3_disks
} else {
sesh$get('evalThis')
}
}
#' Get a ring of H3 cell indexes
#'
#' This function returns all the H3 cell indexes at the specified step from the
#' address supplied.
#' @inheritParams get_disk
#' @return By default, a list of \code{length(h3_address)}. Each list element
#' contains a character vector of H3 cells belonging to that step away from
#' the input address.
#' @note In total, the number of cells returned for each input index is
#' \code{ring_size * 6}. This function will throw an error if there is a
#' pentagon anywhere in the ring.
#' @examples
#' # What are the neighbours of this cell at step 2?
#' get_ring(h3_address = '86be8d12fffffff', ring_size = 2)
#' @import V8
#' @export
#'
get_ring <- function(h3_address = NULL, ring_size = 1, simple = TRUE) {
if(any(is_valid(h3_address)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
eval_this <- data.frame(h3_address, ring_size, stringsAsFactors = FALSE)
sesh$assign('evalThis', eval_this)
# for debug:
# sesh$eval('console.log(JSON.stringify(evalThis[0]))')
# sesh$eval('console.log(JSON.stringify(h3.gridRingUnsafe(evalThis[0].h3_address, evalThis[0].ring_size)));')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].h3_ring = h3.gridRingUnsafe(evalThis[i].h3_address, evalThis[i].ring_size);
};')
if(simple == TRUE) {
sesh$get('evalThis')$h3_ring
} else {
sesh$get('evalThis')
}
}
#' Get H3 cell index within a polygon
#'
#' This function returns all the H3 cell indexes within the supplied polygon
#' geometry.
#' @param geometry \code{sf} object of type \code{POLYGON} or
#' \code{MULTIPOLYGON}.
#' @inheritParams get_parent
#' @param simple Logical; whether to return a vector of outputs or an sf object
#' containing both inputs and outputs.
#' @return By default, a list of \code{length(h3_address)}. Each list element
#' contains a character vector of H3 cell indices belonging to that geometry.
#' A result of NA indicates that no H3 cell indices of the chosen resolution
#' are centered over the geometry.
#' @note This function will be slow with a large number of polygons, and/or
#' polygons that are large relative to the hexagon area at the chosen
#' resolution. A message is printed to console where the total input area is
#' (roughly) > 100000x the area of the chosen H3 resolution.
#' @examples
#' # Which level 5 H3 cell indices have centers inside County Ashe, NC?
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#' nc1 <- nc[1, ]
#' fillers <- polygon_to_cells(geometry = nc1, res = 5)
#' @import V8
#' @importFrom sf st_area st_bbox st_as_sfc st_sf
#' @importFrom utils data
#' @export
#'
polygon_to_cells <- function(geometry = NULL, res = NULL, simple = TRUE) {
if(!any(res %in% seq(0, 15))) {
stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
}
# warn for poor life choices
utils::data("h3_info_table", envir = environment(), package = 'h3jsr')
h3_info_table <- h3_info_table[h3_info_table$h3_resolution %in% res, 'avg_area_sqm']
# doesn't need to be super accurate so shhhhh. Using 3857 avoids lwgeom dep
footprint <- suppressWarnings(as.numeric(sf::st_area(st_transform(
sf::st_as_sfc(sf::st_bbox(geometry)), 3857))))
if(footprint > 100000 * h3_info_table) {
message('Resolution is very small relative to input dataset. This might take a while...')
}
sesh$assign('res', res)
sesh$assign('evalThis', V8::JS(prep_for_polyfill(geometry)))
#sesh$eval('console.log(JSON.stringify(evalThis.features[0].geometry.coordinates.length));')
# are nested loops as bad in JS as they are in R? Guess we'll find out!
sesh$eval('var h3_addresses = {};
for (var i = 0; i < evalThis.features.length; i++) {
var comp_h3a = [];
if (evalThis.features[i].geometry.type == "MultiPolygon") {
for (var j = 0; j < evalThis.features[i].geometry.coordinates.length; j++) {
comp_h3a.push(h3.polygonToCells(evalThis.features[i].geometry.coordinates[j], res, true));
}
h3_addresses[i] = [].concat.apply([], comp_h3a)
} else {
h3_addresses[i] = h3.polygonToCells(evalThis.features[i].geometry.coordinates, res, true);
}};')
# consider writing to tmp when lge as retrieval can be slow
results <- sesh$get('h3_addresses')
results <-
lapply(results, function(x) {
if (length(x) == 0) {
NA_character_
} else {
x
}
})
if(simple == TRUE) {
results
} else {
geometry$h3_addresses <- results
sf::st_sf(geometry)
}
}
#' Get geometry for a set of H3 cells
#'
#' This function returns geometry associated with a set of H3 cells, as a
#' single \code{sfc_MULTIPOLYGON}.
#' @param h3_addresses Character vector or list of 15-character cell indices
#' generated by H3.
#' @param simple Logical; whether to return an \code{sfc_MULTIPOLYGON} or an
#' \code{sf} object including the input cells.
#' @return By default, object of type \code{sfc_MULTIPOLYGON} of length 1.
#' @note The geometry returned by this function will not be valid where the
#' addresses supplied overlap at the same resolution. The main use case for
#' this function appears to be visualising the outputs of
#' \code{\link[h3jsr:polygon_to_cells]{polygon_to_cells}} and
#' \code{\link[h3jsr:compact]{compact}}.
#' @examples \dontrun{
#' # Give me the outline of the cells around Brisbane Town Hall at
#' # resolution 10 (not run as slow-ish)
#' bth <- sf::st_sfc(sf::st_point(c(153.023503, -27.468920)), crs = 4326)
#' bth_10 <- point_to_h3(bth, res = 10)
#' bth_patch <- get_disk(h3_address = bth_10, ring_size = 2)
#' bth_patch_sf <- cells_to_multipolygon(bth_patch)
#' }
#' @import V8
#' @importFrom sf st_is_valid st_sf
#' @importFrom geojsonsf geojson_sf
#' @export
#'
cells_to_multipolygon <- function(h3_addresses = NULL, simple = TRUE) {
# in case a list output from another function is supplied
# unique prevents Weird Geometry from being created
h3_addresses <- unique(unlist(h3_addresses, use.names = FALSE))
if(any(is_valid(h3_addresses)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
# handle single address supplied, although doing that would be silly
if(length(h3_addresses) == 1) {
sesh$assign('evalThis', list(h3_addresses))
} else {
sesh$assign('evalThis', h3_addresses)
}
# sesh$eval('console.log(evalThis.length);')
sesh$eval('var geometry = h3.cellsToMultiPolygon(evalThis, formatAsGeoJson = true);')
# sesh$eval('console.log(JSON.stringify(geometry));')
# Output still isn't proper geoJSON, just the .coordinates.
sesh$eval('var geom_out = JSON.stringify({type: "MultiPolygon", coordinates: geometry});')
geometry <- geojsonsf::geojson_sfc(sesh$get('geom_out'))
# graceful fail if geom is bad
if(any(sf::st_is_valid(geometry) == FALSE)) {
stop('An invalid geometry was returned from this set of addresses.')
}
if(simple == TRUE) {
geometry
} else {
out <- sf::st_sf(geometry)
out$h3_addresses <- list(h3_addresses)
sf::st_sf(out) # blerg
}
}
#' Compact H3 cells
#'
#' This function compacts a set of cells of the same resolution into a set of
#' cells across multiple resolutions that represents the same area.
#' @param h3_addresses Character vector or list of 15-character indices
#' generated by H3 at a single resolution, generally the output of
#' \code{\link[h3jsr:polygon_to_cells]{polygon_to_cells}}.
#' @param simple Logical; whether to return a vector of outputs or a list object
#' containing both inputs and outputs.
#' @return A list of H3 cells with multiple resolutions. The minimum
#' resolution of the output list matches the resolution of the input list.
#' @examples \dontrun{
#' # Give me a compacted representation of County Ashe, NC
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#' nc1 <- nc[1, ]
#' nc1 <- sf::st_cast(nc1, 'POLYGON')
#' fillers <- polygon_to_cells(geometry = nc1, res = 6)
#' compacted <- compact(fillers)
#' }
#' @import V8
#' @export
#'
compact <- function(h3_addresses = NULL, simple = TRUE) {
h3_addresses <- unlist(h3_addresses, use.names = FALSE)
if(any(is_valid(h3_addresses)) == FALSE) {
stop('Invalid H3 cell indexes detected.')
}
# handle single address supplied, although doing that would be silly
if(length(h3_addresses) == 1) {
sesh$assign('evalThis', list(h3_addresses))
} else {
sesh$assign('evalThis', h3_addresses)
}
# sesh$eval('console.log(evalThis.length);')
sesh$eval('var comp = h3.compactCells(evalThis);')
# sesh$eval('console.log(JSON.stringify(comp));')
if(simple == TRUE) {
sesh$get('comp')
} else {
list('input_addresses' = h3_addresses,
'compacted_addresses' = unlist(sesh$get('comp')))
}
}
#' Uncompact H3 cell indices
#'
#' This function uncompacts a compacted set of H3 cells to indices of the
#' target resolution.
#' @inheritParams get_parent
#' @param h3_addresses Character vector or list of 15-character cell indices
#' generated by H3.
#' @param simple Logical; whether to return a vector of outputs or a list object
#' containing both inputs and outputs.
#' @return A list of H3 cell indices of the chosen resolution.
#' @examples \dontrun{
#' # Give me a compacted representation of County Ashe, NC
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#' nc1 <- nc[1, ]
#' nc1 <- sf::st_cast(nc1, 'POLYGON')
#' fillers <- polygon_to_cells(geometry = nc1, res = 6)
#' compacted <- compact(fillers)
#' # uncompact to resolution 7
#' uncompacted <- uncompact(compacted, res = 7)
#' }
#' @import V8
#' @export
#'
uncompact <- function(h3_addresses = NULL, res = NULL, simple = TRUE) {
h3_addresses <- unlist(h3_addresses, use.names = FALSE)
if(any(is_valid(h3_addresses)) == FALSE) {
stop('Invalid H3 address detected.')
}
if(!any(res %in% seq(0, 15))) {
stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
}
sesh$assign('res', res)
# handle single address supplied
if(length(h3_addresses) == 1) {
sesh$assign('evalThis', list(h3_addresses))
} else {
sesh$assign('evalThis', h3_addresses)
}
# sesh$eval('console.log(evalThis.length);')
sesh$eval('var comp = h3.uncompactCells(evalThis, res);')
# sesh$eval('console.log(JSON.stringify(comp));')
if(simple == TRUE) {
sesh$get('comp')
} else {
list('input_addresses' = h3_addresses,
'uncompacted_addresses' = unlist(sesh$get('comp')))
}
}
#' Grid distance between H3 cells
#'
#' This function gets the grid distance between two H3 cell indices.
#' @param origin Character vector or list of 15-character indices generated by
#' H3.
#' @param destination Character vector or list of 15-character indices
#' generated by H3.
#' @param simple Logical; whether to return a vector of outputs or a list object
#' containing both inputs and outputs.
#' @return The distance between two H3 cells, expressed as the minimum
#' number of hexagon 'steps' required to get from the origin to the
#' destination. Thus, a neighbour cell is one step away, and two cells
#' with one hexagon between them are two steps apart.
#' @note Input H3 indices must be of the same resolution or results cannot be
#' computed. This function may fail to find the distance between two indices
#' if they are very far apart or on opposite sides of a pentagon.
#' @examples \dontrun{
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#' nc_pts <- sf::st_centroid(nc[c(1, 2), ])
#' nc_6 <- point_to_cell(nc_pts, res = 6)
#' # how far apart are these two addresses?
#' grid_distance(nc_6[1], nc_6[2])
#' }
#' @import V8
#' @export
#'
grid_distance <- function(origin = NULL, destination = NULL, simple = TRUE) {
if(any(is.null(origin), is.null(destination))) {
stop('Missing required input.')
}
if(length(origin) != length(destination)) {
stop('Uneven origin and destination addresses supplied.')
}
h3_addresses <- c(origin, destination)
if(any(is_valid(h3_addresses)) == FALSE) {
stop('Invalid H3 cell index detected.')
}
# handle single pair supplied
sesh$assign('evalThis', data.frame(origin, destination,
stringsAsFactors = FALSE))
# sesh$eval('console.log(evalThis.length);')
# sesh$eval('console.log(evalThis[0]);')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].grid_distance = h3.gridDistance(evalThis[i].origin, evalThis[i].destination);
};')
# sesh$eval('console.log(JSON.stringify(evalThis[0].grid_distance));')
if(simple == TRUE) {
sesh$get('evalThis')$grid_distance
} else {
sesh$get('evalThis')
}
}
#' Path between H3 cells
#'
#' This function returns a path of H3 cells between a start and end cell
#' (inclusive).
#' @param origin Character vector or list of 15-character indices generated by
#' H3.
#' @param destination Character vector or list of 15-character indices
#' generated by H3.
#' @param simple Logical; whether to return a vector of outputs or a list object
#' containing both inputs and outputs.
#' @return A vector of h3 cells of form c(origin, c(path), destination).
#' @note \itemize{
#' \item{Input H3 cells must be of the same resolution or results cannot
#' be computed. This function may fail to find the distance between two
#' indexes if they are very far apart or on opposite sides of a pentagon.}
#' \item{The specific output of this function should not be considered stable
#' across library versions. The only guarantees the library provides are that
#' the line length will be \code{h3_distance(start, end) + 1} and that every
#' index in the line will be a neighbor of the preceding index.}
#' \item{Lines are drawn in grid space, and may not correspond exactly to
#' either Cartesian lines or great arcs}
#' }
#' @examples \dontrun{
#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#' nc_pts <- sf::st_centroid(nc[c(1, 2), ])
#' nc_6 <- point_to_cell(nc_pts, res = 6)
#' # find a path between these two addresses:
#' grid_path(nc_6[1], nc_6[2], simple = TRUE)
#'
#' }
#' @import V8
#' @export
#'
grid_path <- function(origin = NULL, destination = NULL, simple = TRUE) {
if(any(is.null(origin), is.null(destination))) {
stop('Missing required input.')
}
if(length(origin) != length(destination)) {
stop('Uneven origin and destination indices supplied.')
}
h3_addresses <- c(origin, destination)
if(any(is_valid(h3_addresses)) == FALSE) {
stop('Invalid H3 addresses detected.')
}
# handle single pair supplied
sesh$assign('evalThis', data.frame(origin, destination,
stringsAsFactors = FALSE))
# sesh$eval('console.log(evalThis.length);')
# sesh$eval('console.log(evalThis[0]);')
sesh$eval('for (var i = 0; i < evalThis.length; i++) {
evalThis[i].grid_path = h3.gridPathCells(evalThis[i].origin, evalThis[i].destination);
};')
# sesh$eval('console.log(JSON.stringify(evalThis[0].grid_path));')
if(simple == TRUE) {
sesh$get('evalThis')$grid_path
} else {
sesh$get('evalThis')
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.