edzer/sf-hexagon-with-sf.R

require("sf")
require("dplyr")
require("hexbin")
require("animation")

# Linux libertine font "sf", converted to path with Inkscape,
# added points between existing points 2 times, then turned all segments into straight lines.
# Saved as SVG with absolute coordinates (Preferences > SVG Output > Path Data).
# Loaded coords from SVG source code, remove letters from start and end, and replace " " with ","
coords_f <- c(218.1169,163.46992,215.56952,177.96334,213.51976,189.84421,211.82546,200.33884,210.34442,210.67351,208.24728,226.35176,205.51032,243.54066,201.92029,259.27223,197.26391,270.57846,195.45112,272.90665,193.28288,274.70167,190.97247,275.85687,188.73314,276.26564,187.03291,276.03164,185.79476,275.38887,184.84097,274.42619,183.99382,273.23248,182.45947,271.13533,180.24976,269.10927,177.54243,267.58084,174.51519,266.97658,171.25987,267.58973,169.08867,269.18036,167.87718,271.37526,167.501,273.8012,168.44294,277.0032,171.48203,279.79643,176.93817,281.77214,185.13126,282.52154,191.01986,281.80176,196.83737,279.60686,202.29944,275.88354,207.12169,270.57846,210.87463,263.5702,214.6809,252.47427,218.87815,235.97553,223.80408,212.7588,226.10561,201.56217,228.42491,190.15226,230.70867,178.52909,232.90357,166.69265,233.04575,165.88697,233.18793,165.08128,233.33011,164.2756,233.47229,163.46992,237.87985,163.46992,242.28741,163.46992,246.69498,163.46992,251.10254,163.46992,252.53915,163.32774,254.06462,162.9012,255.34127,162.1903,256.03143,161.19504,256.17953,160.57004,256.50536,159.18083,256.8312,157.75608,256.9793,157.02445,256.90525,156.63642,256.67124,156.33725,256.25951,156.14471,255.65229,156.07658,250.43904,156.07658,245.22579,156.07658,240.01255,156.07658,234.7993,156.07658,235.32062,153.37517,235.84194,150.67376,236.36327,147.97235,236.88459,145.27094,238.01314,140.01919,239.37273,135.10511,240.91005,130.58202,242.57177,126.50325,246.57649,119.17508,251.00776,114.51278,255.15466,112.05426,258.3063,111.33744,261.1647,111.5744,263.25888,112.38009,264.67772,113.89667,265.51006,116.26633,266.31574,119.50683,267.83233,122.56962,270.41526,124.85041,274.41998,125.74496,277.94485,124.97778,280.15455,123.16203,281.29791,121.02638,281.62374,119.29949,280.11012,113.8789,275.77068,109.34692,268.90756,106.23675,259.82288,105.08154,254.79625,105.67099,248.33004,107.66447,241.40176,111.39964,234.98887,117.21419,230.32953,124.27281,226.29222,133.44635,222.85918,144.2194,220.01263,156.07658,216.88468,156.21876,213.75673,156.36094,210.62878,156.50312,207.50083,156.6453,205.20522,157.01556,203.63829,157.75904,202.67562,158.75133,202.1928,159.86804,201.99434,160.5582,201.74257,161.55049,201.52633,162.50724,201.43451,163.09077,201.53226,163.30997,201.78996,163.42253,202.15429,163.464,202.57194,163.46992,206.45818,163.46992,210.34442,163.46992,214.23066,163.46992)
# close the ring              
coords_f <- c(coords_f, coords_f[1:2])

