R/info_utilities.R

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

#' Get average cell area
#'
#' This function returns the average area of an H3 cell at a given
#' resolution.
#' @inheritParams get_parent
#' @param units Areal unit to report in. Options are square meters or square
#'   kilometers.
#' @param fast Logical; whether to retrieve values from a locally stored table or
#'   reclaculate from source.
#' @return Numeric; average H3 cell area.
#' @examples
#' # Return average H3 cell area at each resolution in square meters
#' res_area(res = seq(0, 15), units = 'm2')
#'
#' @import V8
#' @importFrom utils data
#' @export
#'
res_area <- function(res = NULL, units = c('m2', 'km2'), fast = TRUE) {

  if(!any(res %in% seq(0, 15))) {
    stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
  }

  units <-  match.arg(units) # NB rads unsupported at 2022-09, see h3-js #134

  if(fast == TRUE) {
    utils::data('h3_info_table', envir = environment(), package = 'h3jsr')
    h3_info_table <- h3_info_table[h3_info_table$h3_resolution %in% res,
                                   switch(units, 'm2'  = 'avg_area_sqm',
                                                 'km2' = 'avg_area_sqkm')]
    return(h3_info_table)
  } else {
    sesh$assign('evalThis', data.frame(res))
    sesh$assign('unit', units)
    # sesh$eval('console.log(unit);')
    # sesh$eval('console.log(JSON.stringify(h3.getHexagonAreaAvg(evalThis[0].res, unit)));')
    sesh$eval('for (var i = 0; i < evalThis.length; i++) {
                 evalThis[i].area = h3.getHexagonAreaAvg(evalThis[i].res, unit);
              };')
    sesh$get('evalThis')
  }
}

#' Get exact cell area
#'
#' This function calculates the exact area of an H3 cell.
#' @param h3_address Character; 15-character index generated by H3.
#' @param simple Logical; whether to return a vector of outputs or a data frame
#'   containing both inputs and outputs.
#' @param units Length unit to report in. Options are square meters, square
#'   kilometers, or steradians.
#' @return By default, a numeric vector of length(h3_address).
#' @examples
#' cell_area(h3_address = '8abe8d12acaffff', 'm2')
#' @import V8
#' @export
#'
cell_area <- function(h3_address = NULL,
                      units = c('m2', 'km2', 'rads2'), simple = TRUE) {

  units <- match.arg(units, c('m2', 'km2', 'rads2'))

  # edge addresses don't fail, they just return nonsense so:
  stopifnot(all(is_valid_edge(h3_address)) == FALSE)

  eval_this <- data.frame(h3_address, stringsAsFactors = FALSE)

  sesh$assign('evalThis', eval_this)
  sesh$assign('units', units)

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

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$area
  } else {
    out <- sesh$get('evalThis')
    names(out) <- switch(units,
                         'm2'    = c('h3_address', 'area_m2'),
                         'km2'   = c('h3_address', 'area_km2'),
                         'rads2'  = c('h3_address', 'area_rads2'))
    out
  }

}

#' Get average cell edge length
#'
#' This function returns the average edge length of an H3 cell edge at a given
#' resolution.
#' @inheritParams get_parent
#' @param units Length unit to report in. Options are meters or kilometers.
#' @param fast Logical; whether to retrieve values from a locally stored table
#'   or recalculate from source.
#' @return Numeric; H3 cell edge length
#' @note This value is also the hexagon circumradius.
#' @examples
#' # Return average H3 cell edge length at each resolution in kilometers
#' res_length(res = seq(0, 15), units = 'km')
#'
#' @import V8
#' @importFrom utils data
#' @export
#'
res_length <- function(res = NULL, units = c('m', 'km'), fast = TRUE) {

  if(!any(res %in% seq(0, 15))) {
    stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
  }

  units <-  match.arg(units) # NB rads unsupported at 2022-09, see h3-js #134

  if(fast == TRUE) {
    utils::data('h3_info_table', envir = environment(), package = 'h3jsr')
    h3_info_table <- h3_info_table[h3_info_table$h3_resolution %in% res,
                                   switch(units, 'm'    = 'avg_edge_m',
                                                 'km'   = 'avg_edge_km')]
    return(h3_info_table)
  } else {
  sesh$assign('evalThis', data.frame(res))
  sesh$assign('unit', match.arg(units))
  # sesh$eval('console.log(unit);')
  # sesh$eval('console.log(JSON.stringify(h3.getHexagonEdgeLengthAvg(evalThis[0].res, unit));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
               evalThis[i].edgelen = h3.getHexagonEdgeLengthAvg(evalThis[i].res, unit);
            };')
  sesh$get('evalThis')
  }

}

