R/core_api.R

Defines functions cell_to_children_size childpos_to_cell cell_to_childpos rads_to_degs degs_to_rads splitlong_to_cell cell_to_splitlong get_res0 cell_to_polygon cell_to_point point_to_cell get_res get_pentagons get_faces get_base_cell is_rc3 is_pentagon is_valid

Documented in cell_to_childpos cell_to_children_size cell_to_point cell_to_polygon cell_to_splitlong childpos_to_cell degs_to_rads get_base_cell get_faces get_pentagons get_res get_res0 is_pentagon is_rc3 is_valid point_to_cell rads_to_degs splitlong_to_cell

#' check H3 cell index
#'
#' This function checks whether an H3 cell index is valid.
#' @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.
#' @return By default, a logical vector of \code{length(h3_address)}.
#' @examples
#' # is the following cell index valid?
#' is_valid(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
is_valid <- function(h3_address = NULL, simple = TRUE) {

  # frame up for JSON conversion
  eval_this <- data.frame(h3_address, 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.isValidCell(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_valid = h3.isValidCell(evalThis[i].h3_address);
            };')

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_valid
  } else {
    sesh$get('evalThis')
  }

}

#' check if H3 cell index is a pentagon
#'
#' This function checks whether a H3 cell index refers to one of the pentagons
#' that occur at icosahedron corners.
#' @inheritParams is_valid
#' @return By default, a logical vector of \code{length(h3_address)}.
#' @examples
#' # is the following cell index a pentagon?
#' is_pentagon(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
is_pentagon <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 cell index 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.isPentagon(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_pentagon = h3.isPentagon(evalThis[i].h3_address);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_pentagon
  } else {
    sesh$get('evalThis')
  }
}

#' check if H3 cell index is in a Class III resolution
#'
#' This function checks whether a H3 cell index is in a Class III resolution
#' (rotated versus the icosahedron and subject to shape distortion adding extra
#' points on icosahedron edges).
#' @inheritParams is_valid
#' @return By default, a logical vector of \code{length(h3_address)}.
#' @examples
#' # is the following cell index Class III?
#' is_rc3(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
is_rc3 <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 cell index 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.isResClassIII(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_rc3 = h3.isResClassIII(evalThis[i].h3_address);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_rc3
  } else {
    sesh$get('evalThis')
  }

}

#' get the base cell of an H3 cell index
#'
#' This function returns the number of the base (Level 1) cell for an H3
#' cell idnex.
#' @inheritParams is_valid
#' @return By default, an integer vector of \code{length(h3_address)}, ranging from
#'   0 to 121.
#' @examples
#' # What is Brisbane Town Hall's base cell number?
#' get_base_cell(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
get_base_cell <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 cell index 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.h3GetBaseCell(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_base_cell = h3.getBaseCellNumber(evalThis[i].h3_address);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_base_cell
  } else {
    sesh$get('evalThis')
  }

}

#' get the icosahedron faces of an H3 cell index
#'
#' This function returns the indices of all icosahedron faces intersected by a
#' given H3 cell index.
#' @inheritParams is_valid
#' @return By default, an integer vector of \code{length(h3_address)}, ranging
#'   from 1 to 20. If \code{simple = FALSE}, a data.frame with a column of H3
#'   cell indexes and a list-column of faces.
#' @examples
#' # Which faces does this h3 cell index intersect?
#' get_faces(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
get_faces <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 index 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.getIcosahedronFaces(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
          evalThis[i].h3_faces = h3.getIcosahedronFaces(evalThis[i].h3_address);
            };')
  if(simple == TRUE) {
    unlist(sesh$get('evalThis')$h3_faces)
  } else {
    sesh$get('evalThis')
  }
}

