Introduction

The following visualizations are meant to ask the question of how Income, Life Expectancy, and Crime are related in the city of Baltimore. Specifically, I want to demonstrate how crime and income levels are intertwined and how this ultimately determines life expectancy in the city. I hope to demonstrate how much of a factor that income is in a communities quality of life and safety in the city.

Datasets

I’ve pulled three data sets from the data.baltimorecity.gov website that give me the proper data to analyze the correlation between the three. They represent 55 neighborhoods in Baltimore where quality of life can be vastly different.

The First data set is Average Life Expectancy by Neighborhood

The Second is Average Income Levels by Neighborhood

The Third is Violent Crime by Neighborhood per 1,000 Residents

lifeExpectancy <- "R_datafiles/Life_Expectancy.csv"
df <- fread(lifeExpectancy, na.strings=c(NA, ""))
medianIncome <- "R_datafiles/Median_Income.csv"
df2 <- fread(medianIncome, na.strings=c(NA, ""))
crime <- "R_datafiles/Violent_Crime.csv"
df3 <- fread(crime, na.strings=c(NA, ""))

df[, OBJECTID :=NULL]
df[, Shape__Area :=NULL]
df[, Shape__Length :=NULL]
df2[, OBJECTID :=NULL]
df2[, Shape__Area :=NULL]
df2[, Shape__Length :=NULL]
df3[, OBJECTID :=NULL]
df3[, Shape__Area :=NULL]
df3[, Shape__Length :=NULL]
colnames(df)[1] <- "Community"


baltimore <- df2 %>%
  select(CSA2010,mhhi18) %>%
  left_join(df, by = c("CSA2010" = "Community")) %>%
  left_join(df3, by = "CSA2010") %>%
  filter(CSA2010 != "Baltimore City")

box_df <- baltimore %>%
  mutate(quartile = factor(ntile(mhhi18, 4)))


crime_trim <- df3 %>%
  select(CSA2010, viol11:viol18)


ranked <- df %>% arrange(desc(`2018`))
top3 <- head(ranked$Community, 3)
bottom3 <- tail(ranked$Community, 3)
selected <- c(top3, bottom3)

income <-df2 %>%
  select(Community = CSA2010, MedianIncome = mhhi18)
#!!!!! medianIncome = file path, MedianIncome = column



df <- df %>%
  left_join(income, by = "Community")

Findings

Income By Community

First we can observe the income levels of each community. The chart visualizes each of the 55 communities. A steep drop can be seen after the top earning communities and then continues to decrease at a steady rate showing the spread of wealth across the city.

ggplot(income, aes(x = reorder(Community, MedianIncome), y = MedianIncome)) +
  geom_bar(stat = "identity", fill = "orange", color = "orange4") +
  coord_flip() +
  labs(title = "Median Income By Community (2018)" ,
  y = "Meidan Income", 
  x = "Community")

Income & Life Expectancy

In this scatter plot we can see how life expectancy may be affected by wealth. Although there are many outliers, we can see that the majority of communities follow the trend line. We can see a large concentration of communities on the lower end of the y axis representing life expectancy and a much smaller concentration towards the top right. This small concentration is also present in the previous graph before the steep drop off, suggesting that the communities with a larger share of the wealth have much higher life expectancy.

df_scatter <- df %>%
  mutate(Highlight = case_when(
    Community %in% top3 ~ "Top 3 (Life Expectancy)",
    Community %in% bottom3 ~ "Bottom 3 (Life Expectancy)",
    TRUE ~ "Other"
  ))
highlight_colors<- c(
  "Top 3 (Life Expectancy)" = "purple1",
  "Bottom 3 (Life Expectancy)" = "black",
  "Other" = "purple4"
)

