Today we’re going to create some maps based on various information in
states. We’re going to start by installing the necessary packages and
loading in all of our data.
#load in the packages
library(sf)
library(dplyr)
library(spData)
library(urbnmapr)
library(ggplot2)
library(sp)
library(ggmap)
library(ggthemes)
library(stringr)
library(ggspatial)
#load in all the data
setwd("shapefile")
Warning: The working directory was changed to /cloud/project/shapefile inside a notebook chunk. The working directory will be reset when the chunk is finished running. Use the knitr root.dir option in the setup chunk to change the working directory for notebook chunks.
map <- st_read("holc_ad_data.shp")
Reading layer `holc_ad_data' from data source `/cloud/project/shapefile/holc_ad_data.shp' using driver `ESRI Shapefile'
Simple feature collection with 8878 features and 7 fields (with 3 geometries empty)
Geometry type: MULTIPOLYGON
Dimension: XY
Bounding box: xmin: -122.7675 ymin: 25.70537 xmax: -70.9492 ymax: 47.72251
Geodetic CRS: WGS 84
#load the county base map
counties <- get_urbn_map("counties", sf = TRUE)
setwd("/cloud/project")
data <- read.csv("county_data.csv")
#create a new variable, counties1, which removed "county" only leaving county names
counties1 <- counties %>%
mutate(county_name = str_remove_all(county_name, " County| Parish| Borough| Census Area| Municipality")) %>%
mutate(county_name = gsub("[.]", "", county_name))
colnames(data)[3] <- "state_name"
#Create a new variable, data_merged ordering it by county and state names
data_merged <- merge(counties1, data, by = c("county_name", "state_name"))
old-style crs object detected; please recreate object with a recent sf::st_crs()
Map 1
Now we’re going to look at the percentage of those with a college
degree in California. We need to form a “fill” color for the background
of the map, a “fill” color gradient that represent the percentages of
college degrees present and labels for our map. Darker shades of
blue/purple on the map represent higher regions with higher percentages
of college degrees while ivory represents lower percentages of college
degrees present.
#First, we want to look at California specifically so let's filter the state of California
cali <- data_merged %>% filter(state_name == "California")
#Now let's form the graph based on the percentage of college degrees in California
ggplot()+
geom_sf(cali, mapping = aes(), fill = "gray")+
geom_sf(cali, mapping = aes(fill =as.numeric(percent_college_degree)))+
scale_fill_gradient(low = "ivory", high = "blue")+
labs(title = "Percentage of Population with College Degrees in California", fill = "College Degrees Percentage")

NA
Map 2
sf_use_s2(FALSE)
map <- map %>% st_transform("EPSG:4267")
counties1 <- counties1 %>% st_transform("EPSG:4267")
old-style crs object detected; please recreate object with a recent sf::st_crs()
chicago <- counties1 %>% filter(county_name == "Cook" & state_name == "Illinois")
map_chicago <- map[chicago,]
although coordinates are longitude/latitude, st_intersects assumes that they are planar
#Forming the map
ggplot()+
geom_sf(map_chicago, mapping = aes(), fill = "gray")+
geom_sf(map_chicago, mapping = aes(fill = holc_grade))+
theme_classic()+
labs(title ="Redlining in Chicago", fill = "Redline Score")+
theme(plot.title = element_text(hjust = 0.5))+
ylim(41.6, 42.15)+
xlim(-87.9, -87.5)

LAT1 = 41.6
LAT2 = 42.15
LON1 = -87.9
LON2 = -87.5
base_map <- get_stamenmap(bbox = c(left = LON1, right = LON2,
bottom = LAT1, top = LAT2),
maptype = "watercolor")
ℹ Map tiles by Stamen Design, under CC BY 3.0. Data by OpenStreetMap, under CC BY SA.
colors <- c("blue", "aquamarine", "magenta2", "red")
ggmap(base_map)+
geom_sf(map_chicago, mapping = aes(fill = holc_grade), color = "ivory",
inherit.aes = FALSE, alpha = 0.6)+
theme_classic()+
labs(title ="Redlining in Chicago", fill = "Redline Score")+
theme(plot.title = element_text(hjust = 0.5))+
scale_fill_manual(values = colors)
Coordinate system already present. Adding new coordinate system, which will replace the existing one.

