Commit 8c33b6f8 authored by Barry Rowlingson's avatar Barry Rowlingson
Browse files

Initial commit

parents
Package: hexes
Title: What the Package Does (One Line, Title Case)
Version: 0.0.0.9000
Authors@R:
person(given = "First",
family = "Last",
role = c("aut", "cre"),
email = "first.last@example.com",
comment = c(ORCID = "YOUR-ORCID-ID"))
Description: What the package does (one paragraph).
License: `use_mit_license()`, `use_gpl3_license()` or friends to
pick a license
Encoding: UTF-8
LazyData: true
Depends: sf, h3forr, DBI, RSQLite
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.1.0
# Generated by roxygen2: do not edit by hand
make_levels <- function(geometry, levels){
meta = data.frame(
level = c(1,2,3,4,5,6, 7),
buffer = c(3.5, 3.0, 0.75,0.5, 0.1, 0.025, 0.025)
)
hexes <- list()
for(olevel in 1:length(levels)){
level = levels[olevel]
d = meta[meta$level == level,]
message("Doing level ",d$level, " with buffer=", d$buffer)
h = sfHex(geometry,res=level, buffer=d$buffer)
hexes[[olevel]] = h
}
names(hexes) <- paste0("level_",levels, sep="")
hexes
}
zzz = function(){
hexes = list(
uk1 = sfHex(gbr, 1, buffer=3.5)
,
uk2 = sfHex(gbr, 2, buffer=3.0)
,
uk3 = sfHex(gbr, 3, buffer=0.75)
,
uk4 = sfHex(gbr, 4, buffer=0.5)
,
uk5 = sfHex(gbr, 5, buffer=0.1)
,
uk6 = sfHex(gbr, 6, buffer=0.025)
)
}
make_geo <- function(hexlist, packagename){
for(n in names(hexlist)){
st_write(hexlist[[n]]$map, packagename, n)
}
con = dbConnect(SQLite(), packagename)
for(n in names(hexlist)){
aname = paste0("adj",n,sep="")
dbWriteTable(con, aname, hexlist[[n]]$row_ij)
}
}
sfHex <- function(polys, res, dst_crs, buffer, add_nbr_columns=FALSE){
## buffer to catch things outside the source bounding box
if(!missing(buffer)){
buffpolys <- st_buffer(polys, buffer)
}else{
buffpolys = polys
}
## get bbox of buffered source
b = st_bbox(buffpolys)
pts = rbind(
b[c(1,2)],
b[c(1,4)],
b[c(3,4)],
b[c(3,2)],
b[c(1,2)]
)
bb = st_polygon(list(pts))
d = st_as_sf(data.frame(geom=st_sfc(bb)))
## get all hexes with centres in the bounding box at this resolution
p = polyfill(d, res)
hexpolys = geo_boundary_to_sf(h3_to_geo_boundary(p))
## make sure they have the same CRS, all these things should be lat-long 4326
st_crs(polys) <- st_crs(hexpolys)
## get the hexes that overlap our source:
inpolys <- st_intersects(hexpolys, polys)
hu = hexpolys[lengths(inpolys)>0,]
hu$hex = p[lengths(inpolys)>0]
## get the hexcodes and indexes of each row's nearest neighbours:
nbs = k_ring(hu$hex,1)
nbslist = lapply(1:length(nbs), function(ni){
n = nbs[[ni]]
hex_nbrs = n[n %in% hu$hex & (! n %in% hu$hex[ni])]
row_index = match(hex_nbrs, hu$hex)
return(list(hexes=hex_nbrs, indexes=row_index))
})
## pull out the hexes and the indexes into separate lists
hex_adj = Map(function(e){e$hexes}, nbslist)
index_adj = Map(function(e){e$indexes}, nbslist)
## do we want the hex neighbours added on as columns in the spatial data frame?
if(add_nbr_columns){
nbs = do.call(rbind, nbs)
nbs[!nbs %in% hu$hex] <- NA
hu <- cbind(hu, data.frame(nbs))
}
## see if the polys are covered by the hexagons
overlapTest = testOverlap(polys, hu)
if(overlapTest != 1){
pcmissing = 100*(1-overlapTest)
warning(paste0(pcmissing, "% not overlapping hexagons - maybe increase buffer size?"))
}
## transform result to any specified CRS
if(!missing(dst_crs)){
hu = st_transform(hu, dst_crs)
}
list(map = hu, hex_adj_list=hex_adj, row_adj_list=index_adj, row_ij=nb2ij(index_adj))
}
testOverlap <- function(p1, p2){
p1 = st_union(p1)
p2 = st_union(p2)
as.numeric(
st_area(st_intersection(st_geometry(p1), st_geometry(p2)))
/
st_area(st_geometry(p1))
)
}
compare_adj <- function(L1, L2){
compares = sapply(1:length(L1),
function(i){
all(sort(L1[[i]]) == sort(L2[[i]]))
}
)
all(compares)
}
nb2ij <- function(nb){
do.call(rbind,
lapply(1:length(nb), function(i){
if(length(nb[[i]])>0){
return(data.frame(i=i, j=nb[[i]]))
}else{
return(NULL)
}
}
))
}
## test for cells with no neighbours
# identical(nb2ij(list(c(1,2,3))), nb2ij(list(c(1,2,3),c())))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment