demonstrate the effects of Census rounding wages on Atlanta Fed Wage Tracker

wgt.R

library(tidyverse)
library(lubridate)
library(haven)
library(assertr)
library(slider)
library(hrbrthemes)

# function to bin hourly wages of hourly workers
bin_hourly <- function(df, new, old) {
  df %>% 
    mutate({{new}} := case_when(
      # hourly workers
      # assign missing for "N < 15"
      {{old}} < 0.15 & paidhrly82 == 1 ~ NA_real_,
      # nearest $0.10
      {{old}} >= 0.15 & {{old}} < 1 & paidhrly82 == 1 ~ round({{old}}, 1),
      # nearest $0.50
      {{old}} >= 1 & {{old}} < 10 & paidhrly82 == 1 ~ round({{old}} * 2, 0) / 2,
      # nearest $1
      {{old}} >= 10 & {{old}} < 100 & paidhrly82 == 1 ~ round({{old}}, 0),
      # nearest $5
      {{old}}>= 100 & {{old}} < 1000 & paidhrly82 == 1 ~ round({{old}} * 1/5, 0) * 5,
      # nearest $10
      {{old}} >= 1000 & {{old}} < 10000 & paidhrly82 == 1 ~ round({{old}} * 1/10, 0) * 10,
      # top-coded
      {{old}} >= 10000 & paidhrly82 == 1 ~ NA_real_,
    ))
}

# function to bin weekly wages of non-hourly workers
bin_weekly <- function(df, new, old) {
  df %>% 
    mutate({{new}} := case_when(
      # assign missing for "N < 15"
      {{old}} < 15 & paidhrly82 == 0 ~ NA_real_,
      # nearest $10
      {{old}} >= 15 & {{old}} < 100 & paidhrly82 == 0 ~ round({{old}} / 10, 0) * 10,
      # nearest $50
      {{old}} >= 100 & {{old}} < 1000 & paidhrly82 == 0 ~ round({{old}} / 50, 0) * 50,
      # nearest $100
      {{old}} >= 1000 & {{old}} < 10000 & paidhrly82 == 0 ~ round({{old}} / 100, 0) * 100,
      # don't need to do higher categories since weekly wages seem top-coded at $2884.61
      {{old}} >= 10000 & paidhrly82 == 0 ~ NA_real_,
    ))
}

# get a subset of the raw data
# https://cps.kansascityfed.org/cpsdata/full/CPS_harmonized_variable_longitudinally_matched_age16plus.dta.gz
# WARNING: importing the data this way is slow
wgt_data_raw_subset <- read_dta(
    "CPS_harmonized_variable_longitudinally_matched_age16plus.dta.gz",
    col_select = c(date, personid, paidhrly82, age76, matches("wage|hrs|hours|perwk"))
  ) %>% 
  mutate(year = year(date)) %>%
  filter(year >= 1996 & age76 >= 16) %>%
  select(year, date, personid, paidhrly82, matches("wage|hrs|hours|perwk")) %>% 
  # keep only wage earners
  filter(!is.na(wageperhrclean82)) 

# prep microdata and create new binned wage
wgt_data_prepped <- wgt_data_raw_subset %>% 
  # these appear to be the WGT and underlying wages used by ATL Fed
  rename(
    wgt_original = wagegrowthtracker83,
    hourly_wage = wageperhrclean82,
    weekly_wage = wageperwkclean82
  ) %>%
  mutate(wage_old = hourly_wage) %>%
  # now check that ATL Fed uses something like the following to construct wage
  mutate(wage_new = case_when(
    # ensure ATL Fed top-code / allocated restrictions
    wageperhrtopcoded89 == 1 | wageperhrallocated89 == 1 ~ NA_real_,
    # paid hourly
    paidhrly82 == 1 ~ hourly_wage,
    # paid weekly
    paidhrly82 == 0 & hours82 != 0 ~ weekly_wage / hours82
  )) %>% 
  # censor data like ATL Fed does
  mutate(wage_new = if_else(wage_new > 100, 100, wage_new)) %>% 
  # drop obs in Atl Fed data that don't have a wage
  filter(!is.na(wage_old)) %>% 
  # drop small number (< 0.1%) of obs with no reconstructed wage
  filter(!is.na(wage_new)) %>% 
  # verify new reconstructed wage is essentially same as Atl Fed wage
  verify(abs(wage_new - wage_old) < 0.0001) %>% 
  # now that we know how ATL Fed creates wage, now let us create binned wages
  # following Census plan: 
  # https://www.census.gov/content/dam/Census/programs-surveys/cps/updated-2022-cps-puf-changes.pdf
  # create binned hourly wage for hourly workers
  bin_hourly(new = hourly_wage_binned, old = hourly_wage) %>% 
  # create binned weekly earnings for non-hourly workers
  bin_weekly(new = weekly_wage_binned, old = weekly_wage) %>% 
  # create final wage for all workers
  mutate(wage_binned = case_when(
    # ensure ATL Fed top-code / allocation restrictions
    wageperhrtopcoded89 == 1 | wageperhrallocated89 == 1 ~ NA_real_,
    # hourly-workers 
    paidhrly82 == 1 ~ hourly_wage_binned,
    # non-hourly workers
    paidhrly82 == 0 & hours82 != 0 ~ weekly_wage_binned / hours82
  )) %>% 
  # censor data like ATL Fed does
  mutate(wage_binned = if_else(wage_binned > 100, 100, wage_binned)) %>% 
  # create within person wage growth in logs
  arrange(personid, date) %>% 
  group_by(personid) %>% 
  mutate(
    wgt_old = (log(wage_old) - lag(log(wage_old))) * 100,
    wgt_binned = (log(wage_binned) - lag(log(wage_binned))) * 100
  ) %>% 
  ungroup() 

# create wgt variable in microdata
wgt_data_cleaned <- wgt_data_prepped %>% 
  # only look at 1997+
  filter(date >= ymd("1997-01-01")) %>% 
  # enforce ATL wage tracker restrictions, for replication
  filter(!is.na(wgt_original)) %>% 
  # about 0.2% of the sample doesn't have wgt_old but has wgt_original
  # going to drop those obs: doesn't seem to have a sizable effect on replication
  filter(!is.na(wgt_old)) %>% 
  # very small number of wgt_binned missing because in (only) one period their wages 
  # sufficiently low to be censored by binning procedure
  filter(!is.na(wgt_binned))

# some more microdata checks 
wgt_data_cleaned %>% 
  # check that we are using the appropriate wage variable construction
  # by verifying wgt_old and wgt_original are close to equal
  verify(abs(wgt_old - wgt_original) < 0.0001)

# aggregate and smooth data
wgt_data_aggregated <- wgt_data_cleaned %>% 
  group_by(date) %>% 
  summarize(across(wgt_original|wgt_binned, list("median" = median))) %>%
  mutate(across(
    -date, 
    ~ slide_dbl(.x, mean, .before = 2, .complete = TRUE),
    .names = "{.col}_3ma"
  ))

# aggregate data check: compare with published WGT
# confirm replication only off by at most 0.1 percentage points
read_csv("wgt_published.csv") %>%
  inner_join(wgt_data_aggregated, by = "date") %>%
  mutate(wgt_replication = round(wgt_original_median_3ma, 1)) %>%
  verify(abs(wgt_replication - wgt_published_overall) < 0.11)

wgt_data_aggregated %>% 
  select(date, "Original data" = wgt_original_median_3ma, "Rounded data" = wgt_binned_median_3ma) %>%
  pivot_longer(-date) %>% 
  mutate(value = value / 100) %>% 
  mutate(name = ordered(name, levels = c("Rounded data", "Original data"))) %>% 
  ggplot(aes(x = date, y = value, group = name, color = name)) +
  geom_point(alpha = 0.9) +
  geom_line() +
  scale_y_continuous(
    limits = c(0, 0.07),
    labels = scales::label_percent(accuracy = 1.0)
  ) +
  scale_colour_hue(l = 50) +
  scale_x_date(
    date_labels = "%Y",
    breaks = seq(from = ymd("2000-01-01"), to = ymd("2020-01-01"), by = "4 years")
  ) +
  theme_ipsum() +
  theme(
    legend.title = element_blank(),
    axis.title.x = element_blank(),
    axis.title.y = element_blank()
  ) +
  labs(
    title = "Atlanta Fed Wage Tracker data with and without rounded wages",
    subtitle = "Median annual log wage change, three-month moving average"
  )

wgt_published.csv

wgt_rounded_unrounded.png