#This last line just a color scheme - you can change it to anything you want
#you can manually change it with scale_fill_manual and create your own palette (no need to use stata colors unless you want to!)
Map 3
#The map
#don't worry about missing data here - just make it look nice!
ggplot()+
geom_sf(data_merged, mapping = aes(), fill = "gray", color = "black")+
geom_sf(data_merged, mapping = aes(fill = migration_outflow), color = "black")+
theme_map()+
scale_fill_gradient(low = "firebrick1", high = "ivory")+
labs(title= "Migration Outflow in the US, 2002",
fill = "Migration Outflow")+
theme(plot.title = element_text(hjust = 0.5))

NA
Map 4: Challenge Map
In this map, I have also added some code to include a scale bar and
north arrow. Play around with the code to see if you can make them look
nicer.
states <- get_urbn_map("states", sf = TRUE)
in_migration_data <- data %>% select(state_name, migration_inflow) %>%
group_by(state_name) %>%
summarise(mean_migration = mean(migration_inflow, na.rm=T))
in_migration_data[9,1] <- "District of Columbia"
#now merge it
migration_merged <- merge(states, in_migration_data, by = "state_name")
old-style crs object detected; please recreate object with a recent sf::st_crs()
migration_merged <- migration_merged %>% st_transform("epsg:4326")
#The map
ggplot()+
geom_sf(migration_merged, mapping = aes(), fill = "ivory", color = "black")+
geom_sf(migration_merged, mapping = aes(fill = mean_migration), color = "black")+
labs(title = "Migration Desitnations by State, 2000",
fill = "Mean of Migration")+
theme(plot.title = element_text(hjust = 0.5))+
scale_fill_gradient(low = "ivory", high = "purple")+
theme_igray()+
annotation_scale(
#tr = top right
location = "tr",
bar_cols = c("ivory", "purple")) +
#Add a north arrow in the top right corner
annotation_north_arrow(
#br = bottom right
location = "br",
pad_x = unit(0.2, "in"), pad_y = unit(0.2, "in"),
style = north_arrow_nautical(line_col = "black"))

LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKVG9kYXkgd2UncmUgZ29pbmcgdG8gY3JlYXRlIHNvbWUgbWFwcyBiYXNlZCBvbiB2YXJpb3VzIGluZm9ybWF0aW9uIGluIHN0YXRlcy4gV2UncmUgZ29pbmcgdG8gc3RhcnQgYnkgaW5zdGFsbGluZyB0aGUgbmVjZXNzYXJ5IHBhY2thZ2VzIGFuZCBsb2FkaW5nIGluIGFsbCBvZiBvdXIgZGF0YS4KCmBgYHtyfQojbG9hZCBpbiB0aGUgcGFja2FnZXMKbGlicmFyeShzZikgICAgIApsaWJyYXJ5KGRwbHlyKSAgIApsaWJyYXJ5KHNwRGF0YSkgCmxpYnJhcnkodXJibm1hcHIpCmxpYnJhcnkoZ2dwbG90MikKbGlicmFyeShzcCkKbGlicmFyeShnZ21hcCkKbGlicmFyeShnZ3RoZW1lcykKbGlicmFyeShzdHJpbmdyKQpsaWJyYXJ5KGdnc3BhdGlhbCkKCgojbG9hZCBpbiBhbGwgdGhlIGRhdGEKc2V0d2QoInNoYXBlZmlsZSIpCm1hcCA8LSBzdF9yZWFkKCJob2xjX2FkX2RhdGEuc2hwIikKCiNsb2FkIHRoZSBjb3VudHkgYmFzZSBtYXAKY291bnRpZXMgPC0gZ2V0X3VyYm5fbWFwKCJjb3VudGllcyIsIHNmID0gVFJVRSkKc2V0d2QoIi9jbG91ZC9wcm9qZWN0IikKZGF0YSA8LSByZWFkLmNzdigiY291bnR5X2RhdGEuY3N2IikKCiNjcmVhdGUgYSBuZXcgdmFyaWFibGUsIGNvdW50aWVzMSwgd2hpY2ggcmVtb3ZlZCAiY291bnR5IiBvbmx5IGxlYXZpbmcgY291bnR5IG5hbWVzCmNvdW50aWVzMSA8LSBjb3VudGllcyAlPiUgCiAgbXV0YXRlKGNvdW50eV9uYW1lID0gc3RyX3JlbW92ZV9hbGwoY291bnR5X25hbWUsICIgQ291bnR5fCBQYXJpc2h8IEJvcm91Z2h8IENlbnN1cyBBcmVhfCBNdW5pY2lwYWxpdHkiKSkgJT4lIAogIG11dGF0ZShjb3VudHlfbmFtZSA9IGdzdWIoIlsuXSIsICIiLCBjb3VudHlfbmFtZSkpIAoKY29sbmFtZXMoZGF0YSlbM10gPC0gInN0YXRlX25hbWUiCgojQ3JlYXRlIGEgbmV3IHZhcmlhYmxlLCBkYXRhX21lcmdlZCBvcmRlcmluZyBpdCBieSBjb3VudHkgYW5kIHN0YXRlIG5hbWVzIApkYXRhX21lcmdlZCA8LSBtZXJnZShjb3VudGllczEsIGRhdGEsIGJ5ID0gYygiY291bnR5X25hbWUiLCAic3RhdGVfbmFtZSIpKQpgYGAKCk1hcCAxCgpOb3cgd2UncmUgZ29pbmcgdG8gbG9vayBhdCB0aGUgcGVyY2VudGFnZSBvZiB0aG9zZSB3aXRoIGEgY29sbGVnZSBkZWdyZWUgaW4gQ2FsaWZvcm5pYS4gV2UgbmVlZCB0byBmb3JtIGEgImZpbGwiIGNvbG9yIGZvciB0aGUgYmFja2dyb3VuZCBvZiB0aGUgbWFwLCBhICJmaWxsIiBjb2xvciBncmFkaWVudCB0aGF0IHJlcHJlc2VudCB0aGUgcGVyY2VudGFnZXMgb2YgY29sbGVnZSBkZWdyZWVzIHByZXNlbnQgYW5kIGxhYmVscyBmb3Igb3VyIG1hcC4gRGFya2VyIHNoYWRlcyBvZiBibHVlL3B1cnBsZSBvbiB0aGUgbWFwIHJlcHJlc2VudCBoaWdoZXIgcmVnaW9ucyB3aXRoIGhpZ2hlciBwZXJjZW50YWdlcyBvZiBjb2xsZWdlIGRlZ3JlZXMgd2hpbGUgaXZvcnkgcmVwcmVzZW50cyBsb3dlciBwZXJjZW50YWdlcyBvZiBjb2xsZWdlIGRlZ3JlZXMgcHJlc2VudC4KCgpgYGB7cn0KI0ZpcnN0LCB3ZSB3YW50IHRvIGxvb2sgYXQgQ2FsaWZvcm5pYSBzcGVjaWZpY2FsbHkgc28gbGV0J3MgZmlsdGVyIHRoZSBzdGF0ZSBvZiBDYWxpZm9ybmlhCmNhbGkgPC0gZGF0YV9tZXJnZWQgJT4lIGZpbHRlcihzdGF0ZV9uYW1lID09ICJDYWxpZm9ybmlhIikKCiNOb3cgbGV0J3MgZm9ybSB0aGUgZ3JhcGggYmFzZWQgb24gdGhlIHBlcmNlbnRhZ2Ugb2YgY29sbGVnZSBkZWdyZWVzIGluIENhbGlmb3JuaWEKZ2dwbG90KCkrCiAgZ2VvbV9zZihjYWxpLCBtYXBwaW5nID0gYWVzKCksIGZpbGwgPSAiZ3JheSIpKwogIGdlb21fc2YoY2FsaSwgbWFwcGluZyA9IGFlcyhmaWxsID1hcy5udW1lcmljKHBlcmNlbnRfY29sbGVnZV9kZWdyZWUpKSkrCiAgc2NhbGVfZmlsbF9ncmFkaWVudChsb3cgPSAiaXZvcnkiLCBoaWdoID0gImJsdWUiKSsKICBsYWJzKHRpdGxlID0gIlBlcmNlbnRhZ2Ugb2YgUG9wdWxhdGlvbiB3aXRoIENvbGxlZ2UgRGVncmVlcyBpbiBDYWxpZm9ybmlhIiwgZmlsbCA9ICJDb2xsZWdlIERlZ3JlZXMgUGVyY2VudGFnZSIpCiAgCmBgYApNYXAgMgoKYGBge3J9CnNmX3VzZV9zMihGQUxTRSkKCm1hcCA8LSBtYXAgJT4lIHN0X3RyYW5zZm9ybSgiRVBTRzo0MjY3IikKY291bnRpZXMxIDwtIGNvdW50aWVzMSAlPiUgc3RfdHJhbnNmb3JtKCJFUFNHOjQyNjciKQoKY2hpY2FnbyA8LSBjb3VudGllczEgJT4lIGZpbHRlcihjb3VudHlfbmFtZSA9PSAiQ29vayIgJiBzdGF0ZV9uYW1lID09ICJJbGxpbm9pcyIpCgptYXBfY2hpY2FnbyA8LSBtYXBbY2hpY2FnbyxdCgoKI0Zvcm1pbmcgdGhlIG1hcApnZ3Bsb3QoKSsKICBnZW9tX3NmKG1hcF9jaGljYWdvLCBtYXBwaW5nID0gYWVzKCksIGZpbGwgPSAiZ3JheSIpKwogIGdlb21fc2YobWFwX2NoaWNhZ28sIG1hcHBpbmcgPSBhZXMoZmlsbCA9IGhvbGNfZ3JhZGUpKSsKICB0aGVtZV9jbGFzc2ljKCkrCiAgbGFicyh0aXRsZSA9IlJlZGxpbmluZyBpbiBDaGljYWdvIiwgZmlsbCA9ICJSZWRsaW5lIFNjb3JlIikrCiAgdGhlbWUocGxvdC50aXRsZSA9IGVsZW1lbnRfdGV4dChoanVzdCA9IDAuNSkpKwogIHlsaW0oNDEuNiwgNDIuMTUpKwogIHhsaW0oLTg3LjksIC04Ny41KQoKTEFUMSA9IDQxLjYKTEFUMiA9IDQyLjE1CkxPTjEgPSAtODcuOQpMT04yID0gLTg3LjUKCmJhc2VfbWFwIDwtIGdldF9zdGFtZW5tYXAoYmJveCA9IGMobGVmdCA9IExPTjEsIHJpZ2h0ID0gTE9OMiwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgYm90dG9tID0gTEFUMSwgdG9wID0gTEFUMiksCiAgICAgICAgICAgICAgICAgICAgICAgICAgbWFwdHlwZSA9ICJ3YXRlcmNvbG9yIikKCmNvbG9ycyA8LSBjKCJibHVlIiwgImFxdWFtYXJpbmUiLCAibWFnZW50YTIiLCAicmVkIikKCmdnbWFwKGJhc2VfbWFwKSsKICAgZ2VvbV9zZihtYXBfY2hpY2FnbywgbWFwcGluZyA9IGFlcyhmaWxsID0gaG9sY19ncmFkZSksIGNvbG9yID0gIml2b3J5IiwKICAgICAgICAgICAgaW5oZXJpdC5hZXMgPSBGQUxTRSwgYWxwaGEgPSAwLjYpKwogIHRoZW1lX2NsYXNzaWMoKSsKICBsYWJzKHRpdGxlID0iUmVkbGluaW5nIGluIENoaWNhZ28iLCBmaWxsID0gIlJlZGxpbmUgU2NvcmUiKSsKICB0aGVtZShwbG90LnRpdGxlID0gZWxlbWVudF90ZXh0KGhqdXN0ID0gMC41KSkrCiAgc2NhbGVfZmlsbF9tYW51YWwodmFsdWVzID0gY29sb3JzKQoKCiAgCiAgICAgICAgICAgCiAgCiAKCiAKIAogICNUaGlzIGxhc3QgbGluZSBqdXN0IGEgY29sb3Igc2NoZW1lIC0geW91IGNhbiBjaGFuZ2UgaXQgdG8gYW55dGhpbmcgeW91IHdhbnQKICAjeW91IGNhbiBtYW51YWxseSBjaGFuZ2UgaXQgd2l0aCBzY2FsZV9maWxsX21hbnVhbCBhbmQgY3JlYXRlIHlvdXIgb3duIHBhbGV0dGUgKG5vIG5lZWQgdG8gICAgIHVzZSBzdGF0YSBjb2xvcnMgdW5sZXNzIHlvdSB3YW50IHRvISkKICAKCgpgYGAKCk1hcCAzCgpgYGB7cn0KI1RoZSBtYXAKI2Rvbid0IHdvcnJ5IGFib3V0IG1pc3NpbmcgZGF0YSBoZXJlIC0ganVzdCBtYWtlIGl0IGxvb2sgbmljZSEKZ2dwbG90KCkrCiAgZ2VvbV9zZihkYXRhX21lcmdlZCwgbWFwcGluZyA9IGFlcygpLCBmaWxsID0gImdyYXkiLCBjb2xvciA9ICJibGFjayIpKwogIGdlb21fc2YoZGF0YV9tZXJnZWQsIG1hcHBpbmcgPSBhZXMoZmlsbCA9IG1pZ3JhdGlvbl9vdXRmbG93KSwgY29sb3IgPSAiYmxhY2siKSsKICB0aGVtZV9tYXAoKSsKICBzY2FsZV9maWxsX2dyYWRpZW50KGxvdyA9ICJmaXJlYnJpY2sxIiwgaGlnaCA9ICJpdm9yeSIpKwogIGxhYnModGl0bGU9ICJNaWdyYXRpb24gT3V0ZmxvdyBpbiB0aGUgVVMsIDIwMDIiLAogICAgICAgZmlsbCA9ICJNaWdyYXRpb24gT3V0ZmxvdyIpKwogIHRoZW1lKHBsb3QudGl0bGUgPSBlbGVtZW50X3RleHQoaGp1c3QgPSAwLjUpKQogICAgCmBgYAoKTWFwIDQ6IENoYWxsZW5nZSBNYXAKCkluIHRoaXMgbWFwLCBJIGhhdmUgYWxzbyBhZGRlZCBzb21lIGNvZGUgdG8gaW5jbHVkZSBhIHNjYWxlIGJhciBhbmQgbm9ydGggYXJyb3cuIFBsYXkgYXJvdW5kIHdpdGggdGhlIGNvZGUgdG8gc2VlIGlmIHlvdSBjYW4gbWFrZSB0aGVtIGxvb2sgbmljZXIuIAoKYGBge3J9CnN0YXRlcyA8LSBnZXRfdXJibl9tYXAoInN0YXRlcyIsIHNmID0gVFJVRSkKCmluX21pZ3JhdGlvbl9kYXRhIDwtIGRhdGEgJT4lIHNlbGVjdChzdGF0ZV9uYW1lLCBtaWdyYXRpb25faW5mbG93KSAlPiUgCiAgZ3JvdXBfYnkoc3RhdGVfbmFtZSkgJT4lIAogIHN1bW1hcmlzZShtZWFuX21pZ3JhdGlvbiA9IG1lYW4obWlncmF0aW9uX2luZmxvdywgbmEucm09VCkpCgppbl9taWdyYXRpb25fZGF0YVs5LDFdIDwtICJEaXN0cmljdCBvZiBDb2x1bWJpYSIKCiNub3cgbWVyZ2UgaXQKbWlncmF0aW9uX21lcmdlZCA8LSBtZXJnZShzdGF0ZXMsIGluX21pZ3JhdGlvbl9kYXRhLCBieSA9ICJzdGF0ZV9uYW1lIikKCm1pZ3JhdGlvbl9tZXJnZWQgPC0gbWlncmF0aW9uX21lcmdlZCAlPiUgc3RfdHJhbnNmb3JtKCJlcHNnOjQzMjYiKQoKI1RoZSBtYXAKZ2dwbG90KCkrCiAgZ2VvbV9zZihtaWdyYXRpb25fbWVyZ2VkLCBtYXBwaW5nID0gYWVzKCksIGZpbGwgPSAiaXZvcnkiLCBjb2xvciA9ICJibGFjayIpKwogIGdlb21fc2YobWlncmF0aW9uX21lcmdlZCwgbWFwcGluZyA9IGFlcyhmaWxsID0gbWVhbl9taWdyYXRpb24pLCBjb2xvciA9ICJibGFjayIpKwogIGxhYnModGl0bGUgPSAiTWlncmF0aW9uIERlc2l0bmF0aW9ucyBieSBTdGF0ZSwgMjAwMCIsCiAgICAgICBmaWxsID0gIk1lYW4gb2YgTWlncmF0aW9uIikrCiAgdGhlbWUocGxvdC50aXRsZSA9IGVsZW1lbnRfdGV4dChoanVzdCA9IDAuNSkpKwogIHNjYWxlX2ZpbGxfZ3JhZGllbnQobG93ID0gIml2b3J5IiwgaGlnaCA9ICJwdXJwbGUiKSsKICB0aGVtZV9pZ3JheSgpKwogIGFubm90YXRpb25fc2NhbGUoCiAgICAjdHIgPSB0b3AgcmlnaHQKICAgIGxvY2F0aW9uID0gInRyIiwKICAgIGJhcl9jb2xzID0gYygiaXZvcnkiLCAicHVycGxlIikpICsKICAjQWRkIGEgbm9ydGggYXJyb3cgaW4gdGhlIHRvcCByaWdodCBjb3JuZXIKICBhbm5vdGF0aW9uX25vcnRoX2Fycm93KAogICAgI2JyID0gYm90dG9tIHJpZ2h0CiAgICBsb2NhdGlvbiA9ICJiciIsCiAgICBwYWRfeCA9IHVuaXQoMC4yLCAiaW4iKSwgcGFkX3kgPSB1bml0KDAuMiwgImluIiksCiAgICBzdHlsZSA9IG5vcnRoX2Fycm93X25hdXRpY2FsKGxpbmVfY29sID0gImJsYWNrIikpCmBgYAo=