#' get the pentagon indices for an H3 resolution
#'
#' This function returns the indices of all pentagons occurring at a
#' given H3 resolution.
#' @inheritParams get_parent
#' @param simple Logical; whether to return outputs as list of outputs (TRUE) or
#'   data frame with both inputs and outputs.
#' @return By default, a list of \code{length(h3_address)}. Each list element
#'   contains a vector of twelve H3 addresses. If \code{simple = FALSE}, a data
#'   frame with a column of input resolutions and a list-column of pentagon
#'   indexes for each.
#' @examples
#' # Which indexes are pentagons at resolution 7?
#' get_pentagons(res = 7)
#' @import V8
#' @export
#'
get_pentagons <- function(res = NULL, simple = TRUE) {

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

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

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis))')
  # sesh$eval('console.log(JSON.stringify(h3.getPentagons(evalThis[0].res)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
          evalThis[i].h3_pentagons = h3.getPentagons(evalThis[i].res);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_pentagons
  } else {
    sesh$get('evalThis')
  }
}

#' get the resolution of an H3 cell index
#'
#' This function returns an H3 cell index's resolution level.
#' @inheritParams is_valid
#' @return By default, an integer vector of \code{length(h3_address)}, ranging
#'   from 1 to 15.
#' @examples
#' # What is the resolution of this H3 cell index?
#' get_res(h3_address = '8abe8d12acaffff')
#' @import V8
#' @export
#'
get_res <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 cell index 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.getResolution(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
          evalThis[i].h3_res = h3.getResolution(evalThis[i].h3_address);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_res
  } else {
    sesh$get('evalThis')
  }
}

#' Convert point location to H3 cell index
#'
#' This function takes point location data and returns a H3 cell index for each
#' point at the chosen resolution(s).
#' @inheritParams get_parent
#' @param input \code{sf} object with point geometry, \code{sfc_POINT} object,
#'   \code{sfg} point, data frame or matrix.
#' @param simple Logical; whether to return outputs as character vector where
#'   possible.
#' @return \itemize{
#' \item {if \code{simple = TRUE} and one resolution is requested, a character vector
#' of H3 addresses.}
#' \item {if \code{simple = TRUE} and multiple resolutions are requested, a data
#' frame of H3 addresses.}
#' \item {if \code{simple = FALSE} and a matrix, sfc or sfg object is supplied, a
#' data frame of H3 addresses.}
#' \item {if \code{simple = FALSE} and a data frame or sf object with other
#' attributes is supplied, a data frame of non-spatial attributes with new
#' columns containing addresses for one or more H3 resolutions.}
#' }
#' @note While multiple resolutions can be requested for multiple points, be
#'   aware of the memory demand on large datasets.
#' @import V8
#' @importFrom methods is
#' @importFrom sf st_crs st_geometry st_sf
#' @importFrom tidyr spread
#' @examples
#' # where is the Brisbane Town Hall at resolution 15?
#' bth <- sf::st_sfc(sf::st_point(c(153.023503, -27.468920)), crs = 4326)
#' bth_15 <- point_to_cell(bth, res = 15)
#'
#' # where is it at several resolutions?
#' bth_many <- point_to_cell(bth, res = seq(10, 15), simple = FALSE)
#' @export
#'
point_to_cell <- function(input = 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.')
  }

  pts <- prep_for_pt2cell(input)

  # dealing with multiple points, multiple resolutions:
  eval_this <-
    data.frame('X' = rep(pts[ , 1], length(res)),
               'Y' = rep(pts[ , 2], length(res)),
               'h3_res' = rep(res, each = nrow(pts)),
               stringsAsFactors = FALSE)

  sesh$assign('evalThis', eval_this, digits = NA)
  # sesh$eval('console.log(evalThis[0].X);')
  # sesh$eval('console.log(JSON.stringify(h3.latLngToCell(evalThis[0].Y, evalThis[0].X, evalThis[0].res)));')
  sesh$eval('var h3_address = [];
            for (var i = 0; i < evalThis.length; i++) {
              h3_address[i] = h3.latLngToCell(evalThis[i].Y, evalThis[i].X, evalThis[i].h3_res);
            };')

  # get data back. If length(res != 1), divide up outputs properly
  addys <- data.frame('n' = seq(nrow(pts)),
                      'res' = rep(res, each = nrow(pts)),
                      'h3_address' = sesh$get('h3_address'),
                      stringsAsFactors = FALSE)
  addys <- tidyr::spread(addys, 'res', 'h3_address')
  addys$n <- NULL
  names(addys) <- paste0('h3_resolution_', names(addys))

  if (simple == TRUE) {
    if (length(res) == 1) {
      unlist(addys, use.names = FALSE)
    } else {
      addys
    }

  } else {
    # for sf or df inputs, tack extra attribs back on if present. Probably dumb
    # to do that with matrices since it'll coerce all to char?? I'm assuming
    # that anyone feeding in a matrix with loc info will have a) a matrix that
    # is only long, lat or b) a matrix that is long, lat, and a bunch of other
    # numbers. Coercing a bunch of numbers to char seems suboptimal.
    if(inherits(input, 'sf')) {
      cbind(sf::st_set_geometry(input, NULL), addys)
    } else if(inherits(input, 'data.frame')) {
      cbind(input[, c(3:dim(input)[2]), drop = FALSE], addys)
    } else {
      addys
    }
  }
}