ggplot(df_scatter, aes(x = MedianIncome, y = `2018`)) +
  geom_labelsmooth(aes(label = "Trend"), fill = "white",
                   method = "lm", formula = y ~ x,
                   size = 4, linewidth = 0.8, boxlinewidth = 0.4,
                   color = "gray40") + 
  geom_point(aes(color = Highlight), size = 3) +
  scale_color_manual(values = highlight_colors) + 
  labs(title = "Median Income vs. Life Expectancy Baltimore 2018",
       x = "Median Household Income",
       y = "Life Expectancy",
       color = NULL) +
  theme(plot.title = element_text(hjust = 0.5))

Crime Heatmap

This Heatmap represents the number of violent crimes occuring in each community per 1,000 residents from 2011 to 2018. This mapping shows there is a huge contrast between where crimes occur in the city of Baltimore with a small number of communities having a consistent rate below 5 and a large number having a consistent rate above 40. It is important to note that this graph is capped at 50 violent crimes for 1,000 residents. This was done because Downtown Seton Hill has a huge amount of violent crimes and a small population. Although this community has a decent share of wealth, they are in a central part of the city with alot of traffic where crime might leach over from neighboring communities, therfore skewing the data.

heat_df <- baltimore %>%
  pivot_longer(viol11:viol18, names_to = "year", values_to = "crime_rate") %>%
  mutate(year = factor(paste0("20", substr(year, 5, 6))))

my_levels <- baltimore %>% arrange(mhhi18) %>% pull(CSA2010)
heat_df$CSA2010 <- factor(heat_df$CSA2010, levels = my_levels)

#set cap for heatmap
breaks <- seq(0, 50, by = 10)

heatmap_plot <- ggplot(heat_df, aes(x = year, y = CSA2010, fill = crime_rate)) +
  geom_tile(color = "black") +
  geom_text(aes(label = round(crime_rate, 1)), size = 2) +
  labs(title = "Heatmap: Violent Crime rate by Community 2011-2018",
       x = "Year",
       y = "Community",
       fill = "Violent Crimes per 1,000",
       caption = "Color Capped at 50 Because Downtown Exceeds 50 Every Year Despite Small Population") +
  theme_minimal() +
  theme(plot.title = element_text(hjust = 0.5),
        axis.text.y = element_text(size = 6)) +
  scale_fill_continuous(low = "white", high = "navy",
                        limits = c(0, 50), oob = scales::squish,
                        breaks = breaks) +
  guides(fill = guide_legend(reverse = TRUE, override.aes = list(color = "black")))
heatmap_plot

Crime & Life Expectancy By Income

In these next two boxplots, I’ve taken the 55 communities and divided them into four quartiles based on income with the 1st quartile being the lowest income and the 4th being the highest. This boxplot represents each quartiles violent crime per 1,000 residents. It shows how crime an income might be related seen by the steady decrease of the median from the 1st to 4th quartile.

Violent Crime

crime_box <- ggplot(box_df, aes(x = quartile, y = viol18)) +
  geom_boxplot(fill = "navy" ,  alpha = 0.6, outlier.shape = NA) +
  geom_jitter(width = 0.2, color = "black", size = 1.5, alpha = 0.9) +
  labs(title = "Violent Crime Rate by Income Quartile 2018",
       x = "Income Quartile (1 = lowest, 4 = highest)",
       y = "Violent Crimes Per 1,000 Residents",
       caption = "Each dot represnts one community") +
  theme_minimal() +
  theme(plot.title = element_text(hjust = 0.5))

crime_box

Life Expectancy

This next boxplot shows the life expectancy of each quartile in relation to their income. It is interesting to note that this boxplot goes the opposite direction of the previous boxplot. Comparing these two graphs, it can be seen that for each quartile, as income levels rise, violent crime decreases and life expectancy increases.

life_box <- ggplot(box_df, aes(x = quartile, y = `2018`)) +
  geom_boxplot(fill = "pink4", alpha = 0.6, outlier.shape = NA) +
  geom_jitter(width = 0.2, color = "black", size = 1.5, alpha = 0.9) +
  labs(title = "Life Expectancy by Income Quartile 2018",
       x = "Income Quartile (1 = lowest, 4 = highest)",
       y = "Life Expectancy (Years)",
       caption = "each dot is one community") +
  theme_minimal() +
  theme(plot.title = element_text(hjust = 0.5))

