Housing market at a glance

Suggested answers

Application exercise
Answers
Modified

April 18, 2024

We will create a dashboard to visualize the housing market in the United States. We will use data on mortgage rates, housing opportunity index, and mortgage origination rates.

Revisions to the dashboard

Your turn:

Source code for the final dashboard

---
title: "Housing Market at a Glance"
format: 
  dashboard:
    theme: [litera, custom.scss]
    orientation: columns
logo: logo.png
---

```{r}
#| label: setup
#| include: false

# import packages
library(tidyverse)
library(scales)
library(plotly)
library(sf)
library(tigris)
library(gt)
library(geofacet)

# set default ggplot2 theme
theme_set(theme_minimal(base_family = "Atkinson Hyperlegible", base_size = 14))

# import weekly mortgage interest rates
mortgages <- read_csv("data/weekly_mortgage_rates.csv") |>
  # clean columns for consistency
  mutate(
    fixed_30 = fixed_30 / 100,
    fixed_15 = fixed_15 / 100
  ) |>
  select(date, fixed_30, fixed_15)

# import median sale price
median_housing <- read_csv("data/median-housing.csv") |>
  # clean columns for consistency
  mutate(DATE = mdy(DATE)) |>
  rename(
    date = DATE,
    price = MSPUS
  )

# import housing opportunity index
hoi <- read_csv("data/hoi.csv") |>
  arrange(date) |>
  # clean columns for consistency
  mutate(
    hoi = hoi / 100,
    median_price = median_price * 1000
  )

# import mortgage origination rate
origin <- read_csv("data/mortgage-origination-state.csv")

# join with states sf data frame for mapping
origin_sf <- states() |>
  shift_geometry() |>
  filter(STUSPS %in% state.abb) |>
  left_join(y = origin)
```

```{r}
#| label: create-graphs
#| include: false

# mortgage rates over time
mortgage_p <- mortgages |>
  pivot_longer(
    cols = starts_with("fixed"),
    names_to = "type",
    values_to = "rate"
  ) |>
  mutate(
    type = case_match(
      .x = type,
      "fixed_30" ~ "Fixed 30-year",
      "fixed_15" ~ "Fixed 15-year"
    ),
    tooltip = str_glue("Date: {date}<br>Rate: {label_percent(accuracy = 0.1)(rate)}<br>Type: {type}")
  ) |>
  ggplot(mapping = aes(x = date, y = rate, color = type)) +
  geom_line(mapping = aes(text = tooltip, group = type)) +
  scale_y_continuous(labels = label_percent()) +
  scale_color_viridis_d(end = 0.8, guide = guide_legend(reverse = TRUE)) +
  labs(
    title = "Interest Rates 15- and 30-Year",
    x = NULL, y = NULL, color = NULL
  ) +
  theme(legend.position = "top")

# housing opportunity index
hoi_p <- hoi |>
  mutate(tooltip = str_glue("Date: {date}<br>HOI: {label_percent(accuracy = 0.1)(hoi)}")) |>
  ggplot(mapping = aes(x = date, y = hoi)) +
  geom_line(mapping = aes(text = tooltip, group = 1)) +
  scale_y_continuous(labels = label_percent()) +
  labs(
    title = "Housing Opportunity Index",
    subtitle = "Percentage of homes affordable to median-income families",
    x = NULL, y = NULL
  )

# mortgage origination by state over time using geofacet
origin_state <- ggplot(data = origin, mapping = aes(x = date, y = mort_adj)) +
  geom_line() +
  scale_x_continuous(breaks = c(2000, 2020), labels = c("'00", "'20")) +
  facet_geo(facets = vars(NAME), labeller = label_wrap_gen(width = 15)) +
  labs(
    title = "Mortgage Originations per Capita",
    subtitle = "Mortgages originated per 1,000 residents",
    x = NULL,
    y = NULL
  ) +
  theme(
    strip.text = element_text(size = rel(0.6))
  )

# mortgage origination by state - ggplot2 and sf map
origin_map <- origin_sf |>
  filter(date == max(date)) |>
  ggplot(mapping = aes(fill = mort_adj)) +
  geom_sf() +
  scale_fill_viridis_c(labels = label_percent()) +
  labs(
    title = "Mortgage Originations per Capita",
    subtitle = "Mortgages originated per 1,000 residents"
  )

# mortgage origination by state - plotly map
origin_map_plotly <- origin |>
  # add hover text strings
  mutate(hover = str_glue("{NAME}: {label_number(accuracy = 0.1)(mort_adj)} per thousand residents in {date}")) |>
  # use built-in geographic data
  plot_geo(locationmode = "USA-states") |>
  # add choropleth layer
  add_trace(
    # type of chart
    type = "choropleth",
    # 2 letter abbreviations for each state
    locations = ~STUSPS,
    # variable to use for color shading
    z = ~mort_adj,
    # variable to use for animation
    frame = ~date,
    # tooltip text
    text = ~hover,
    # type of info to use for tooltip hover
    hoverinfo = "text",
    # choose a color scale
    colorscale = "Viridis",
    # fix the minimum and maximum of the colorbar to the entire time period
    zmin = min(origin$mort_adj),
    zmax = max(origin$mort_adj),
    # no separate borders between states
    marker = list(line = list(
      width = 0
    ))
  ) |>
  # set layout options
  layout(
    # plot title
    title = "Mortgage Originations per Capita<br>Mortgages originated per thousand residents",
    # geographic info
    geo = list(
      scope = "usa",
      projection = list(type = "albers usa")
    ),
    # adjust font to match rest of site
    font = list(
      family = "Atkinson Hyperlegible"
    )
  ) |>
  colorbar(title = "") |>
  # animation options
  animation_opts(
    # frame duration in milliseconds
    frame = 1000,
  ) |>
  animation_slider(
    currentvalue = list(prefix = "Year: ")
  )

# median home prices
median_home_p <- median_housing |>
  mutate(tooltip = str_glue("Date: {date}<br>Price: {label_dollar()(price)}")) |>
  ggplot(mapping = aes(x = date, y = price)) +
  geom_line(mapping = aes(text = tooltip, group = 1)) +
  scale_y_continuous(labels = label_dollar(scale_cut = cut_short_scale())) +
  labs(
    title = "Median Home Prices",
    y = "Median Home Price\n(nominal)",
    x = NULL
  )
```