#' Get exact cell edge length
#'
#' This function calculates the exact length of an H3 cell edge.
#' @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.
#' @param units Length unit to report in. Options are meters, kilometers, or
#'   radians.
#' @return By default, a numeric vector of length(h3_address).
#' @examples
#' edge_length(h3_edge = '166be8d12fffffff', 'm')
#' @import V8
#' @export
#'
edge_length <- function(h3_edge = NULL, units = c('m', 'km', 'rads'),
                        simple = TRUE) {

  units <- match.arg(units, c('m', 'km', 'rads'))

  stopifnot(all(is_valid_edge(h3_edge)) == TRUE)

  eval_this <- data.frame(h3_edge, stringsAsFactors = FALSE)

  sesh$assign('evalThis', eval_this)
  sesh$assign('units', units)

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

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$len
  } else {
    out <- sesh$get('evalThis')
    names(out) <- switch(units,
                         'm'    = c('h3_address', 'length_m'),
                         'km'   = c('h3_address', 'length_km'),
                         'rads' = c('h3_address', 'length_rads'))
    out
    }

}

#' Get average distance between H3 cell centers
#'
#' This function returns the average distance between the center of H3 cells
#'  at a given resolution.
#' @inheritParams get_parent
#' @param units Length unit to report in, either meters or kilometers.
#' @param fast Logical; whether to retrieve values from a locally stored table or
#'   recalculate from source.
#' @return Numeric; H3 cell center separation distance.
#' @note This isn't in the core library but may be useful.
#' @examples
#' # Return average H3 cell separation distance at each resolution in kilometers
#' res_cendist(res = seq(0, 15), units = 'km')
#'
#' @import V8
#' @importFrom utils data
#' @export
#'
res_cendist <- function(res = NULL, units = c('m', 'km'), fast = TRUE) {

  if(!any(res %in% seq(0, 15))) {
    stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
  }

  units <-  match.arg(units) # rads unsupported at present

  if(fast == TRUE) {
    utils::data('h3_info_table', envir = environment(), package = 'h3jsr')
    h3_info_table <- h3_info_table[h3_info_table$h3_resolution %in% res,
                                   switch(units, 'm'    = 'avg_cendist_m',
                                                 'km'   = 'avg_cendist_km')]
    return(h3_info_table)
  } else {
    crad <- h3jsr::res_length(res = res, units = units, fast = FALSE)
    crad$cendist <- cos(30 * pi / 180) * crad$edgelen * 2
    crad[, c('res', 'cendist')]
  }

}

#' Get total H3 cells
#'
#' This function returns total number of H3 cells at a given resolution.
#' @inheritParams get_parent
#' @param fast Logical; whether to retrieve values from a locally stored table or
#'   recalculate from source.
#' @return Numeric; H3 cell count.
#' @note Above resolution 8 the exact count cannot be represented in a
#'   JavaScript 32-bit number, so consumers should use caution when applying
#'   further operations to the output.
#' @examples
#' # Return cell count for resolution 8
#' num_cells(res = 8)
#'
#' @import V8
#' @importFrom utils data
#' @export
#'
num_cells <- function(res = NULL, fast = TRUE) {

  if(!any(res %in% seq(0, 15))) {
    stop('Please provide a valid H3 resolution. Allowable values are 0-15 inclusive.')
  }

  if(fast == TRUE) {
    utils::data('h3_info_table', envir = environment(), package = 'h3jsr')
    h3_info_table <- h3_info_table[h3_info_table$h3_resolution %in% res,
                                   'total_unique_indexes']
    return(h3_info_table)
  } else {
    sesh$assign('evalThis', data.frame(res))
    # sesh$eval('console.log(unit);')
    # sesh$eval('console.log(JSON.stringify(h3.getNumCells(evalThis[0].res)));')
    sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].total_unique_indexes = h3.getNumCells(evalThis[i].res);
            };')
    sesh$get('evalThis')
  }
}