coords_s <- c(148.44601,239.29898,149.15691,239.29898,149.8678,239.29898,150.5787,239.29898,151.2896,239.29898,163.7777,237.48027,173.13785,232.42697,179.0146,224.74335,181.05251,215.03368,179.98024,208.33939,176.31319,201.43184,169.37602,194.02666,158.49337,185.83949,154.90926,183.04033,152.56922,180.2234,151.29553,177.22874,150.91046,173.89641,151.63024,168.99418,153.82514,164.67844,157.54846,161.60677,162.85354,160.43675,166.10589,160.73592,168.6829,161.69267,170.47791,163.39586,171.38431,165.93436,172.29366,169.39406,174.10941,172.5694,176.7427,174.89167,180.10465,175.79214,183.41032,175.21157,185.50747,173.70684,186.60936,171.63339,186.92926,169.34667,185.20533,164.09788,180.53118,159.20453,173.65325,155.59081,165.31798,154.18086,154.21317,156.25727,145.86309,161.69268,140.60541,169.29632,138.77781,177.87744,139.622,183.66533,142.40339,189.63094,147.49519,195.73873,155.27063,201.95316,161.31622,206.93833,164.82035,211.55028,166.4406,215.62905,166.83456,219.0147,165.51644,225.60531,161.97676,229.93883,156.83757,232.31737,150.72089,233.04308,147.4478,232.82981,145.01001,232.04783,143.38976,230.48385,142.56926,227.92462,141.73692,224.51527,140.03373,221.26588,137.37083,218.83402,133.65935,217.87727,130.24408,218.62075,128.09065,220.4128,126.96803,222.59585,126.64516,224.51231,128.2121,229.6752,132.64039,234.25161,139.52129,237.65503)
coords_s <- c(coords_s, coords_s[1:2])

# create sf objects from letters
rot = function(a) matrix(c(cos(a), sin(a), -sin(a), cos(a)), 2, 2)

matrix_s <- matrix(coords_s, ncol = 2, byrow = TRUE)
matrix_s <- apply(apply(matrix_s, 1, rev), 1, rev)
letter_s <- st_polygon(list(matrix_s))

matrix_f <- matrix(coords_f, ncol = 2, byrow = TRUE)
matrix_f <- apply(apply(matrix_f, 1, rev), 1, rev)
letter_f <- st_polygon(list(matrix_f))

letter_sf <- st_sfc(st_union(letter_s, letter_f))
letter_sf <- ((letter_sf - st_centroid(letter_sf)) * rot(pi/2)) * 1.5

letters_bbox <- st_bbox(st_union(letter_s, letter_f))
coords_hex <- hexcoords(dx = letters_bbox[["xmax"]] - letters_bbox[["xmin"]],
                        dy = letters_bbox[["ymax"]] - letters_bbox[["ymin"]])
corners <- tibble(x = coords_hex$x, y = coords_hex$y)
corners <- rbind(corners, corners[1,])
hexagon <- st_polygon(list(as.matrix(corners), as.matrix(corners) * 0.94)) 

laea = st_crs("+proj=laea +lat_0=30 +lon_0=30") # Lambert equal area
letter_sf = letter_sf * 1e4
st_crs(letter_sf) = laea
corners = st_sfc(st_polygon(list(as.matrix(corners))) * 1e4, crs = laea)
hexagon = st_sfc(hexagon * 1e4, crs = laea)

#png("sf-hexagon.png")

bb = st_bbox(hexagon)
px = 200
saveGIF(
for (i in 1:32) {
#st_graticule(st_bbox(hexagon), lon = seq(-32,80,8)+.5*i) %>% 
par(mar = rep(0, 4), xaxs = "i", yaxs = "i")
st_intersection(corners,
	st_geometry(st_graticule(hexagon, lon = seq(-32,80,8)+.25*i))) %>% 
	plot(asp = .662, col = "gray42", xlim = bb[c(1,3)], ylim = bb[c(2,4)])
plot(hexagon, col = "grey", rule = "evenodd", add = TRUE)
plot(st_buffer(letter_sf, dist = 10 * 1e4), col = sf.colors()[1], add = TRUE)
plot(letter_sf, add = TRUE, col = sf.colors()[2], border = "gray", lwd = 3)
}
, interval = 0.05, clean = FALSE, ani.height = px, ani.width = px)

png("sf-hexagon.png", bg = "transparent")
opar = par(mar = rep(0,4))
st_cast(hexagon, "LINESTRING")[[1]] |> 
  st_cast("POLYGON") |> 
  plot(col = "white", asp = 0.7)
st_graticule(st_bbox(hexagon), lon = seq(-32,80,8)) %>% 
  st_geometry %>%
  st_intersection(corners) %>%
  plot(asp = .7, col = "gray42", add = TRUE)
plot(hexagon, col = "white", add = TRUE)
plot(hexagon, col = "grey", rule = "evenodd", add = TRUE, bg = "white")
plot(st_buffer(letter_sf, dist = 10 * 1e4), col = sf.colors()[1], add = TRUE)
plot(letter_sf, add = TRUE, col = sf.colors()[2], border = "gray", lwd = 3)
dev.off()