# Stats

## Column {width="20%"}

```{r}
#| include: false

# get most recent records for mortgage rates and home sale prices
last_row <- slice_tail(mortgages, n = 1)
last_home_price <- slice_tail(hoi, n = 1)
```

```{r}
#| content: valuebox
#| title: !expr str_glue('Average annual rate for a 30-year fixed mortgage in {last_row |> pull(date) |> format(format = "%b. %Y")}')
#| icon: house-door
#| color: info

list(
  value = label_percent(accuracy = 0.1)(last_row |> pull(fixed_30))
)
```

```{r}
#| content: valuebox
#| title: !expr str_glue('Average annual rate for a 15-year fixed mortgage in {last_row |> pull(date) |> format(format = "%b. %Y")}')
#| icon: house-door
#| color: info

list(
  value = label_percent(accuracy = 0.1)(last_row |> pull(fixed_15))
)
```

```{r}
#| content: valuebox
#| title: !expr str_glue('National median home price in {last_home_price |> pull(date) |> format(format = "%b. %Y")}')
#| icon: currency-dollar
#| color: info

list(
  value = label_dollar(scale_cut = cut_short_scale())(last_home_price |> pull(median_price))
)
```

## Column 

```{r}
#| title: "Mortgage Originations per Capita"
#| height: 50%

# plotly map
origin_map_plotly
```

```{r}
#| title: Mortgage Interest Rates
#| height: 50%

# formatted table of weekly mortgage rates
mortgages |>
  gt() |>
  cols_label(
    date = "Date",
    fixed_30 = "Fixed 30-year rate",
    fixed_15 = "Fixed 15-year rate"
  ) |>
  fmt_percent(
    columns = starts_with("fixed")
  ) |>
  fmt_date(
    columns = date,
    date_style = "month_day_year"
  ) |>
  sub_missing() |>
  opt_interactive(
    use_search = TRUE,
    use_compact_mode = TRUE,
    pagination_type = "jump"
  )
```

## Column {.tabset width="40%"}

```{r}
#| title: "Housing Economics"

# interest rates
mortgage_p |>
  # ensure correct column is used for tooltips
  ggplotly(tooltip = "text") |>
  # move legend - doesn't accept theme() values
  layout(legend = list(orientation = "v", x = 0.95, y = 0.95, traceorder = "reversed", xanchor = "right"))

# housing opportunity index
ggplotly(hoi_p, tooltip = "text")
```

```{r}
#| title: "Median Price"

# median sales price
ggplotly(median_home_p, tooltip = "text")
```

# Data

-  [Mortgage Interest Rates 15- and 30-Year](https://www.nahb.org/news-and-economics/housing-economics/national-statistics/weekly-mortgage-rates-15-and-30-year)
-  [Housing Opportunity Index](https://www.nahb.org/news-and-economics/housing-economics/indices/housing-opportunity-index)
-  [Median Home Prices](https://fred.stlouisfed.org/series/MSPUS)

Acknowledgments

sessioninfo::session_info()
─ Session info ───────────────────────────────────────────────────────────────
 setting  value
 version  R version 4.3.2 (2023-10-31)
 os       macOS Ventura 13.6.6
 system   aarch64, darwin20
 ui       X11
 language (EN)
 collate  en_US.UTF-8
 ctype    en_US.UTF-8
 tz       America/New_York
 date     2024-04-18
 pandoc   3.1.1 @ /Applications/RStudio.app/Contents/Resources/app/quarto/bin/tools/ (via rmarkdown)

─ Packages ───────────────────────────────────────────────────────────────────
 package     * version date (UTC) lib source
 cli           3.6.2   2023-12-11 [1] CRAN (R 4.3.1)
 digest        0.6.34  2024-01-11 [1] CRAN (R 4.3.1)
 evaluate      0.23    2023-11-01 [1] CRAN (R 4.3.1)
 fastmap       1.1.1   2023-02-24 [1] CRAN (R 4.3.0)
 here          1.0.1   2020-12-13 [1] CRAN (R 4.3.0)
 htmltools     0.5.7   2023-11-03 [1] CRAN (R 4.3.1)
 htmlwidgets   1.6.4   2023-12-06 [1] CRAN (R 4.3.1)
 jsonlite      1.8.8   2023-12-04 [1] CRAN (R 4.3.1)
 knitr         1.45    2023-10-30 [1] CRAN (R 4.3.1)
 rlang         1.1.3   2024-01-10 [1] CRAN (R 4.3.1)
 rmarkdown     2.25    2023-09-18 [1] CRAN (R 4.3.1)
 rprojroot     2.0.4   2023-11-05 [1] CRAN (R 4.3.1)
 rstudioapi    0.15.0  2023-07-07 [1] CRAN (R 4.3.0)
 sessioninfo   1.2.2   2021-12-06 [1] CRAN (R 4.3.0)
 xfun          0.41    2023-11-01 [1] CRAN (R 4.3.1)
 yaml          2.3.8   2023-12-11 [1] CRAN (R 4.3.1)

 [1] /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/library

──────────────────────────────────────────────────────────────────────────────