#' Great circle distance
#'
#' Get the great circle distance between WGS84 lat/long points
#' @param pt1 `sf` object with point geometry, `sfc_POINT` object, `sfg`
#'   point, data frame or matrix.
#' @param pt2 `sf` object with point geometry, `sfc_POINT` object, `sfg`
#'   point, data frame or matrix.
#' @param units whether to return the great circle distance in meters,
#'   kilometers, or radians.
#' @param simple whether to return a numeric vector of distances or a
#'   `data.frame` containing start and end coordinates as well as distance.
#' @return Numeric vector of point to point distances, or data frame of origin
#'   and destination coordinates accompanied by their distances.
#' @note This functionality also exists in R packages \code{sp}, \code{sf},
#' \code{geosphere} and \code{fields}. H3's version appears to return slightly
#' shorter distances than most other implementations, but is included here
#' for completeness.
#' @examples
#' # distance between Brisbane and Melbourne
#' bne <- c(153.028, -27.468)
#' mlb <- c(144.963, -37.814)
#' get_gcdist(bne, mlb, 'km')
#' @export
#'
get_gcdist <- function(pt1 = NULL, pt2 = NULL,
                       units = c('m', 'km', 'rads'),
                       simple = TRUE) {

  units <- match.arg(units, c('m', 'km', 'rads'))

  pt1 <- prep_for_pt2cell(pt1)
  pt2 <- prep_for_pt2cell(pt2)

  stopifnot(nrow(pt1) == nrow(pt2)) # TODO

  sesh$assign('pt1', pt1, digits = NA)
  sesh$assign('pt2', pt2, digits = NA)
  sesh$assign('units', units, digits = NA)

  # sesh$eval('console.log(pts1[0]);')
  # sesh$eval('console.log(JSON.stringify(h3.greatCircleDistance(pts1[0], pts2[0], units)));')
  sesh$eval('var gcd = [];
            for (var i = 0; i < pt1.length; i++) {
              gcd[i] = h3.greatCircleDistance(pt1[i], pt2[i], units);
            };')

  if(simple == TRUE) {
    sesh$get('gcd')
  } else {
    out <- as.data.frame(cbind(pt1, pt2, sesh$get('gcd')))
    names(out) <- c('start_X', 'start_Y', 'end_X', 'end_Y', 'gc_dist')
    out
  }
}

# ## get all info in a table for fast access
# h3_res_areas <-
#   purrr::reduce(list(res_area(seq(0, 15), 'm2',    fast = FALSE),
#                      res_area(seq(0, 15), 'km2',   fast = FALSE)),
#                 left_join,
#                 by = 'res')
# names(h3_res_areas) <-
#   c('h3_resolution', 'avg_area_sqm', 'avg_area_sqkm')
#
# h3_res_els <- dplyr::left_join(res_length(seq(0, 15), 'm', fast = FALSE),
#                                res_length(seq(0, 15), 'km', fast = FALSE), by = 'res')
# names(h3_res_els) <- c('h3_resolution', 'avg_edge_m', 'avg_edge_km')
#
# h3_seps <-
#   dplyr::left_join(res_cendist(seq(0, 15), 'm', fast = FALSE),
#                    res_cendist(seq(0, 15), 'km', fast = FALSE), by = 'res')
# names(h3_seps) <- c('h3_resolution', 'avg_cendist_m', 'avg_cendist_km')
#
# h3_counts <- num_cells(seq(0, 15), fast = FALSE)
# names(h3_counts) <- c('h3_resolution', 'total_unique_indexes')
#
# h3_info_table <-
#   purrr::reduce(list(h3_res_areas, h3_res_els, h3_seps, h3_counts),
#                 left_join, by = 'h3_resolution')
# usethis::use_data(h3_info_table, overwrite = TRUE)