1 Back to Outline

This section includes information on demographic diagnostics. You can go back to table of contents if you would like.

2 Demographics

2.1 Population Size

demogr <- list(
  prev.prop = list(name = "pop.size",
                  sec_title = "Population Size",
                  plot_name = "Population Size",
                  plot_cap = "Number of indviduals",
                  plot_ylab = "Number",
                  plt_type = "line",
                  vars = c("num."),
                  sum_fun = function(x) {x}
  )
)
ps <- sim_dat$epi$num.ovr[52 * (2019 - 1943), 1]
targ <- sim_dat$param$demog$pop.growth %>% filter(year >= 2019)
targ$value = ps * targ$s_perc
# print_many_plots(demogr[1], sim_dat, targ_df = cur_targs, num_hash = 2, 
#                  # "geom_line(data = targ, color = 'red')",
#                  sub_atrs = "ovr")

2.1.1 Overall

Note the target growth rate is only for the active population, thus we expect to be over the target (since the older population is not growing at as fast a rate).

meas_data <- make_epi_plot_data(sim_dat, demogr[[1]])
plot_epi(meas_data, brk_across = "ovr",
         targets = cur_targs)

2.1.2 Broken down by Active Status

Currently, we are choosing to enforce a constant population size after 2019.

make_split_num_plot(sim_dat)

2.1.3 Race

plot_epi(meas_data, brk_across = "race", targets = cur_targs)

2.1.4 Region

plot_epi(meas_data, brk_across = "region", targets = cur_targs)

2.1.5 Age Group

plot_epi(meas_data, brk_across = "age.grp", targets = cur_targs)

2.1.6 SNAP 5

plot_epi(meas_data, brk_across = "snap5", targets = cur_targs)

2.2 Proportion of populaiton by attribute

demogr[[1]]$plot_name <- "Proportion in Population"
demogr[[1]]$plot_cap <- "Among all individuals"
demogr[[1]]$plot_ylab <- "Proportion"
meas_data <- make_epi_plot_data(sim_dat, demogr[[1]])
wide_df <- meas_data$epi_data %>% 
  pivot_wider(id_cols = c("year", "simno"), values_from = "value",
              names_from = "name") %>% 
  mutate(across(4:21, .fns = function(x) (x / pop.size.ovr))) %>%
  mutate(across(c(pop.size.1, pop.size.2, pop.size.3, 
                  pop.size.4, pop.size.5),
                .fns = function(x) (x / (
                  pop.size.1 + pop.size.2 + pop.size.3 + 
                  pop.size.4 + pop.size.5)))) 
long_df <- wide_df %>% pivot_longer(cols = -c(1:3), names_to = "name", 
                                 values_to = "value")  %>% 
  select(-pop.size.ovr) %>%
  left_join(meas_data$epi_data %>% select(name, year, sub_cat_name, cat_name),
            by = c("name", "year")) %>% mutate(meas = "pop.prop")
meas_data$epi_data <- long_df

2.2.1 Race

Targets here come from the ACS estimates of race in Washington state.

plot_epi(meas_data, year_range = c(1980, 2030),
         targets = cur_targs, brk_across = "race")

2.2.2 Region

plot_epi(meas_data, year_range = c(1980, 2030),
         targets = cur_targs, brk_across = "region")

2.2.3 Age group

plot_epi(meas_data, year_range = c(1980, 2030),
         targets = cur_targs, brk_across = "age.grp")

2.2.4 SNAP 5

plot_epi(meas_data, year_range = c(1980, 2030), brk_across = "snap5")

2.3 Change Rates

rolling_year_sum <- function(x, years = 1, avg = FALSE){
  val <- data.table::frollsum(fill(data.frame(x), "x")$x, years * 52)
  if (avg) {val <- val / (years * 52)}
  return(val)
}
sim_dat$epi$nNew.ovr <- sim_dat$epi$nNew
entry.inf <- list(
  inflow = list(name = "inflow",
                  sec_title = "Inflow (at each time step)",
                  plot_name = "Number Entering each week",
                  plot_cap = "",
                  plot_ylab = "Number Entering",
                  plt_type = "line",
                  vars = c("nNew."),
                  sum_fun = function(x) {rolling_year_sum(x, avg = TRUE)}
  )
)
print_many_plots(entry.inf, sim_dat)

2.3.1 Inflow (at each time step)

2.3.1.1 ovr

2.4 Race proportions of entering individuals

After the year we match our demographic targets, the simulation chooses the number of and race of entering individuals based on a new mechanism.

The population growth rate among individuals 65 and younger is chosen (we can have it grow as a percentage of the current 65 and under population size or remain flat).
Entering individuals are assigned race based on the data from the U.S. Census Bureau and data from Grey et al., 2016.

## TODO: Make this work with multiple simulations
agerace <- do.call(data.frame, sim_dat$attr[[1]][c("age", "race")])
post.race.targ <- sim_dat$param$demog$post.race.distr %>% 
  mutate("targ" = round(100 * prop, 2))
targ.demog.year <- sim_dat$param$match.demog.year
sim.end.year <- round(sim_dat$control$year.start + 
                        (sim_dat$control$nsteps - sim_dat$control$start) / 52)
num.years.post.targ <- sim.end.year - targ.demog.year
entr.aftr <- agerace %>% filter(round(age) <= 15 + num.years.post.targ)
obs.props <- entr.aftr %>% group_by(race) %>% 
  count(name = "Simulated Count") %>% ungroup() %>% 
  mutate(obs = round(100 * `Simulated Count` / sum(`Simulated Count`), 2))
disp.tab <- left_join(obs.props, post.race.targ, by = "race") %>% 
  select(-value, -prop) %>% mutate("Percent Difference" = obs - targ)
disp.tab$race <- recode(disp.tab$race, !!!attr_names$race)
gt::gt(disp.tab, rowname_col = "race") %>%
  gt::cols_label(obs = "Simulated Percent", targ = "Target Percent") %>%
  gt::tab_header(paste0(
    "Proportion of simulated individuals who entered after target year (", 
    targ.demog.year, ") who are of each race."))

Proportion of simulated individuals who entered after target year (2019) who are of each race.

	Simulated Count	Simulated Percent	Target Percent	Percent Difference
Black	328	7.85	8.50	-0.65
Hispanic	697	16.69	16.03	0.66
Other	3151	75.45	75.46	-0.01

2.5 Exit rates

The exit rates here are taken from the National Center for Health Statistics. More information can be found here.

make_exit_plot(sim_dat)

EpiModel Demographic Summary Diagnostics

Adam Elder

2021-06-14