-
Notifications
You must be signed in to change notification settings - Fork 1
/
ffp_opt_solin.R
154 lines (140 loc) · 6.5 KB
/
ffp_opt_solin.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
ffp_opt_solin_relow <- function(df, svr_A_i, svr_alpha_i, svr_beta_i, fl_N_agg,
fl_rho,
svr_inpalc = "optiallocate",
svr_expout = "optiexpoutcm") {
#' Theorem 1, Binary Optimal Allocation solution, for one planner inequality
#' preference (one rho value)
#'
#' @description This is the solution to the linear optimal allocation problem.
#' Relative allocations, summed splined, inversion. solin, solution linear.
#' relow, relative to the lowest allocation algoritm.
#'
#' @param df tibble data table including variables using svr names below each
#' row is potentially an individual who will receive alternative allocations
#' @param svr_A_i string name of the A_i variable, dot product of covariates and
#' coefficients
#' @param svr_alpha_i string name of the alpha_i variable, individual specific
#' marginal-effects
#' @param svr_beta_i string name of the beta_i variable, relative preference
#' weight for each child
#' @param fl_N_agg float total resource avaible for allocation, if not specific,
#' sum by svr_N_i
#' @param fl_rho float preference for equality for the planner
#' @param svr_inpalc string variable name for newly generated input optimal
#' allocation, single word no dash
#' @param svr_expout string variable name for newly generated expected outcome,
#' single word no dash
#' @return a dataframe that expands the df inputs with additional results.
#' @return a list with a dataframe and an array \itemize{ \item df_opti -
#' Dataframe with various statistcs related to optimal allocation, all
#' intermediary stats \item ar_opti_inpalc - Array where each element is an
#' optimal choice for each individual \item ar_opti_expout - Array where each
#' element is the expected outcome given optimal choices for each i }
#' @author Fan Wang, \url{http://fanwangecon.github.io}
#' @references
#' \url{https://fanwangecon.github.io/PrjOptiAlloc/reference/ffp_opt_solin_relow.html}
#' \url{https://fanwangecon.github.io/PrjOptiAlloc/articles/ffv_opt_solin_relow.html}
#' @export
#' @import dplyr tidyr stringr broom REconTools
#' @examples
#' data(df_opt_dtgch_cbem4)
#' df <- df_opt_dtgch_cbem4
#' svr_A_i <- 'A_lin'
#' svr_alpha_i <- 'alpha_lin'
#' svr_beta_i <- 'beta'
#' fl_N_agg <- 10000
#' fl_rho <- -30
#' ls_lin_solu <- ffp_opt_solin_relow(df, svr_A_i, svr_alpha_i, svr_beta_i, fl_N_agg, fl_rho)
#' df_opti <- ls_lin_solu$df_opti
#' ar_opti_inpalc <- ls_lin_solu$ar_opti_inpalc
#' ar_opti_expout <- ls_lin_solu$ar_opti_expout
#' summary(df_opti)
#' print(ar_opti_inpalc)
#' print(ar_opti_expout)
# A. select only relevant data ----
df_opti <- df %>% rename(A = !!sym(svr_A_i), alpha = !!sym(svr_alpha_i), beta = !!sym(svr_beta_i))
# B. Generate V4, Rank Index Value, rho specific ----
# df_opti <- df_opti %>% mutate(!!paste0('rv_', it_rho_ctr) := A/((alpha*beta))^(1/(1-fl_rho)))
df_opti <- df_opti %>% mutate(rank_val = A / ((alpha * beta))^(1 / (1 - fl_rho)))
# C. Generate Rank Index ----
df_opti <- df_opti %>%
arrange(rank_val) %>%
mutate(rank_idx = row_number())
# D. Populate lowest index alpha, beta, and A to all rows ----
df_opti <- df_opti %>%
mutate(lowest_rank_A = A[rank_idx == 1]) %>%
mutate(lowest_rank_alpha = alpha[rank_idx == 1]) %>%
mutate(lowest_rank_beta = beta[rank_idx == 1])
# E. relative slope and relative intercept with respect to lowest index ----
df_opti <- df_opti %>%
mutate(
rela_slope_to_lowest =
(((lowest_rank_alpha * lowest_rank_beta) / (alpha * beta))^(1 / (fl_rho - 1)) * (lowest_rank_alpha / alpha))
) %>%
mutate(
rela_intercept_to_lowest =
((((lowest_rank_alpha * lowest_rank_beta) / (alpha * beta))^(1 / (fl_rho - 1)) * (lowest_rank_A / alpha)) - (A / alpha))
)
# F. cumulative sums ----
df_opti <- df_opti %>%
mutate(
rela_slope_to_lowest_cumsum =
cumsum(rela_slope_to_lowest)
) %>%
mutate(
rela_intercept_to_lowest_cumsum =
cumsum(rela_intercept_to_lowest)
)
# G. inverting cumulative slopes and intercepts ----
df_opti <- df_opti %>%
mutate(
rela_slope_to_lowest_cumsum_invert =
(1 / rela_slope_to_lowest_cumsum)
) %>%
mutate(
rela_intercept_to_lowest_cumsum_invert =
((-1) * (rela_intercept_to_lowest_cumsum) / (rela_slope_to_lowest_cumsum))
)
# H. Relative x-intercept points ----
df_opti <- df_opti %>%
mutate(
rela_x_intercept =
(-1) * (rela_intercept_to_lowest / rela_slope_to_lowest)
)
# I. Inverted relative x-intercepts ----
df_opti <- df_opti %>%
mutate(
opti_lowest_spline_knots =
(rela_intercept_to_lowest_cumsum + rela_slope_to_lowest_cumsum * rela_x_intercept)
)
# J. Sort by order of receiving transfers/subsidies ----
df_opti <- df_opti %>% arrange(rela_x_intercept)
# K. Find position of subsidy ----
df_opti <- df_opti %>%
arrange(opti_lowest_spline_knots) %>%
mutate(tot_devi = opti_lowest_spline_knots - fl_N_agg) %>%
arrange((-1) * case_when(tot_devi < 0 ~ tot_devi)) %>%
mutate(
allocate_lowest =
case_when(row_number() == 1 ~
rela_intercept_to_lowest_cumsum_invert +
rela_slope_to_lowest_cumsum_invert * fl_N_agg)
) %>%
mutate(allocate_lowest = allocate_lowest[row_number() == 1]) %>%
mutate(!!sym(svr_inpalc) :=
rela_intercept_to_lowest +
rela_slope_to_lowest * allocate_lowest) %>%
mutate(!!sym(svr_inpalc) :=
case_when(!!sym(svr_inpalc) >= 0 ~ !!sym(svr_inpalc), TRUE ~ 0)) %>%
mutate(allocate_total = sum(!!sym(svr_inpalc), na.rm = TRUE))
# L. Predictes Expected choice: A + alpha*opti_allocate ----
df_opti <- df_opti %>% mutate(!!sym(svr_expout) := A + alpha * !!sym(svr_inpalc))
# M. Drop some variables that I do not want to keep even in full df to export ----
# inpalc = input allocation optimal
# expout = expected outcome given input allocation
df_opti <- df_opti %>% select(-one_of(c("lowest_rank_alpha", "lowest_rank_beta")))
ar_opti_inpalc <- df_opti %>% pull(!!sym(svr_inpalc))
ar_opti_expout <- df_opti %>% pull(!!sym(svr_expout))
# Returns ----
return(list(df_opti = df_opti, ar_opti_inpalc = ar_opti_inpalc, ar_opti_expout = ar_opti_expout))
}