vignettes/ffv_snw_stimulus_bush_2008.Rmd
ffv_snw_stimulus_bush_2008.RmdIn 2008, the Bush administration sent out stimulus checks as tax rebates (Economic Stimulus Act of 2008). The checks are a function of income, marital status, and the number of children. We have functions that computable taxable income given income, tax liability given income, and also stimulus amount given income.
First, we test the taxable income function.
ar_income <- c(1e4, 2e4, 4e4, 8e4, 1.6e5)
ls_taxable <- ffp_snw_tax_liability(ar_income)
mn_taxable_income <- ls_taxable$mn_taxable_income
mn_tax_liability <- ls_taxable$mn_tax_liabilitySecond, show the taxable income schedule.
print('mn_taxable_income')## [1] "mn_taxable_income"
print(mn_taxable_income)## , , kids=0
##
## married=0 married=1
## income=10000 1050 -7900
## income=20000 11050 2100
## income=40000 31050 22100
## income=80000 71050 62100
## income=160000 151050 142100
##
## , , kids=1
##
## married=0 married=1
## income=10000 -5000 -11400
## income=20000 5000 -1400
## income=40000 25000 18600
## income=80000 65000 58600
## income=160000 145000 138600
##
## , , kids=2
##
## married=0 married=1
## income=10000 -8500 -14900
## income=20000 1500 -4900
## income=40000 21500 15100
## income=80000 61500 55100
## income=160000 141500 135100
##
## , , kids=3
##
## married=0 married=1
## income=10000 -12000 -18400
## income=20000 -2000 -8400
## income=40000 18000 11600
## income=80000 58000 51600
## income=160000 138000 131600
##
## , , kids=4
##
## married=0 married=1
## income=10000 -15500 -21900
## income=20000 -5500 -11900
## income=40000 14500 8100
## income=80000 54500 48100
## income=160000 134500 128100Third, show the tax liability schedule.
print('mn_tax_liability')## [1] "mn_tax_liability"
print(mn_tax_liability)## , , kids=0
##
## married=0 married=1
## income=10000 105.00 0.0
## income=20000 1256.25 210.0
## income=40000 4256.25 2512.5
## income=80000 14106.25 8512.5
## income=160000 36272.25 28532.0
##
## , , kids=1
##
## married=0 married=1
## income=10000 0.0 0.0
## income=20000 500.0 0.0
## income=40000 3177.5 1987.5
## income=80000 11312.5 7987.5
## income=160000 32283.0 27552.0
##
## , , kids=2
##
## married=0 married=1
## income=10000 0.0 0.0
## income=20000 150.0 0.0
## income=40000 2652.5 1510.0
## income=80000 10437.5 7462.5
## income=160000 31303.0 26572.0
##
## , , kids=3
##
## married=0 married=1
## income=10000 0.0 0.0
## income=20000 0.0 0.0
## income=40000 2127.5 1160.0
## income=80000 9562.5 6937.5
## income=160000 30323.0 25592.0
##
## , , kids=4
##
## married=0 married=1
## income=10000 0.0 0.0
## income=20000 0.0 0.0
## income=40000 1602.5 810.0
## income=80000 8687.5 6412.5
## income=160000 29343.0 24712.5Find taxable income, tax liability, and then finally stimulus checks (tax-rebates) amounts for households with 10k, 20k, 30k, 40k, 50k, 60k, 70k, 80k, 90k, 100k, and 160k income, and all kids and marital status combinations.
# Income array
ar_income <- c(1e4, 2e4, 3e4, 4e4, 5e4, 6e4, 7e4, 8e4, 9e4, 1.6e5)
# Store stimulus checks amounts
mn_stimulus_check <- array(NA, dim=c(length(ar_income), 2, 5))
# Solve and Store stimulus by kids count and marital status
for (it_kids in 0:4){
for (bl_marital in c(0,1)){
# Solve and Store
ar_stimulus_check <- ffp_snw_stimulus_checks_bush(ar_income, it_kids, bl_marital)
mn_stimulus_check[, bl_marital+1, it_kids+1] <- ar_stimulus_check
}
}
# Labeling
dimnames(mn_stimulus_check)[[1]] = paste0('income=', round(ar_income, 0))
dimnames(mn_stimulus_check)[[2]] = paste0('married=', 0:1)
dimnames(mn_stimulus_check)[[3]] = paste0('kids=', 0:4)
# Print
print('mn_stimulus_check')## [1] "mn_stimulus_check"
print(mn_stimulus_check)## , , kids=0
##
## married=0 married=1
## income=10000 300 600
## income=20000 600 600
## income=30000 600 1200
## income=40000 600 1200
## income=50000 600 1200
## income=60000 600 1200
## income=70000 600 1200
## income=80000 350 1200
## income=90000 0 1200
## income=160000 0 700
##
## , , kids=1
##
## married=0 married=1
## income=10000 600 900
## income=20000 800 900
## income=30000 900 1160
## income=40000 900 1500
## income=50000 900 1500
## income=60000 900 1500
## income=70000 900 1500
## income=80000 650 1500
## income=90000 150 1500
## income=160000 0 1000
##
## , , kids=2
##
## married=0 married=1
## income=10000 900 1200
## income=20000 900 1200
## income=30000 1200 1200
## income=40000 1200 1800
## income=50000 1200 1800
## income=60000 1200 1800
## income=70000 1200 1800
## income=80000 950 1800
## income=90000 450 1800
## income=160000 0 1300
##
## , , kids=3
##
## married=0 married=1
## income=10000 1200 1500
## income=20000 1200 1500
## income=30000 1500 1500
## income=40000 1500 2060
## income=50000 1500 2100
## income=60000 1500 2100
## income=70000 1500 2100
## income=80000 1250 2100
## income=90000 750 2100
## income=160000 0 1600
##
## , , kids=4
##
## married=0 married=1
## income=10000 1500 1800
## income=20000 1500 1800
## income=30000 1650 1800
## income=40000 1800 2010
## income=50000 1800 2400
## income=60000 1800 2400
## income=70000 1800 2400
## income=80000 1550 2400
## income=90000 1050 2400
## income=160000 0 1900We have a dataframe of households, where each household is defined by the number of kids in the household, marital status, and also income bin. Note that this is an income bin, not a specific income level. We computes an approximate income-bin (and marital status and kids count) specific stimulus amount by evaluating the stimulus checks function along a fine grid of income levels from the min to the max point of the income-bin, and simply take the average.
We do this first for the actual stimulus that households should receive under the Economic Stimulus Act of 2008. We then adjust parameters for the stimulus function and compute alternative max-stimulus bounds for each income bin.
We develop the function by testing out the code line by line first.
First, load in the testing dataframe df_nsw_tiny_chk168_df_id.
# Load file
data(df_nsw_tiny_chk168_df_id)
df_id <- df_nsw_tiny_chk168_df_id
# Print results
print(df_id)## # A tibble: 111 x 7
## id_i marital kids age_group ymin_group mass hhsize
## <dbl> <int> <int> <fct> <fct> <dbl> <dbl>
## 1 1 0 0 (17,64] (0,0.363] 0.0317 1
## 2 2 0 0 (17,64] (0.363,0.544] 0.0606 1
## 3 3 0 0 (17,64] (0.544,0.725] 0.0994 1
## 4 4 0 0 (17,64] (0.725,0.907] 0.0437 1
## 5 5 0 0 (17,64] (0.907,1.09] 0.0508 1
## 6 6 0 0 (17,64] (1.09,1.27] 0.0218 1
## 7 7 0 0 (17,64] (1.27,1.45] 0.0191 1
## 8 8 0 0 (17,64] (1.45,1.63] 0.0307 1
## 9 9 0 0 (17,64] (1.63,1.81] 0.000942 1
## 10 10 0 0 (17,64] (1.81,1.99] 0.0119 1
## # ... with 101 more rowsSecond, parse the ymin_group group.
# what 1 in model equals to
fl_multiple <- 58056
# Define input variables
svr_ymin_group <- 'ymin_group'
# Parse the ymin group
df_id <- df_id %>%
rowwise() %>%
mutate(!!sym(svr_ymin_group) := as.character(!!sym(svr_ymin_group))) %>%
mutate(y_group_min = substring(strsplit(!!sym(svr_ymin_group), ",")[[1]][1], 2),
y_group_max = gsub(strsplit(!!sym(svr_ymin_group), ",")[[1]][2], pattern = "]", replacement = "")) %>%
mutate(y_group_min = fl_multiple*as.numeric(y_group_min),
y_group_max = fl_multiple*as.numeric(y_group_max)) %>%
ungroup()
# Print results
print(df_id[1:10,])## # A tibble: 10 x 9
## id_i marital kids age_group ymin_group mass hhsize y_group_min
## <dbl> <int> <int> <fct> <chr> <dbl> <dbl> <dbl>
## 1 1 0 0 (17,64] (0,0.363] 0.0317 1 0
## 2 2 0 0 (17,64] (0.363,0.544] 0.0606 1 21074.
## 3 3 0 0 (17,64] (0.544,0.725] 0.0994 1 31582.
## 4 4 0 0 (17,64] (0.725,0.907] 0.0437 1 42091.
## 5 5 0 0 (17,64] (0.907,1.09] 0.0508 1 52657.
## 6 6 0 0 (17,64] (1.09,1.27] 0.0218 1 63281.
## 7 7 0 0 (17,64] (1.27,1.45] 0.0191 1 73731.
## 8 8 0 0 (17,64] (1.45,1.63] 0.0307 1 84181.
## 9 9 0 0 (17,64] (1.63,1.81] 0.000942 1 94631.
## 10 10 0 0 (17,64] (1.81,1.99] 0.0119 1 105081.
## # ... with 1 more variable: y_group_max <dbl>Third, generate an income array with y_group_min and y_group_max, and call the stimulus function to solve for stimulus along the income array, and then take average. Set various parameters
# Dollar per Check
fl_percheck_dollar <- 100
# Define input variables
svr_id <- 'id_i'
svr_marital <- 'marital'
svr_kids <- 'kids'
# Define other parameters
fl_stimulus_child <- 300
fl_stimulus_adult_min <- 300
fl_stimulus_adult_max <- 600
fl_per_adult_phase_out <- 75000
fl_phase_out_per_dollar_income <- 0.05
# fl_stimulus_child <- ls_stimulus_specs$fl_stimulus_child
# fl_stimulus_adult_min <- ls_stimulus_specs$fl_stimulus_adult_min
# fl_stimulus_adult_max <- ls_stimulus_specs$fl_stimulus_adult_max
# fl_per_adult_phase_out <- ls_stimulus_specs$fl_per_adult_phase_out
# fl_phase_out_per_dollar_income <- ls_stimulus_specs$fl_phase_out_per_dollar_income
# Compute stimulus, averaging over array of income-specific stimulus
df_id <- df_id %>%
group_by(!!sym(svr_id)) %>%
do(bush_rebate =
mean(ffp_snw_stimulus_checks_bush(
ar_income = seq(.[['y_group_min']],
.[['y_group_max']],
length.out=100),
it_kids = .[[svr_kids]],
bl_marital = .[[svr_marital]],
fl_stimulus_child=fl_stimulus_child,
fl_stimulus_adult_min=fl_stimulus_adult_min,
fl_stimulus_adult_max=fl_stimulus_adult_max,
fl_per_adult_phase_out=fl_per_adult_phase_out,
fl_phase_out_per_dollar_income=fl_phase_out_per_dollar_income
))) %>%
unnest(c(bush_rebate)) %>%
mutate(bush_rebate_n_checks = round(bush_rebate/fl_percheck_dollar)) %>%
left_join(df_id, by=svr_id)
# Display results
print(df_id)## # A tibble: 111 x 11
## id_i bush_rebate bush_rebate_n_c~ marital kids age_group ymin_group mass
## <dbl> <dbl> <dbl> <int> <int> <fct> <chr> <dbl>
## 1 1 409. 4 0 0 (17,64] (0,0.363] 3.17e-2
## 2 2 600 6 0 0 (17,64] (0.363,0.~ 6.06e-2
## 3 3 600 6 0 0 (17,64] (0.544,0.~ 9.94e-2
## 4 4 600 6 0 0 (17,64] (0.725,0.~ 4.37e-2
## 5 5 600 6 0 0 (17,64] (0.907,1.~ 5.08e-2
## 6 6 600 6 0 0 (17,64] (1.09,1.2~ 2.18e-2
## 7 7 398. 4 0 0 (17,64] (1.27,1.4~ 1.91e-2
## 8 8 19.5 0 0 0 (17,64] (1.45,1.6~ 3.07e-2
## 9 9 0 0 0 0 (17,64] (1.63,1.8~ 9.42e-4
## 10 10 0 0 0 0 (17,64] (1.81,1.9~ 1.19e-2
## # ... with 101 more rows, and 3 more variables: hhsize <dbl>,
## # y_group_min <dbl>, y_group_max <dbl>Now we test the function ffp_snw_stimulus_checks_bush_add2dfid().
First, we add in the actual policy bounds:
# Call and solve
df_id <- df_nsw_tiny_chk168_df_id
df_id_checkadded_actual <- ffp_snw_stimulus_checks_bush_add2dfid(
df_id,
it_income_n_in_seg = 100,
fl_multiple = 58056,
fl_percheck_dollar = 100,
fl_stimulus_child=300,
fl_stimulus_adult_min=300, fl_stimulus_adult_max=600,
fl_per_adult_phase_out=75000,
fl_phase_out_per_dollar_income=0.05)
# Display
print(df_id_checkadded_actual[1:10,])## # A tibble: 10 x 11
## id_i bush_rebate bush_rebate_n_c~ marital kids age_group ymin_group mass
## <dbl> <dbl> <dbl> <int> <int> <fct> <chr> <dbl>
## 1 1 409. 4 0 0 (17,64] (0,0.363] 3.17e-2
## 2 2 600 6 0 0 (17,64] (0.363,0.~ 6.06e-2
## 3 3 600 6 0 0 (17,64] (0.544,0.~ 9.94e-2
## 4 4 600 6 0 0 (17,64] (0.725,0.~ 4.37e-2
## 5 5 600 6 0 0 (17,64] (0.907,1.~ 5.08e-2
## 6 6 600 6 0 0 (17,64] (1.09,1.2~ 2.18e-2
## 7 7 398. 4 0 0 (17,64] (1.27,1.4~ 1.91e-2
## 8 8 19.5 0 0 0 (17,64] (1.45,1.6~ 3.07e-2
## 9 9 0 0 0 0 (17,64] (1.63,1.8~ 9.42e-4
## 10 10 0 0 0 0 (17,64] (1.81,1.9~ 1.19e-2
## # ... with 3 more variables: hhsize <dbl>, y_group_min <dbl>, y_group_max <dbl>
# Summarize
vars.group <- c('kids', 'marital')
var.numeric <- 'bush_rebate'
str.stats.group <- 'allperc'
ar.perc <- c(0.01, 0.05, 0.10, 0.20, 0.30, 0.40, 0.50, 0.70, 0.90)
ls_summ_by_group <- ff_summ_bygroup(df_id_checkadded_actual,
vars.group, var.numeric, str.stats.group, ar.perc)## Warning: `funs()` was deprecated in dplyr 0.8.0.
## Please use a list of either functions or lambdas:
##
## # Simple named list:
## list(mean = mean, median = median)
##
## # Auto named with `tibble::lst()`:
## tibble::lst(mean, median)
##
## # Using lambdas
## list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was generated.## Warning: attributes are not identical across measure variables;
## they will be dropped
df_table_grp_stats <- ls_summ_by_group$df_table_grp_stats
print(round(df_table_grp_stats,0) %>%
select(vars.group, one_of(
'mean', '1%', '5%', '10%', '20%', '30%', '50%', '90%')))## Note: Using an external vector in selections is ambiguous.
## i Use `all_of(vars.group)` instead of `vars.group` to silence this message.
## i See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
## This message is displayed once per session.## # A tibble: 6 x 10
## # Groups: kids [3]
## kids marital mean `1%` `5%` `10%` `20%` `30%` `50%` `90%`
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0 0 213 0 0 0 0 0 0 600
## 2 0 1 860 0 0 0 357 707 1200 1200
## 3 1 0 334 0 0 0 0 0 0 900
## 4 1 1 1099 0 0 3 634 934 1500 1500
## 5 2 0 465 0 0 0 0 0 23 1200
## 6 2 1 1348 0 0 99 934 1201 1800 1800Second, we will triple the amount of stimulus received for adult and for kids, but keep the base amount the same, and set phase-out per_dollar income to 0. By doing this, we are no longer finding the stimulus under the actual policy, but generating upper allocation bounds based on tax-liability.
# Child stimulus triple
fl_stimulus_child=300*3
fl_stimulus_adult_max=600*3
fl_phase_out_per_dollar_income=0
# Call and solve
df_id <- df_nsw_tiny_chk168_df_id
df_id_checkadded_x3chd_x3adthgbd <- ffp_snw_stimulus_checks_bush_add2dfid(
df_id,
fl_multiple = 58056,
fl_percheck_dollar = 100,
fl_stimulus_child=fl_stimulus_child,
fl_stimulus_adult_min=300, fl_stimulus_adult_max=fl_stimulus_adult_max,
fl_phase_out_per_dollar_income=fl_phase_out_per_dollar_income)
# Display
print(df_id_checkadded_x3chd_x3adthgbd[1:10,])## # A tibble: 10 x 11
## id_i bush_rebate bush_rebate_n_c~ marital kids age_group ymin_group mass
## <dbl> <dbl> <dbl> <int> <int> <fct> <chr> <dbl>
## 1 1 521. 5 0 0 (17,64] (0,0.363] 3.17e-2
## 2 2 1752. 18 0 0 (17,64] (0.363,0.~ 6.06e-2
## 3 3 1800 18 0 0 (17,64] (0.544,0.~ 9.94e-2
## 4 4 1800 18 0 0 (17,64] (0.725,0.~ 4.37e-2
## 5 5 1800 18 0 0 (17,64] (0.907,1.~ 5.08e-2
## 6 6 1800 18 0 0 (17,64] (1.09,1.2~ 2.18e-2
## 7 7 1800 18 0 0 (17,64] (1.27,1.4~ 1.91e-2
## 8 8 1800 18 0 0 (17,64] (1.45,1.6~ 3.07e-2
## 9 9 1800 18 0 0 (17,64] (1.63,1.8~ 9.42e-4
## 10 10 1800 18 0 0 (17,64] (1.81,1.9~ 1.19e-2
## # ... with 3 more variables: hhsize <dbl>, y_group_min <dbl>, y_group_max <dbl>
# Summarize
ls_summ_by_group <- ff_summ_bygroup(df_id_checkadded_x3chd_x3adthgbd,
vars.group, var.numeric, str.stats.group, ar.perc)## Warning: attributes are not identical across measure variables;
## they will be dropped
df_table_grp_stats <- ls_summ_by_group$df_table_grp_stats
print(round(df_table_grp_stats,0) %>%
select(vars.group, one_of(
'mean', '1%', '5%', '10%', '20%', '30%', '50%', '90%')))## # A tibble: 6 x 10
## # Groups: kids [3]
## kids marital mean `1%` `5%` `10%` `20%` `30%` `50%` `90%`
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0 0 1726 730 1567 1786 1800 1800 1800 1800
## 2 0 1 3208 651 854 1818 3524 3600 3600 3600
## 3 1 0 2584 1371 1961 2517 2700 2700 2700 2700
## 4 1 1 4055 1515 1576 2313 4287 4500 4500 4500
## 5 2 0 3458 2183 2517 3259 3600 3600 3600 3600
## 6 2 1 4903 2400 2402 2878 4976 5400 5400 5400Third, we will triple the amount of stimulus received for adult and for kids, and also triple the base amount (upper-bound) for lowest income group, and set phase-out per_dollar income to 0.
# Child stimulus triple
fl_stimulus_child=300*3
fl_stimulus_adult_max=600*3
fl_stimulus_adult_min=300*3
fl_phase_out_per_dollar_income=0
# Call and solve
df_id <- df_nsw_tiny_chk168_df_id
df_id_checkadded_x3chd_x3adthgbdlwbd <- ffp_snw_stimulus_checks_bush_add2dfid(
df_id,
fl_multiple = 58056,
fl_percheck_dollar = 100,
fl_stimulus_child=fl_stimulus_child,
fl_stimulus_adult_min=fl_stimulus_adult_min, fl_stimulus_adult_max=fl_stimulus_adult_max,
fl_phase_out_per_dollar_income=fl_phase_out_per_dollar_income)
# Display
print(df_id_checkadded_x3chd_x3adthgbdlwbd[1:10,])## # A tibble: 10 x 11
## id_i bush_rebate bush_rebate_n_c~ marital kids age_group ymin_group mass
## <dbl> <dbl> <dbl> <int> <int> <fct> <chr> <dbl>
## 1 1 945. 9 0 0 (17,64] (0,0.363] 3.17e-2
## 2 2 1752. 18 0 0 (17,64] (0.363,0.~ 6.06e-2
## 3 3 1800 18 0 0 (17,64] (0.544,0.~ 9.94e-2
## 4 4 1800 18 0 0 (17,64] (0.725,0.~ 4.37e-2
## 5 5 1800 18 0 0 (17,64] (0.907,1.~ 5.08e-2
## 6 6 1800 18 0 0 (17,64] (1.09,1.2~ 2.18e-2
## 7 7 1800 18 0 0 (17,64] (1.27,1.4~ 1.91e-2
## 8 8 1800 18 0 0 (17,64] (1.45,1.6~ 3.07e-2
## 9 9 1800 18 0 0 (17,64] (1.63,1.8~ 9.42e-4
## 10 10 1800 18 0 0 (17,64] (1.81,1.9~ 1.19e-2
## # ... with 3 more variables: hhsize <dbl>, y_group_min <dbl>, y_group_max <dbl>
# Summarize
ls_summ_by_group <- ff_summ_bygroup(df_id_checkadded_x3chd_x3adthgbdlwbd,
vars.group, var.numeric, str.stats.group, ar.perc)## Warning: attributes are not identical across measure variables;
## they will be dropped
df_table_grp_stats <- ls_summ_by_group$df_table_grp_stats
print(round(df_table_grp_stats,0) %>%
select(vars.group, one_of(
'mean', '1%', '5%', '10%', '20%', '30%', '50%', '90%')))## # A tibble: 6 x 10
## # Groups: kids [3]
## kids marital mean `1%` `5%` `10%` `20%` `30%` `50%` `90%`
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0 0 1750 1082 1631 1786 1800 1800 1800 1800
## 2 0 1 3323 1800 1800 2069 3524 3600 3600 3600
## 3 1 0 2619 1857 2083 2530 2700 2700 2700 2700
## 4 1 1 4192 2700 2700 2765 4287 4500 4500 4500
## 5 2 0 3502 2715 2774 3318 3600 3600 3600 3600
## 6 2 1 5061 3600 3600 3600 4976 5400 5400 5400