life_box

Life Expectancy Gap

This lollipop chart shows where each community stands in relation to the average life expectancy in the city. Many of the lower income communities have an averge life expectancy around 4 or 5 years below the life expectancy. The higher income portion of the graph shows much more volitility with about 3 communities outperforming the rest of the city’s life expectancy.

city_le <- median(box_df$ `2018`, na.rm = TRUE)

lolli_df <- box_df %>%
  mutate(diff = `2018` - city_le,
          mycolor = ifelse(diff > 0, "Above", "Below"),
          CSA2010 = factor(CSA2010, levels = my_levels))

lolli_plot <- ggplot(lolli_df, aes(x = CSA2010, y = diff)) +
  geom_segment(aes(x = CSA2010, xend = CSA2010, y = 0, yend = diff, color = mycolor),
               linewidth = 1.3, alpha = 0.9) +
  geom_point(aes(color = mycolor), size = 2) +
  coord_flip() +
  scale_color_manual(values = c("Above" = "orange", "Below" = "purple3")) +
  labs(title = "Life Expectancy Compared to the Baltiore City Average 2018",
       x = "Community(Lowest at Bottom)",
       y = "Years above or Below city average",
       caption = "Orange = Longer Than city aveage, Purple = Shorter Than city average") +
  theme_minimal() +
  theme(legend.position = "none",
        plot.title = element_text(hjust = 0.5),
        axis.text.y = element_text(size = 6))
lolli_plot

Wealth Gap

Finally, This line graph represents the ratio of wealth between the top quartile and bottom quartile from 2010 to 2019. This graph simply compares the income levels from the bottom and top quartiles so it should not be affected by inflation over the years. It shows how from 2010 to 2012 there was a big increase in the gap between wealth in the city. This increase began to slow down after 2012 and even decreased from 2015 to 2016. However, after 2016 the line continues its increase. In 2019 the top quartile earned 3.3 times what the bottom quartile earned, compared to 2.4 times in 2010.

inc_long <- box_df %>%
  select(CSA2010, quartile) %>%
  left_join(df2 %>% select(CSA2010, mhhi10:mhhi19), by ="CSA2010") %>%
  pivot_longer(mhhi10:mhhi19, names_to = "year", values_to = "income") %>%
  mutate(year = factor(paste0("20", substr(year, 5, 6))))

inc_q <- inc_long %>%
  group_by(quartile, year) %>%
  summarize(median_income = median(income, na.rm = TRUE), .groups = "drop")

q4 <- inc_q %>% filter(quartile == 4) %>% select(year, q4_income = median_income)
q1 <- inc_q %>% filter(quartile == 1) %>% select(year, q1_income = median_income)

ratio_df <- q4 %>%
  left_join(q1, by = "year") %>%
  mutate(ratio = q4_income / q1_income)

ratio_plot <- ggplot(ratio_df, aes(x = year, y = ratio, group = 1)) +
  geom_line(color = "purple2", linewidth = 1) +
  geom_point(color = "orange", size = 2) +
  geom_text(aes(label = paste0(round(ratio, 1), "x")), vjust = -1, size = 3) +
  labs(title = "How Many Times More Do Baltimore's\n Wealthiest Communities Earn?",
       x = "Year",
       y = "Income Ratio (Top Quartile / Bottom Quartile)",
       caption = "Median Household Income of The Top and Bottom Quartile") +
  theme_minimal() +
  theme(plot.title  = element_text(hjust = 0.5))
ratio_plot

Conclusion

From this collection of visualizations, it can be concluded that crime, income levles, and life expectancy are all connected to each other in a very evident way. Inequality in Baltimore can be directly mapped back to income levels, which from what these visualizations demontrate, has a direct affect on how much crime happens in certain communities and how long people in these communities might live. Crime levels in the lowest quartile have increased drasticaly, while at the same time, the top quartile gains more wealth. In conclusion, it is suggested that income levels might be a major factor in the quality of life for people living in Baltimore and their communities.