-
Notifications
You must be signed in to change notification settings - Fork 1
/
geolocate.R
111 lines (96 loc) · 2.82 KB
/
geolocate.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
#' @title Associate a set of coordinates to FIPS codes
#' @param x `data.frame`, `matrix`, `sf`/`sfc`/`sfg` object,
#' or longitude in *EPSG:4326*
#' @param ... Named arguments passed on to methods
#' @param y Latitude in *EPSG:4326*
#' @param coords Coordinates columns if `x` is a `data.frame` or `matrix`.
#' @examples
#' # Some coordinates at UC Santa Barbara
#' coords_to_fips(x = -119.8696, y = 34.4184)
#' @return a `character` vector of FIPS codes
#' @export
coords_to_fips <- function(x, ...) {
UseMethod("coords_to_fips")
}
# nocov start
#' @rdname coords_to_fips
#' @export
coords_to_fips.sf <- function(x, ...) {
coords_to_fips(
x = do.call(
rbind,
lapply(x[[attr(x, "sf_column")]], as.numeric)
)
)
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.sfc <- function(x, ...) {
coords_to_fips(x = do.call(rbind, lapply(x, as.numeric)))
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.sfg <- function(x, ...) {
coords_to_fips(x = as.numeric(x)[[1]],
y = as.numeric(x)[[2]])
}
# nocov end
#' @rdname coords_to_fips
#' @export
coords_to_fips.list <- function(x, ...) {
coords_to_fips(x = do.call(rbind, x))
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.data.frame <- function(x, coords = c(1, 2), ...) {
coords_to_fips(x = x[[coords[1]]],
y = x[[coords[2]]])
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.matrix <- function(x, coords = c(1, 2), ...) {
coords_to_fips(x = x[, coords[1]],
y = x[, coords[2]])
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.character <- function(x, y, ...) {
coords_to_fips(x = as.numeric(x),
y = as.numeric(y))
}
#' @rdname coords_to_fips
#' @export
coords_to_fips.numeric <- function(x, y, ...) {
county_fips <- nchar(as.character(.lookup_fips)) > 3
lookup_fips <- .lookup_fips[county_fips]
lookup_geometry <- .geometry_fips[county_fips]
rm(county_fips)
# Filter out geometries by bounding box,
# like a spatial index
intersected <- which(sapply(
lookup_geometry,
FUN = function(g) {
bb <- .bbox(g)
any(x >= bb[1] & y >= bb[2] &
x <= bb[3] & y <= bb[4])
},
USE.NAMES = FALSE
))
# Get fips and geometry based on `intersected`
lookup_fips <- lookup_fips[intersected]
lookup_geometry <- lookup_geometry[intersected]
ret_index <- lapply(
lookup_geometry,
FUN = .intersects,
x = x,
y = y
)
ret_value <- .pad0(lookup_fips)[!is.na(ret_index)]
ret_index <- ret_index[!is.na(ret_index)]
rm(lookup_fips, lookup_geometry)
result <- character(length(x))
for (ind in seq_along(ret_value)) {
result[ret_index[[ind]]] <- ret_value[ind]
}
result
}