#' Convert H3 cell index to point location
#'
#' This function takes a H3 cell index and returns its center coordinates in
#' WGS84.
#' @inheritParams is_valid
#' @return By default, an \code{sfc_POINT} object of \code{length(h3_address)}.
#'   EPSG:WGS84.
#' @import V8
#' @examples
#' # Where is the center of the hexagon over the Brisbane Town Hall at resolution 10?
#' brisbane_10 <- cell_to_point(h3_address = '8abe8d12acaffff')
#'
#' @export
#'
cell_to_point <- function(h3_address = NULL, simple = TRUE) {

  if(any(is_valid(h3_address)) == FALSE) {
    stop('Invalid H3 cell index 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.h3ToGeo(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].geometry = h3.cellToLatLng(evalThis[i].h3_address);
            };')

  pts <- sesh$get('evalThis')
  pts$geometry <- lapply(pts$geometry, function(x) {
    # the coords come back as y,x ;_;
    sf::st_point(c(x[2], x[1]))
  })
  pts$geometry <- sf::st_sfc(pts$geometry, crs = 4326)

  if(simple == TRUE) {
    pts$geometry
  } else {
    sf::st_sf(pts)
  }

}

#' Get the boundary of an H3 cell index
#'
#' This function takes an H3 cell index and returns its bounding shape (usually a
#' hexagon) in WGS84.
#' @param input Character; 15-character index generated by H3, or a
#'   vector or list of same, or a data frame where the first column contains H3
#'   addresses.
#' @param simple Logical; whether to return an \code{sfc_POLYGON} object or an \code{sf}
#'   data frame containing both inputs and outputs.
#' @return By default, an \code{sfc_POLYGON} object of \code{length(input)}. If an
#'   appropriately formatted data frame is supplied, an \code{sf} data frame
#'   containing input attributes and geometry.
#' @import V8
#' @examples
#' # What is the hexagon over the Brisbane Town Hall at resolution 10?
#' brisbane_hex_10 <- cell_to_polygon(input = '8abe8d12acaffff')
#'
#' # Give me some of the cells over Brisbane Town Hall as an sf object
#' bth <- sf::st_sfc(sf::st_point(c(153.023503, -27.468920)), crs = 4326)
#' bth_addys <- unlist(point_to_cell(bth, res = seq(10, 15)), use.names = FALSE)
#' bth_hexes <- cell_to_polygon(input = bth_addys)
#' plot(bth_hexes, axes = TRUE)
#' @importFrom sf st_polygon st_sfc st_sf
#' @export
#'
cell_to_polygon <- function(input = NULL, simple = TRUE) {

  if(inherits(input, 'data.frame')) {
    h3_address <- as.character(input[[1]])
  } else {
    h3_address <- unlist(input, use.names = FALSE)
  }

  if(!any(is_valid(h3_address))) {
    stop('Invalid H3 cell index detected.')
  }

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

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

  hexes <- sesh$get('evalThis')

  # spatialise
  hexes$geometry <- lapply(hexes$geometry, function(hex) {
    sf::st_polygon(list(hex))
  })
  hexes$geometry <- sf::st_sfc(hexes$geometry, crs = 4326)

  if(simple == TRUE) {
    hexes$geometry
  } else {
    if(inherits(input, 'data.frame')) {
      sf::st_sf(cbind(input[, c(2:dim(input)[2]), drop = FALSE], hexes),
                stringsAsFactors = FALSE)
    } else {
      sf::st_sf(hexes, stringsAsFactors = FALSE)
  }
}
}

#' Get resolution 0 indexes
#'
#' Get all H3 cell indexes at resolution 0.
#' @return length 122 character vector of top-level H3 cell indices.
#' @note As every index at every resolution > 0 is
#' the descendant of a res 0 index, this can be used with
#' \code{\link[h3jsr:get_children]{get_children}} to iterate over H3 indexes at
#' any resolution.
#' @examples
#' res0 <- get_res0()
#' cell_area(res0[1], 'km2')
#' @export
#'
get_res0 <- function() {
  sesh$eval('res0 = h3.getRes0Cells();')
  sesh$get('res0')
}

#' H3 cell to split long
#'
#' Convert an H3 cell (64-bit hexidecimal string) into a "split long" - a pair
#' of 32-bit integers.
#' @param h3_address Character; 15-character index generated by H3.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return list of integer pairs, one for each address supplied.
#' @import V8
#' @examples
#' cell_to_splitlong(h3_address = '8abe8d12acaffff')
#' @export
#'
cell_to_splitlong <- function(h3_address, simple = TRUE) {

  # no validity check for address, may as well let this work for any
  # 64 bit hex

  # frame up for JSON conversion
  eval_this <- data.frame(h3_address, 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.h3IndexToSplitLong(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_spl = h3.h3IndexToSplitLong(evalThis[i].h3_address);
            evalThis[i].split_lower = evalThis[i].h3_spl[0];
            evalThis[i].split_upper = evalThis[i].h3_spl[1];
            };')

  # retrieve the result
  if(simple == TRUE) {
    # n2s could instead return a matrix here
    sesh$get('evalThis')$h3_spl
  } else {
    # Seems simpler not to return a list-column
    data.frame('h3_address'  = sesh$get('evalThis')$h3_address,
               'split_lower' = sesh$get('evalThis')$split_lower,
               'split_upper' = sesh$get('evalThis')$split_upper)
  }

}

#' Split long to H3 cell
#'
#' Convert a "split long" - a pair of 32-bit integers - into an H3 cell index.
#' @param split_lower Integer; Lower 32 bits of an H3 index.
#' @param split_upper Integer; Upper 32 bits of an H3 index.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return Vector of H3 addresses, one for each split long pair supplied.
#' @import V8
#' @examples
#' x <- cell_to_splitlong(h3_address = '8abe8d12acaffff')
#'
#' splitlong_to_cell(split_lower = x[[1]][1], split_upper = x[[1]][2])
#' @export
#'
splitlong_to_cell <- function(split_lower = NULL,
                              split_upper = NULL, simple = TRUE) {

  if(length(split_lower) != length(split_upper)) {
    stop('Uneven split long data supplied.')
    # NB not yet checking for 0 or NA in these, may do in future
  }

  # frame up for JSON conversion
  eval_this <- data.frame(split_lower, split_upper, 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.splitLongToH3Index(evalThis[0].split_lower, evalThis[0].split_upper)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].h3_address = h3.splitLongToH3Index(evalThis[i].split_lower, evalThis[i].split_upper);
            };')

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$h3_address
  } else {
    sesh$get('evalThis')
  }

}

#' Convert degrees to radians
#'
#' Convert degrees to radians.
#' @param degree Numeric, value in degrees
#' @param lang Character; whether to perform the conversion using base R
#' or the H3 library. Defaults to R for speed.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return Numeric, value in radians
#' @examples
#' degs_to_rads(120)
#' @export
#'
degs_to_rads <- function(degree = NULL, lang = c('r', 'h3'), simple = TRUE) {

  lang <- match.arg(lang)

  if(lang == 'r') {
    return((degree * pi) / (180))
  }

  # otherwise,
  eval_this <- data.frame(degree, 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.degsToRads(evalThis[0].degree)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].radian = h3.degsToRads(evalThis[i].degree);
            };')

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$radian
  } else {
    sesh$get('evalThis')
  }

}

#' Convert radians to degrees
#'
#' Convert radians to degrees.
#' @param radian Numeric, value in radians
#' @param lang Character; whether to perform the conversion using base R
#' or the H3 library. Defaults to R for speed.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return Numeric, value in degrees
#' @examples
#' rads_to_degs(1.5)
#' @export
#'
rads_to_degs <- function(radian = NULL, lang = c('r', 'h3'), simple = TRUE) {

  lang <- match.arg(lang)

  if(lang == 'r') {
    return((radian * 180) / (pi))
  }

  # otherwise,
  eval_this <- data.frame(radian, 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.radsToDegs(evalThis[0].radian)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].degree = h3.radsToDegs(evalThis[i].radian);
            };')

  # retrieve the result
  if(simple == TRUE) {
    sesh$get('evalThis')$degree
  } else {
    sesh$get('evalThis')
  }

}

