-
Notifications
You must be signed in to change notification settings - Fork 4
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Get basic SVG map with states & a few HUCs #1
Changes from all commits
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,34 @@ | ||
# Get spatial data into sf objects | ||
|
||
source("1_fetch/src/maps_to_sf.R") | ||
|
||
p1_targets <- list( | ||
|
||
# Albers Equal Area | ||
tar_target(p1_proj_str, "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=37.5 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs"), | ||
|
||
tar_target( | ||
p1_conus_sf, | ||
generate_conus_sf(p1_proj_str) | ||
), | ||
|
||
tar_target( | ||
p1_conus_states_sf, | ||
generate_conus_states_sf(p1_proj_str) | ||
), | ||
|
||
# Get basins | ||
# TODO: add more than the one IWS basin and propogate these | ||
# labels through to the SVG additions. | ||
tar_target( | ||
p1_huc8s, c("07120001", "07120002", "07120003") | ||
), | ||
tar_target( | ||
p1_huc8s_sf, | ||
get_huc8(id = p1_huc8s) %>% | ||
st_buffer(0) %>% | ||
st_union() %>% | ||
st_make_valid() %>% | ||
st_transform(p1_proj_str) | ||
) | ||
) |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,121 @@ | ||
# Utils for using spatial data from `maps` | ||
# to create state and county sf objects | ||
|
||
generate_conus_sf <- function(proj_str) { | ||
|
||
usa_sf <- maps::map("usa", fill = TRUE, plot=FALSE) %>% | ||
st_as_sf() %>% | ||
st_transform(proj_str) %>% | ||
st_buffer(0) | ||
|
||
return(usa_sf) | ||
} | ||
|
||
generate_conus_states_sf <- function(proj_str) { | ||
|
||
usa_sf <- maps::map("usa", fill = TRUE, plot=FALSE) %>% | ||
st_as_sf() %>% | ||
st_transform(proj_str) %>% | ||
st_buffer(0) | ||
|
||
# Need to remove islands from state outlines and then add back in | ||
# later so that they can be drawn as individual polygons. Otherwise, | ||
# drawn with the state since the original state maps data only has 1 | ||
# ID per state. | ||
|
||
usa_islands_sf <- usa_sf %>% filter(ID != "main") | ||
usa_addl_islands_sf <- generate_addl_islands(proj_str) | ||
usa_mainland_sf <- usa_sf %>% | ||
filter(ID == "main") %>% | ||
st_erase(usa_addl_islands_sf) | ||
|
||
# Have to manually add in CO because in `maps`, it is an incomplete | ||
# polygon and gets dropped somewhere along the way. | ||
co_sf <- maps::map("state", "colorado", fill = TRUE, plot=FALSE) %>% | ||
st_as_sf() %>% | ||
# st_buffer(0) %>% # Hmm thought it would fix the weird line but doesn't | ||
st_transform(proj_str) | ||
|
||
maps::map("state", fill = TRUE, plot=FALSE) %>% | ||
st_as_sf() %>% | ||
st_transform(proj_str) %>% | ||
st_buffer(0) %>% | ||
# Get rid of islands from state outline data | ||
st_intersection(usa_mainland_sf) %>% | ||
select(-ID.1) %>% # st_intersection artifact that is unneeded | ||
# Add islands back in as separate polygons from states | ||
bind_rows(usa_islands_sf) %>% | ||
bind_rows(usa_addl_islands_sf) %>% | ||
st_buffer(0) %>% | ||
st_cast("MULTIPOLYGON") %>% # Needed to bring back to correct type to use st_coordinates | ||
rmapshaper::ms_simplify(0.5) %>% | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Could go much lower with this number without any noticeable difference. Would be worth exploring how much that affects files size There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Capturing these ideas as we go. See #3 There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Yeah, later we could also investigate setting this as a function of how large the bounding box is, with really high simplification for larger CONUS-level maps, where that detail detracts visually, and less simplification for maps that cover regions or smaller areas. |
||
bind_rows(co_sf) # bind CO after bc otherwise it gets dropped in st_buffer(0) | ||
|
||
} | ||
|
||
generate_addl_islands <- function(proj_str) { | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Wow I had no idea that there was so much funkiness to work through. Is this the case with any r spatial data package? Or is it that more of the oddities in how the polygons are drawn and whether or not they are multipolygons come out when converting to svg? Have you explored using another package like There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. It was more about how they are drawn once you are creating the SVG. I had to split up like this to make sure the islands are not connected together when drawing. There is a ton of weirdness. It would be fun to explore a different package, but this I know that there is also There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Ah, I see. That makes sense. So much to think through! Totally makes sense to use existing code that has all the workarounds. |
||
# These are not called out specifically as islands in the maps::map("usa") data | ||
# but cause lines to be drawn across the map if not treated separately. This creates those shapes. | ||
|
||
# Counties to be considered as separate polygons | ||
|
||
separate_polygons <- list( | ||
`upper penninsula` = list( | ||
state = "michigan", | ||
counties = c( | ||
"alger", | ||
"baraga", | ||
"chippewa", | ||
"delta", | ||
"dickinson", | ||
"gogebic", | ||
"houghton", | ||
"iron", | ||
"keweenaw", | ||
"luce", | ||
"mackinac", | ||
"marquette", | ||
"menominee", | ||
"ontonagon", | ||
"schoolcraft" | ||
)), | ||
`eastern shore` = list( | ||
state = "virginia", | ||
counties = c( | ||
"accomack", | ||
"northampton" | ||
)), | ||
# TODO: borders still slightly wonky bc it doesn't line up with counties perfectly. | ||
`nags head` = list( | ||
state = "north carolina", | ||
counties = c( | ||
"currituck" | ||
)), | ||
# This + simplifying to 0.5 took care of the weird line across NY | ||
`staten island` = list( | ||
state = "new york", | ||
counties = c( | ||
"richmond" | ||
))) | ||
|
||
purrr::map(names(separate_polygons), function(nm) { | ||
maps::map("county", fill = TRUE, plot=FALSE) %>% | ||
sf::st_as_sf() %>% | ||
st_transform(proj_str) %>% | ||
st_buffer(0) %>% | ||
filter(ID %in% sprintf("%s,%s", separate_polygons[[nm]][["state"]], | ||
separate_polygons[[nm]][["counties"]])) %>% | ||
mutate(ID = nm) | ||
}) %>% | ||
bind_rows() %>% | ||
group_by(ID) %>% | ||
summarize(geom = st_union(geom)) | ||
} | ||
|
||
# List counties to use to query `maps()` | ||
list_state_counties <- function(state_abbr) { | ||
tolower(gsub(" County", "", countyCd$COUNTY_NAME[which(countyCd$STUSAB == state_abbr)])) | ||
} | ||
|
||
# Function to remove a state | ||
st_erase <- function(x, y) st_difference(x, st_union(st_combine(y))) |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,46 @@ | ||
# Steps for converting spatial features (sf) objects into SVG land | ||
|
||
source("2_process/src/sf_to_coords.R") | ||
source("2_process/src/coords_to_svg_path.R") | ||
|
||
p2_targets <- list( | ||
|
||
tar_target(svg_width, 1000), | ||
tar_target(p2_view_bbox, st_bbox(p1_conus_states_sf)), | ||
|
||
# Prepare CONUS states for SVG | ||
|
||
tar_target( | ||
p2_conus_states_names, | ||
p1_conus_states_sf %>% | ||
st_drop_geometry() %>% | ||
pull(ID) | ||
), | ||
|
||
tar_target( | ||
p2_conus_states_coords, | ||
p1_conus_states_sf %>% | ||
filter(ID %in% p2_conus_states_names) %>% | ||
sf_to_coords(svg_width, view_bbox = p2_view_bbox), | ||
pattern = map(p2_conus_states_names) | ||
), | ||
|
||
tar_target( | ||
p2_conus_states_paths, | ||
coords_to_svg_path(p2_conus_states_coords, close_path = TRUE), | ||
pattern = map(p2_conus_states_coords) | ||
), | ||
|
||
# Prepare HUCs for SVG | ||
|
||
tar_target( | ||
p2_huc8s_coords, | ||
p1_huc8s_sf %>% | ||
sf_to_coords(svg_width, view_bbox = p2_view_bbox) | ||
), | ||
|
||
tar_target( | ||
p2_huc8s_paths, | ||
coords_to_svg_path(p2_huc8s_coords, close_path = TRUE) | ||
) | ||
) |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,25 @@ | ||
coords_to_svg_path <- function(xy_df, close_path = FALSE) { | ||
|
||
x <- xy_df$x | ||
y <- xy_df$y | ||
|
||
# Build path | ||
first_pt_x <- head(x, 1) | ||
first_pt_y <- head(y, 1) | ||
|
||
all_other_pts_x <- tail(x, -1) | ||
all_other_pts_y <- tail(y, -1) | ||
path_ending <- "" | ||
if(close_path) { | ||
# Connect path to start to make polygon | ||
all_other_pts_x <- c(all_other_pts_x, first_pt_x) | ||
all_other_pts_y <- c(all_other_pts_y, first_pt_y) | ||
path_ending <- " Z" | ||
} | ||
|
||
d <- sprintf("M%s %s %s%s", first_pt_x, first_pt_y, | ||
paste0("L", all_other_pts_x, " ", | ||
all_other_pts_y, collapse = " "), | ||
path_ending) | ||
return(d) | ||
} |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,33 @@ | ||
# Converting sf polygons into SVG coordinates | ||
# This function will work if `sf_obj` is an individual polygon | ||
sf_to_coords <- function(sf_obj, svg_width, view_bbox = NULL) { | ||
|
||
coords <- st_coordinates(sf_obj) | ||
x_dec <- coords[,1] | ||
y_dec <- coords[,2] | ||
|
||
# Using the whole view, figure out coordinates | ||
# If view_bbox isn't provided, assume sf_obj is the whole view | ||
if(is.null(view_bbox)) view_bbox <- st_bbox(sf_obj) | ||
|
||
x_extent <- c(view_bbox$xmin, view_bbox$xmax) | ||
y_extent <- c(view_bbox$ymin, view_bbox$ymax) | ||
|
||
# Calculate aspect ratio | ||
aspect_ratio <- diff(x_extent)/diff(y_extent) | ||
|
||
# Figure out what the svg_height is based on svg_width, maintaining the aspect ratio | ||
svg_height <- svg_width / aspect_ratio | ||
|
||
# Convert longitude and latitude to SVG horizontal and vertical positions | ||
# Remember that SVG vertical position has 0 on top | ||
x_extent_pixels <- x_extent - view_bbox$xmin | ||
y_extent_pixels <- y_extent - view_bbox$ymin | ||
x_pixels <- x_dec - view_bbox$xmin # Make it so that the minimum longitude = 0 pixels | ||
y_pixels <- y_dec - view_bbox$ymin # Make it so that the maximum latitude = 0 | ||
|
||
data.frame( | ||
x = round(approx(x_extent_pixels, c(0, svg_width), x_pixels)$y, 6), | ||
y = round(approx(y_extent_pixels, c(svg_height, 0), y_pixels)$y, 6) | ||
) | ||
} |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,57 @@ | ||
# Build an SVG using XML components | ||
|
||
source("3_build/src/svg_xml_helpers.R") | ||
|
||
p3_targets <- list( | ||
|
||
tar_target( | ||
root_svg, | ||
init_svg("3_build/tmp/root.svg", | ||
viewbox_dims = c(0, 0, svg_width=svg_width, svg_height=700)), | ||
format = "file" | ||
), | ||
|
||
# Add states | ||
# TODO: groups don't seem to actually be working | ||
tar_target( | ||
g_conus_state_svg, | ||
add_grp(out_svg = "3_build/tmp/g_conus_state.svg", | ||
in_svg = root_svg, | ||
grp_nm = 'conus-states', trans_x = 0, trans_y = 0), | ||
format = "file" | ||
), | ||
|
||
tar_target( | ||
state_paths_svg, | ||
add_child_paths(out_svg = "3_build/tmp/state_paths.svg", | ||
in_svg = g_conus_state_svg, | ||
paths = p2_conus_states_paths, | ||
path_nms = sprintf('state-%s', p2_conus_states_names)), | ||
format = "file" | ||
), | ||
|
||
# Add in HUCs | ||
tar_target( | ||
g_huc8s_svg, | ||
add_grp(out_svg = "3_build/tmp/g_huc8s.svg", | ||
in_svg = state_paths_svg, | ||
grp_nm = 'huc8s', trans_x = 0, trans_y = 0), | ||
format = "file" | ||
), | ||
|
||
tar_target( | ||
huc8s_paths_svg, | ||
add_child_paths(out_svg = "3_build/tmp/huc8s_paths.svg", | ||
in_svg = g_huc8s_svg, | ||
paths = p2_huc8s_paths, | ||
path_nms = rep('huc8s', length(p2_huc8s_paths))), | ||
format = "file" | ||
), | ||
|
||
tar_target( | ||
map_svg, | ||
build_final_svg("3_build/out/map.svg", huc8s_paths_svg), | ||
format = "file" | ||
) | ||
|
||
) |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,42 @@ | ||
# Each of the steps has to read and write a file or you will get an | ||
# error about an invalid external pointer (this is because of how xml2 | ||
# edits the global var, see more at https://github.com/tidyverse/rvest/issues/181) | ||
|
||
init_svg <- function(out_svg, viewbox_dims) { | ||
# Create the main "parent" svg node. This is the top-level part of the svg | ||
svg_root <- xml_new_root('svg', | ||
viewBox = paste(viewbox_dims, collapse=" "), | ||
preserveAspectRatio="xMidYMid meet", | ||
xmlns="http://www.w3.org/2000/svg", | ||
`xmlns:xlink`="http://www.w3.org/1999/xlink") | ||
write_xml(svg_root, out_svg) | ||
return(out_svg) | ||
} | ||
|
||
add_grp <- function(out_svg, in_svg, grp_nm, trans_x, trans_y) { | ||
|
||
current_svg <- read_xml(in_svg) | ||
|
||
current_svg %>% | ||
xml_add_child('g', id = grp_nm, | ||
transform = sprintf("translate(%s %s) scale(1, 1)", trans_x, trans_y)) | ||
|
||
write_xml(current_svg, out_svg) | ||
return(out_svg) | ||
} | ||
|
||
add_child_paths <- function(out_svg, in_svg, paths, path_nms) { | ||
svg_state <- read_xml(in_svg) | ||
for(i in 1:length(paths)) { | ||
xml_add_child(svg_state, 'path', d = paths[i], | ||
class = path_nms[i], | ||
style = "stroke:#9fabb7;stroke-width:0.5;fill:none") | ||
} | ||
write_xml(svg_state, out_svg) | ||
return(out_svg) | ||
} | ||
|
||
build_final_svg <- function(out_svg, in_svg) { | ||
read_xml(in_svg) %>% write_xml(file = out_svg) | ||
return(out_svg) | ||
} |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
So if we wanted to make a map with all HUCs we would need to list them all?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I want to make a helper function for this - allow you to pass in specific HUC 8s or get all. But currently, yes you would. Just don't have time to outfit the pipeline to do all the things just yet :)
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Made an issue. See #2