hexagon experiments (WIP)

[mdsumner]

just lurning how it werks

x<-rnorm(1000, sd=1)
y<-rnorm(1000, sd=sqrt(3))

scl <- .5
ex <- vaster::buffer_extent(c(range(x), range(y)), scl*sqrt(3))

snap0 <- function(x, res) {
  (x %/% res) * res + c(0, res)
}
ex <- c(snap0(range(x), scl), snap0(range(y), sqrt(3) * scl) + sqrt(3) * scl)
dm <- diff(ex)[c(1, 3)] / c(scl, scl * sqrt(3))
hcentres <- function(xy, dimension, extent) {
  cbind(vaster::x_from_col(dimension/2, extent,  vaster::col_from_x(dimension/2, extent, xy[,1])), 
        vaster::y_from_row(dimension/2, extent,  vaster::row_from_y(dimension/2, extent, xy[,2])))
}
h1 <- hcentres(cbind(x, y), dm, ex)
h2 <- hcentres(cbind(x + scl, y + scl * sqrt(3) ), dm, ex)
h2 <- cbind(h2[,1] - scl, h2[,2] - scl * sqrt(3))

d <- sqrt(rowSums((cbind(x, y) - h1)^2)) < sqrt(rowSums((cbind(x, y) - h2)^2))

h <- cbind(x = ifelse(d, h1[,1], h2[,1]), 
           y = ifelse(d, h1[,2], h2[,2]))
           

groups <- h |> tibble::as_tibble() |> 
  group_by(x, y) |> 
  mutate(cnt = n(), g = cur_group_id()) |> ungroup()


hexs <- groups |> distinct(x, y, g, cnt)

hex0 <- hexbin::hexcoords(dx = scl)

plot(x, y, pch = ".", asp = 1)
cols <- palr::d_pal(hexs$cnt)
for (i in seq_len(nrow(hexs))) {
  polygon(hex0$x + hexs$x[i], hex0$y + hexs$y[i], col = cols[i], border = NA)
  #  scan("", 1)
}




vaster::plot_extent(ex)
x1<-round(x)
x2<-round(x+1/2)-1/2

x11 <- trunc(x / scl)
head(x1)
head(x11)


y1<-round(y/sqrt(3))*sqrt(3)
y2<-(round(y/sqrt(3)+1/2)-1/2)*sqrt(3)
d1<-(x-x1)^2+3*(y-y1)^2
d2<-(x-x2)^2+3*(y-y2)^2
hx<-ifelse(d1<d2,x1,x2)
hy<-ifelse(d1<d2,y1,y2)

plot(x, y, pch = ".", asp = 1)
points(x1, y1)
points(x2, y2, col = "red")


hex0 <- hexbin::hexcoords(dx = scl)
for (i in seq_along(hx)) polygon(hex0$x + hx[i], hex0$y + hy[i])

abline(v = seq(-6.5, 6.5, by = scl*2))
#abline(h = seq(-6, 6, by = scl))

library(dplyr)
xy <- reproj::reproj_xy(maps::world.cities[c("long", "lat")], "+proj=cea")

x <- xy[,1]
y <- xy[,2]
scl <- 2500000
sscl <- scl * sqrt(3)

x1<- (x %/% scl) * scl
x2<- ((x + scl) %/% scl)*scl - scl
y1<-  (y %/% sscl) * sscl
y2<- ((y + sscl) %/% sscl)*sscl - sscl
d1<- (x-x1)^2 + 3*(y-y1)^2
d2<- (x-x2)^2 + 3*(y-y2)^2
hx<- ifelse(d1<d2,x1,x2)
hy<- ifelse(d1<d2,y1,y2)
groups <- tibble(hx = hx, hy = hy) |> 
  group_by(hx, hy) |> 
  mutate(cnt = n(), g = cur_group_id()) |> ungroup()

hexs <- groups |> distinct(hx, hy, g, cnt)

hex0 <- hexbin::hexcoords(dx = scl)

plot(x, y, pch = ".", asp = 1)
cols <- palr::d_pal(hexs$cnt)
for (i in seq_len(nrow(hexs))) {
  polygon(hex0$x + hexs$hx[i], hex0$y + hexs$hy[i], col = cols[i], border = NA)
#  scan("", 1)
}


par(pty="s")
plot(x1,y1,pch=19)
points(x2,y2,pch=19,col="blue")
plot(hx,hy, col="#A000A020",pch=19, asp = 1)
points(x,y,pch=".")
segments(x,y,hx,hy,col="#00000060")




bb <- st_bbox(c(xmin = min(hx), ymin = min(hy), xmax = max(hx), ymax = max(hy)))
dm <- c((max(hx) - min(hx))/scl, (max(hy) - min(hy))/(sqrt(3) * scl))
plot(x, y, pch = 19, cex = .5, col = "red", asp = 1)
plot(hex <- st_make_grid(bb, square = F, cellsize = scl * 2), add = T)


hexcoords(0.5)