#' Cell to Child position
#'
#' Get the position of the cell within an ordered list of all children of the cell's parent at the specified resolution.
#' @param h3_address Character; 15-character index generated by H3.
#' @param parent_res numeric; resolution of reference parent cell.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return Numeric, Position of child within parent at `parent_res`.
#' @note Function will return 0 if `parent_res` is the same as the resolution of the supplied cell.
#' @examples
#' # example address has resolution 7
#' cell_to_childpos('872830b82ffffff', c(3,4,5,6), simple = FALSE)
#' @export
#'
cell_to_childpos <- function(h3_address = NULL, parent_res = NULL, simple = TRUE) {

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

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

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

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.cellToChildPos(evalThis[0].h3_address)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].child_pos = h3.cellToChildPos(evalThis[i].h3_address, evalThis[i].parent_res);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$child_pos
  } else {
    sesh$get('evalThis')
  }

}

#' Child position to cell
#'
#' Get the child cell at a given position within an ordered list of all children at the specified resolution.
#' @param child_pos numeric; position of the child cell to get.
#' @param h3_address Character; 15-character index generated by H3.
#' @param child_res numeric; resolution of the child cell to return.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return Character, H3 address of child
#' @note `child_pos` is 0-indexed and capped at the maximum number of hexagons within the parent cell at the supplied resolution. This figure can be determined using \code{\link[h3jsr:cell_to_children_size]{cell_to_children_size}}.
#' @examples
#' # example address has resolution 7:
#' childpos_to_cell(0, '872830b82ffffff', 9, simple = FALSE)
#' @export
#'
childpos_to_cell <- function(child_pos  = NULL,
                             h3_address = NULL,
                             child_res  = NULL,
                             simple     = TRUE) {

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

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

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

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.childPosToCell(evalThis[i].child_pos, evalThis[i].h3_address, evalThis[i].child_res)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].child_cell = h3.childPosToCell(evalThis[i].child_pos, evalThis[i].h3_address, evalThis[i].child_res);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$child_cell
  } else {
    sesh$get('evalThis')
  }

}

#' Cell to children size
#'
#' Get the number of children for a cell at a given resolution.
#' @param h3_address Character; 15-character index generated by H3.
#' @param child_res numeric; child resolution to report on.
#' @param simple Logical; whether to return a vector or a data frame containing
#'   both inputs and outputs.
#' @return numeric; number of children at the requested resolution
#' @examples
#' # example address has resolution 7:
#' cell_to_children_size('872830b82ffffff', c(8,9,10,11), simple = FALSE)
#' @export
#'
cell_to_children_size <- function(h3_address = NULL,
                                  child_res  = NULL,
                                  simple     = TRUE) {

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

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

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

  # for debug:
  # sesh$eval('console.log(JSON.stringify(evalThis[0]))')
  # sesh$eval('console.log(JSON.stringify(h3.cellToChildrenSize(evalThis[i].h3_address, evalThis[i].child_res)));')
  sesh$eval('for (var i = 0; i < evalThis.length; i++) {
            evalThis[i].child_size = h3.cellToChildrenSize(evalThis[i].h3_address, evalThis[i].child_res);
            };')
  if(simple == TRUE) {
    sesh$get('evalThis')$child_size
  } else {
    sesh$get('evalThis')
  }

}
obrl-soil/h3jsr documentation built on Jan. 27, 2024, 4:33 a.m.