vignettes/ffv_opt_anlyz_rhgin.Rmd
ffv_opt_anlyz_rhgin.RmdGiven allocation space parameters (A, alpha), test lower-bounded continuous optimal allocation solution.Compare inequality measures given optimal allocations across planner preferences. This function tests out the procedure to solve for optimal allocations over various rhos, and computes gini each time.
library(dplyr)
library(tidyr)
library(REconTools)
library(PrjOptiAlloc)
bl_save_rda = FALSELoad data that is generated by regression ffy_opt_dtgch_cbem4 (vignette).
# Load Library
ls_opti_alpha_A <- PrjOptiAlloc::ffy_opt_dtgch_cbem4()## Warning: The `x` argument of `as_tibble.matrix()` must have unique column names if `.name_repair` is omitted as of tibble 2.0.0.
## Using compatibility `.name_repair`.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was generated.
df_raw <- ls_opti_alpha_A$df_raw
df_hw_cebu_m24 <- df_raw
df_esti <- ls_opti_alpha_A$df_esti
# Review dataframes
# raw file
head(df_raw, 10)## # A tibble: 10 x 17
## S.country vil.id indi.id sex svymthRound momEdu wealthIdx hgt wgt
## <chr> <dbl> <dbl> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Cebu 1 2 Female 24 7.1 7.3 79.2 10776.
## 2 Cebu 1 3 Female 24 9.4 10.3 76.7 10296.
## 3 Cebu 1 4 Female 24 13.9 13.3 78.1 7604.
## 4 Cebu 1 5 Male 24 11.3 9.3 84.1 11787.
## 5 Cebu 1 6 Female 24 7.3 7.3 76.9 7991.
## 6 Cebu 1 7 Male 24 10.4 8.3 79.6 12583.
## 7 Cebu 1 8 Female 24 13.5 9.3 81.5 8358.
## 8 Cebu 1 9 Female 24 10.4 17.3 74.7 8195.
## 9 Cebu 1 10 Male 24 10.5 6.3 77.1 9442.
## 10 Cebu 1 11 Male 24 1.9 6.3 72.1 6627.
## # ... with 8 more variables: hgt0 <dbl>, wgt0 <dbl>, prot <dbl>, cal <dbl>,
## # p.A.prot <dbl>, p.A.nProt <dbl>, momEduRound <fct>, hgt0med <fct>
head(df_esti, 10)## # A tibble: 10 x 9
## S.country vil.id indi.id svymthRound alpha_lin alpha_log A_lin A_log beta
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Cebu 1 2 24 0.0101 0.00669 78.4 4.34 0.000959
## 2 Cebu 1 3 24 0.0323 0.00925 79.9 4.36 0.000959
## 3 Cebu 1 4 24 0.0323 0.00925 78.9 4.35 0.000959
## 4 Cebu 1 5 24 0.0662 0.0139 80.6 4.37 0.000959
## 5 Cebu 1 6 24 0.0101 0.00669 77.8 4.34 0.000959
## 6 Cebu 1 7 24 0.0662 0.0139 79.6 4.36 0.000959
## 7 Cebu 1 8 24 0.0101 0.00669 77.8 4.34 0.000959
## 8 Cebu 1 9 24 0.0101 0.00669 78.0 4.34 0.000959
## 9 Cebu 1 10 24 0.0662 0.0139 80.0 4.36 0.000959
## 10 Cebu 1 11 24 0.0602 0.0121 77.7 4.33 0.000959## The following objects are masked from df_hw:
##
## cal, hgt, hgt0, hgt0med, indi.id, momEdu, momEduRound, p.A.nProt,
## p.A.prot, prot, S.country, sex, svymthRound, vil.id, wealthIdx,
## wgt, wgt0I would like to be able to directly call the dataset generated here in various functions. Save the datafile we just created in the project folder.
df <- df_opt_dtgch_cbem4
svr_id_i <- 'indi.id'
svr_A_i <- 'A_lin'
svr_alpha_i <- 'alpha_lin'
svr_beta_i <- 'beta'
fl_N_agg <- 10000
ar_rho <- c(-50, -10, -0.1, 0.1, 0.5, 0.7)
svr_inpalc <- 'optiallocate'
svr_expout <- 'optiexpoutcm'
df_opti_alloc_all_rho <- df
it_indi_count <- dim(df)[1]
# A. First Loop over Planner Preference ----
# Generate Rank Order
for (it_rho_ctr in seq(1,length(ar_rho))) {
fl_rho = ar_rho[it_rho_ctr]
# B. Invoke optimal linear (crs) solution problem ----
# ar_opti is the array of optimal choices, it is in df_opti as well.
# use df_opti for merging, because that contains the individual keys.
# actually file here should contain unique keys, unique key ID as required input. should return?
# actually it is fine, the function here needs the key, not solin_flinr
ls_lin_solu <- PrjOptiAlloc::ffp_opt_solin_relow(
df, svr_A_i, svr_alpha_i, svr_beta_i, fl_N_agg, fl_rho,
svr_inpalc, svr_expout)
# C. Keep for df collection individual key + optimal allocation ----
# _on stands for optimal nutritional choices
# _eh stands for expected height
tb_opti_allocate_wth_key <- ls_lin_solu$df_opti %>% select(one_of(svr_id_i, svr_inpalc, svr_expout)) %>%
rename(!!paste0('rho_c', it_rho_ctr, '_', svr_inpalc) := !!sym(svr_inpalc),
!!paste0('rho_c', it_rho_ctr, '_', svr_expout) := !!sym(svr_expout))
# D. merge optimal allocaiton results from different planner preference ----
df_opti_alloc_all_rho <- df_opti_alloc_all_rho %>%
left_join(tb_opti_allocate_wth_key, by=svr_id_i)
}
# Print
head(df_opti_alloc_all_rho, 10)## # A tibble: 10 x 21
## S.country vil.id indi.id svymthRound alpha_lin alpha_log A_lin A_log beta
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Cebu 1 2 24 0.0101 0.00669 78.4 4.34 0.000959
## 2 Cebu 1 3 24 0.0323 0.00925 79.9 4.36 0.000959
## 3 Cebu 1 4 24 0.0323 0.00925 78.9 4.35 0.000959
## 4 Cebu 1 5 24 0.0662 0.0139 80.6 4.37 0.000959
## 5 Cebu 1 6 24 0.0101 0.00669 77.8 4.34 0.000959
## 6 Cebu 1 7 24 0.0662 0.0139 79.6 4.36 0.000959
## 7 Cebu 1 8 24 0.0101 0.00669 77.8 4.34 0.000959
## 8 Cebu 1 9 24 0.0101 0.00669 78.0 4.34 0.000959
## 9 Cebu 1 10 24 0.0662 0.0139 80.0 4.36 0.000959
## 10 Cebu 1 11 24 0.0602 0.0121 77.7 4.33 0.000959
## # ... with 12 more variables: rho_c1_optiallocate <dbl>,
## # rho_c1_optiexpoutcm <dbl>, rho_c2_optiallocate <dbl>,
## # rho_c2_optiexpoutcm <dbl>, rho_c3_optiallocate <dbl>,
## # rho_c3_optiexpoutcm <dbl>, rho_c4_optiallocate <dbl>,
## # rho_c4_optiexpoutcm <dbl>, rho_c5_optiallocate <dbl>,
## # rho_c5_optiexpoutcm <dbl>, rho_c6_optiallocate <dbl>,
## # rho_c6_optiexpoutcm <dbl>
head(df_opti_alloc_all_rho %>% select(starts_with('rho')), 20)## # A tibble: 20 x 12
## rho_c1_optiallocate rho_c1_optiexpoutcm rho_c2_optiallocate rho_c2_optiexpou~
## <dbl> <dbl> <dbl> <dbl>
## 1 0 78.4 0 78.4
## 2 0 79.9 0 79.9
## 3 0 78.9 0 78.9
## 4 0 80.6 0 80.6
## 5 0 77.8 0 77.8
## 6 0 79.6 7.17 80.0
## 7 0 77.8 0 77.8
## 8 0 78.0 0 78.0
## 9 0 80.0 1.17 80.0
## 10 25.8 79.3 27.0 79.4
## 11 26.6 79.3 27.7 79.4
## 12 0 78.9 0 78.9
## 13 8.82 79.3 10.0 79.4
## 14 0 81.1 0 81.1
## 15 0 78.8 0 78.8
## 16 0 77.1 0 77.1
## 17 0 78.3 0 78.3
## 18 0 79.1 0 79.1
## 19 0 78.7 0 78.7
## 20 0 79.1 0 79.1
## # ... with 8 more variables: rho_c3_optiallocate <dbl>,
## # rho_c3_optiexpoutcm <dbl>, rho_c4_optiallocate <dbl>,
## # rho_c4_optiexpoutcm <dbl>, rho_c5_optiallocate <dbl>,
## # rho_c5_optiexpoutcm <dbl>, rho_c6_optiallocate <dbl>,
## # rho_c6_optiexpoutcm <dbl>
# E. Extract from All results Optimal Allocation and Expected Outcomes ----
mt_opti_alloc_all_rho <- data.matrix(df_opti_alloc_all_rho %>% select(ends_with(svr_inpalc)))
mt_expc_outcm_all_rho <- data.matrix(df_opti_alloc_all_rho %>% select(ends_with(svr_expout)))
# Print
summary(mt_opti_alloc_all_rho)## rho_c1_optiallocate rho_c2_optiallocate rho_c3_optiallocate
## Min. : 0.000 Min. : 0.000 Min. : 0.000
## 1st Qu.: 0.000 1st Qu.: 0.000 1st Qu.: 0.000
## Median : 0.000 Median : 0.000 Median : 0.000
## Mean : 9.588 Mean : 9.588 Mean : 9.588
## 3rd Qu.: 15.122 3rd Qu.:17.191 3rd Qu.: 0.000
## Max. :216.490 Max. :94.000 Max. :63.897
## rho_c4_optiallocate rho_c5_optiallocate rho_c6_optiallocate
## Min. : 0.000 Min. : 0.000 Min. : 0.000
## 1st Qu.: 0.000 1st Qu.: 0.000 1st Qu.: 0.000
## Median : 0.000 Median : 0.000 Median : 0.000
## Mean : 9.588 Mean : 9.588 Mean : 9.588
## 3rd Qu.: 0.000 3rd Qu.: 0.000 3rd Qu.: 0.000
## Max. :64.217 Max. :64.252 Max. :64.252
summary(mt_expc_outcm_all_rho)## rho_c1_optiexpoutcm rho_c2_optiexpoutcm rho_c3_optiexpoutcm
## Min. :76.56 Min. :74.37 Min. :74.37
## 1st Qu.:78.35 1st Qu.:78.35 1st Qu.:77.73
## Median :79.28 Median :79.35 Median :78.46
## Mean :78.96 Mean :79.05 Mean :79.10
## 3rd Qu.:79.43 3rd Qu.:79.87 3rd Qu.:79.87
## Max. :84.61 Max. :84.61 Max. :84.61
## rho_c4_optiexpoutcm rho_c5_optiexpoutcm rho_c6_optiexpoutcm
## Min. :74.19 Min. :73.70 Min. :73.70
## 1st Qu.:77.73 1st Qu.:77.73 1st Qu.:77.73
## Median :78.46 Median :78.46 Median :78.46
## Mean :79.10 Mean :79.10 Mean :79.10
## 3rd Qu.:79.87 3rd Qu.:79.87 3rd Qu.:79.87
## Max. :84.61 Max. :84.61 Max. :84.61
# F. Compute gini for each rho ----
# ff_dist_gini_vector_pos() is from REconTools
ar_opti_alloc_gini <- suppressMessages(apply(t(mt_opti_alloc_all_rho), 1,
REconTools::ff_dist_gini_vector_pos))
ar_expc_outcm_gini <- suppressMessages(apply(t(mt_expc_outcm_all_rho), 1,
REconTools::ff_dist_gini_vector_pos))
# Print
print(ar_opti_alloc_gini)## rho_c1_optiallocate rho_c2_optiallocate rho_c3_optiallocate rho_c4_optiallocate
## 0.7496377 0.6902218 0.8089562 0.8105391
## rho_c5_optiallocate rho_c6_optiallocate
## 0.8107186 0.8107186
print(ar_expc_outcm_gini)## rho_c1_optiexpoutcm rho_c2_optiexpoutcm rho_c3_optiexpoutcm rho_c4_optiexpoutcm
## 0.006735065 0.007619387 0.013797035 0.013896702
## rho_c5_optiexpoutcm rho_c6_optiexpoutcm
## 0.013907624 0.013907624
# G. Wide to Long to Wide Gini ----
# column names look like: rho_c1_on rho_c2_on rho_c3_on rho_c1_eh rho_c2_eh rho_c3_eh
tb_gini_onerow_wide <- cbind(as_tibble(t(ar_opti_alloc_gini)), as_tibble(t(ar_expc_outcm_gini)))
tb_gini_long <- tb_gini_onerow_wide %>%
pivot_longer(
cols = starts_with("rho"),
names_to = c("it_rho_ctr", "oneh"),
names_pattern = "rho_c(.*)_(.*)",
values_to = "gini"
)
tb_gini_wide2 <- tb_gini_long %>%
pivot_wider(
id_cols = it_rho_ctr,
names_from = oneh,
values_from = gini
)
planner_elas <- log(1/(1-ar_rho)+2)
mt_gini <- data.matrix(cbind(tb_gini_wide2, planner_elas))
# Print
print(tb_gini_onerow_wide)## rho_c1_optiallocate rho_c2_optiallocate rho_c3_optiallocate
## 1 0.7496377 0.6902218 0.8089562
## rho_c4_optiallocate rho_c5_optiallocate rho_c6_optiallocate
## 1 0.8105391 0.8107186 0.8107186
## rho_c1_optiexpoutcm rho_c2_optiexpoutcm rho_c3_optiexpoutcm
## 1 0.006735065 0.007619387 0.01379703
## rho_c4_optiexpoutcm rho_c5_optiexpoutcm rho_c6_optiexpoutcm
## 1 0.0138967 0.01390762 0.01390762
print(tb_gini_long)## # A tibble: 12 x 3
## it_rho_ctr oneh gini
## <chr> <chr> <dbl>
## 1 1 optiallocate 0.750
## 2 2 optiallocate 0.690
## 3 3 optiallocate 0.809
## 4 4 optiallocate 0.811
## 5 5 optiallocate 0.811
## 6 6 optiallocate 0.811
## 7 1 optiexpoutcm 0.00674
## 8 2 optiexpoutcm 0.00762
## 9 3 optiexpoutcm 0.0138
## 10 4 optiexpoutcm 0.0139
## 11 5 optiexpoutcm 0.0139
## 12 6 optiexpoutcm 0.0139
print(tb_gini_wide2)## # A tibble: 6 x 3
## it_rho_ctr optiallocate optiexpoutcm
## <chr> <dbl> <dbl>
## 1 1 0.750 0.00674
## 2 2 0.690 0.00762
## 3 3 0.809 0.0138
## 4 4 0.811 0.0139
## 5 5 0.811 0.0139
## 6 6 0.811 0.0139
print(mt_gini)## it_rho_ctr optiallocate optiexpoutcm planner_elas
## [1,] 1 0.7496377 0.006735065 0.7029034
## [2,] 2 0.6902218 0.007619387 0.7375989
## [3,] 3 0.8089562 0.013797035 1.0678406
## [4,] 4 0.8105391 0.013896702 1.1349799
## [5,] 5 0.8107186 0.013907624 1.3862944
## [6,] 6 0.8107186 0.013907624 1.6739764
# df_opt_dtgch_ropti: dataframe, opt project, data guat cebu height, cebu edu mother, results relative linear optimal
df_opt_dtgch_cbem4_rrlop_allrh <- df_opti_alloc_all_rho
df_opt_dtgch_cbem4_rrlop_argin <- mt_gini
if (bl_save_rda) {
usethis::use_data(df_opt_dtgch_cbem4_rrlop_allrh, df_opt_dtgch_cbem4_rrlop_allrh, overwrite = TRUE)
usethis::use_data(df_opt_dtgch_cbem4_rrlop_argin, df_opt_dtgch_cbem4_rrlop_argin, overwrite = TRUE)
}