In FanWangEcon/PrjOptiAlloc: The Optimal Allocation of Resources Among Heterogeneous Individuals

Line by line, calculate welfare distances, Resource Equivalent Variation (REV), for the Binary Allocation problem based on Theorem 1. Hand-input A and alpha values.

Load Dependencies

rm(list = ls(all.names = TRUE))
options(knitr.duplicate.label = 'allow')

library(dplyr)
library(tidyr)
library(tibble)

library(PrjOptiAlloc)

library(knitr)
library(kableExtra)

Implement Algorithm Line by Line

Generate Testing Rank Data

Generate data needed.

# 1. Generate A and alpha Testing Vectors, random list no meanings
ar_alpha <- c(0.1,1.5,2.5,4  ,9,1.2,3,2,8)
ar_A <-     c(0.5,1.5,3.5,6.5,1.9,3,4,6,4)
ar_beta <-  rep(0, length(ar_A)) + 1/length(ar_A)
mt_alpha_A <- cbind(ar_alpha, ar_A, ar_beta)
ar_st_varnames <- c('alpha', 'A', 'beta')
tb_alpha_A <- as_tibble(mt_alpha_A) %>% rename_all(~c(ar_st_varnames))
tb_alpha_A
ar_rho <- c(0.99)
for (it_rho_ctr in seq(1,length(ar_rho))) {
  fl_rho <- ar_rho[it_rho_ctr]

  ls_ranks <- ffp_opt_sobin_target_row(tb_alpha_A[1,], fl_rho, ar_A, ar_alpha, ar_beta)
  it_rank <- ls_ranks$it_rank
  ar_it_rank <- ls_ranks$ar_it_rank
  ar_fl_rank_val <- ls_ranks$ar_fl_rank_val

  cat('fl_rho:', fl_rho, 'it_rank:', it_rank, '\n')
  cat('ar_it_rank:', ar_it_rank, '\n')
  cat('ar_fl_rank_val:', ar_fl_rank_val, '\n')

}

Compute REV

Compute REV giving observable and ranking

# Use the just generated optimal ranking above
ar_it_obs <- c(0,1,0,1,0,0,1,1,0)
ar_opti_r <- ar_it_rank
mt_rev <- cbind(seq(1,length(ar_opti_r)), ar_it_obs, ar_opti_r, ar_A, ar_alpha, ar_beta)
ar_st_varnames <- c('id', 'observed', 'optimal', 'A', 'alpha', 'beta')
tb_onevar <- as_tibble(mt_rev) %>% rename_all(~c(ar_st_varnames)) %>%
                arrange(optimal)

it_w_res <- sum(ar_it_obs)
fl_rho <- ar_rho

# Generate util observed and util unobserved columns
tb_onevar <- tb_onevar %>% mutate(utility = beta*((A+alpha)^fl_rho - A^fl_rho)) %>%
                           mutate(util_ob = case_when(observed == 1 ~ utility,
                                                      TRUE ~ 0 )) %>%
                           mutate(util_notob = case_when(observed == 0 ~ utility,
                                                         TRUE ~ 0 ))

# Display
kable(tb_onevar) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))

Generate Util observed um and not observed Reverse Sum

# Generate directional cumulative sums
tb_onevar <- tb_onevar %>%
                arrange(-optimal) %>%
                mutate(util_ob_sum = cumsum(util_ob)) %>%
                arrange(optimal) %>%
                mutate(util_notob_sum = cumsum(util_notob)) %>%
                select(id, observed, optimal, alpha, A, beta,
                       utility,
                       util_ob, util_ob_sum,
                       util_notob, util_notob_sum)

# Display
kable(tb_onevar) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))

# Following Theorem 1, simply compare util_ob_sum vs util_notob_sum
tb_onevar <- tb_onevar %>%
      mutate(opti_better_obs =
               case_when(util_notob_sum/util_ob_sum > 1 ~ 1,
                         TRUE ~ 0)
             ) %>%
      select(id, observed, optimal,
             utility,
             util_ob, util_ob_sum,
             util_notob, util_notob_sum,
             opti_better_obs,
             alpha, A, beta)

# Display
kable(tb_onevar) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))

# Find the Rank number tha tmatches the First 1 in opti_better_obs
tb_onevar <- tb_onevar %>%
  mutate(opti_better_obs_cumu = cumsum(opti_better_obs)) %>%
  mutate(min_w_hat =
           case_when(opti_better_obs_cumu == 1 ~ optimal,
                     TRUE ~ 0)) %>%
      select(id, observed, optimal,
             utility,
             util_ob, util_ob_sum,
             util_notob, util_notob_sum,
             opti_better_obs,
             min_w_hat,
             alpha, A, beta)

# Display
  kable(tb_onevar) %>%
  kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"))

# Compute REV
it_min_w_hat <- max(tb_onevar %>% pull(min_w_hat))
it_w_hat_obs <- sum(ar_it_obs)
delta_rev <- 1-(it_min_w_hat/it_w_hat_obs)

cat('it_min_w_hat:', it_min_w_hat, '\n')
cat('it_w_hat_obs:', it_w_hat_obs, '\n')
cat('delta_rev:', delta_rev, '\n')

Function test

Test the function written based on the details above.

# ar_alpha <- c(0.1,1.5,2.5,4  ,9,1.2,3,2,8)
# ar_A <-     c(0.5,1.5,3.5,6.5,1.9,3,4,6,4)
# ar_beta <-  rep(0, length(ar_A)) + 1/length(ar_A)
# mt_alpha_A <- cbind(ar_alpha, ar_A, ar_beta)
# ar_st_varnames <- c('alpha', 'A', 'beta')
# tb_alpha_A <- as_tibble(mt_alpha_A) %>% rename_all(~c(ar_st_varnames))
# tb_alpha_A
# ar_rho <- c(-1)
for (it_rho_ctr in seq(1,length(ar_rho))) {
  fl_rho <- ar_rho[it_rho_ctr]

  ls_ranks <- ffp_opt_sobin_target_row(tb_alpha_A[1,], fl_rho, ar_A, ar_alpha, ar_beta)
  it_rank <- ls_ranks$it_rank
  ar_it_rank <- ls_ranks$ar_it_rank
  ar_fl_rank_val <- ls_ranks$ar_fl_rank_val

  cat('fl_rho:', fl_rho, 'it_rank:', it_rank, '\n')
  cat('ar_it_rank:', ar_it_rank, '\n')
  cat('ar_fl_rank_val:', ar_fl_rank_val, '\n')

}
ar_bin_observed <- ar_it_obs
ar_queue_optimal <- ar_it_rank
ffp_opt_sobin_rev(ar_queue_optimal, ar_bin_observed, ar_A, ar_alpha, ar_beta, fl_rho)

FanWangEcon/PrjOptiAlloc documentation built on Jan. 25, 2022, 6:55 a.m.