Nothing
#nocov start
#' @keywords internal
.has_fastmatch <- function() {
requireNamespace("fastmatch", quietly = TRUE)
}
#nocov end
#' @keywords internal
.bbox <- function(geometry) {
geometry <- .to_matrix(geometry)
c(xmin = min(geometry[, 1]),
ymin = min(geometry[, 2]),
xmax = max(geometry[, 1]),
ymax = max(geometry[, 2]))
}
#' Simple intersection via ray casting
#' @return indices of points in `x` and `y`
#' that intersect `geometry`
#' @keywords internal
.intersects <- function(x, y, geometry) {
geometry <- .to_matrix(geometry)
starts <- geometry[-nrow(geometry), ]
ends <- geometry[-1, ]
nodes <- cbind(starts, ends)
rm(starts, ends)
sides <- lapply(
seq_len(nrow(nodes)),
FUN = function(i) {
list(list(X = nodes[i, 1],
Y = nodes[i, 2]),
list(X = nodes[i, 3],
Y = nodes[i, 4]))
}
)
# `names(.)` are the indices of points in `x` and `y`
# the values are how many sides that point intersects with `geometry`
points_per_side <- table(unlist(lapply(
sides,
FUN = function(side) which(.segment_intersect(side, x, y))
)))
# indices of the point(s) that intersect with `geometry`
# i.e. if below = 6, then (x[6], y[6]) intersects `geometry`.
ret <- as.numeric(names(which(points_per_side %% 2 == 1)))
if (length(ret) == 0) {
NA_real_
} else {
ret
}
}
#' Check if a point intersects with a side of a polygon
#' @keywords internal
.segment_intersect <- function(side, x, y) {
.slope <- function(x1, y1, x2, y2) ((y2 - y1) / (x2 - x1))
offset <- ifelse(side[[1]]$Y > side[[2]]$Y, 1, 0)
a <- side[[1 + offset]]
b <- side[[2 - offset]]
y <- ifelse((y == a$Y) | (y == b$Y), y + 0.0001, y)
m1 <- ifelse(a$X != b$X, .slope(a$X, a$Y, b$X, b$Y), Inf)
m2 <- ifelse(a$X != x, .slope(a$X, a$Y, x, y), Inf)
c1 <- (y < a$Y | y > b$Y) | (x > max(a$X, b$X))
c2 <- x < min(a$X, b$X)
ifelse(c1, FALSE, ifelse(c2, TRUE, m2 >= m1))
}
#nocov start
#' @keywords internal
.to_matrix <- function(geometry) {
if (isNamespaceLoaded("sf")) {
as.matrix(geometry)
} else {
do.call(
rbind,
unlist(geometry,
recursive = FALSE)
)
}
}
#' @keywords internal
.index <- function(fips, tbl = .lookup_fips) {
match(as.integer(fips), tbl)
}
#' @keywords internal
.pad0 <- function(x) {
sapply(x, function(y) {
if (is.na(y)) {
as.character(y)
} else {
sprintf(paste0(
"%0",
if (nchar(as.character(y)) < 3) 2 else 5,
if (is.character(y)) "s" else "d"
), y)
}
}, USE.NAMES = FALSE)
}
#' @keywords internal
.pad <- function(x, len) {
sapply(x, function(y) {
if (is.na(y)) {
as.character(y)
} else {
sprintf(paste0(
"%0",
len,
if (is.character(y)) "s" else "d"
), y)
}
}, USE.NAMES = FALSE)
}
#' @keywords internal
.subint <- function(x, n) {
if (n <= 0) {
stop("n must be > 0")
}
tmp <- as.double(x)
cutoff <- 10 ^ n
while (any(abs(tmp) >= cutoff)) {
index <- abs(tmp) >= cutoff
tmp[index] <- tmp[index] / 10
}
as.integer(trunc(tmp))
}
#nocov end
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.