Go to the RMD, R, PDF, or HTML version of this file. Go back to fan’s REconTools Package, R Code Examples Repository (bookdown site), or Intro Stats with R Repository (bookdown site).
We want evaluate nonlinear function f(Q_i, y_i, ar_x, ar_y, c, d), where c and d are constants, and ar_x and ar_y are arrays, both fixed. x_i and y_i vary over each row of matrix. We would like to evaluate this nonlinear function concurrently across \(N\) individuals. The eventual goal is to find the \(i\) specific \(Q\) that solves the nonlinear equations.
This is a continuation of R use Apply, Sapply and dplyr Mutate to Evaluate one Function Across Rows of a Matrix
There is a function that takes \(M=Q+P\) inputs, we want to evaluate this function \(N\) times. Each time, there are \(M\) inputs, where all but \(Q\) of the \(M\) inputs, meaning \(P\) of the \(M\) inputs, are the same. In particular, \(P=Q*N\).
\[M = Q+P = Q + Q*N\]
# it_child_count = N, the number of children
it_N_child_cnt = 5
# it_heter_param = Q, number of parameters that are heterogeneous across children
it_Q_hetpa_cnt = 2
# P fixed parameters, nN is N dimensional, nP is P dimensional
ar_nN_A = seq(-2, 2, length.out = it_N_child_cnt)
ar_nN_alpha = seq(0.1, 0.9, length.out = it_N_child_cnt)
ar_nP_A_alpha = c(ar_nN_A, ar_nN_alpha)
ar_nN_N_choice = seq(1,it_N_child_cnt)/sum(seq(1,it_N_child_cnt))
# N by Q varying parameters
mt_nN_by_nQ_A_alpha = cbind(ar_nN_A, ar_nN_alpha, ar_nN_N_choice)
# Convert Matrix to Tibble
ar_st_col_names = c('fl_A', 'fl_alpha', 'fl_N')
tb_nN_by_nQ_A_alpha <- as_tibble(mt_nN_by_nQ_A_alpha) %>% rename_all(~c(ar_st_col_names))
# Show
kable(tb_nN_by_nQ_A_alpha) %>%
kable_styling_fc()| fl_A | fl_alpha | fl_N |
|---|---|---|
| -2 | 0.1 | 0.0666667 |
| -1 | 0.3 | 0.1333333 |
| 0 | 0.5 | 0.2000000 |
| 1 | 0.7 | 0.2666667 |
| 2 | 0.9 | 0.3333333 |
For this example, use a very simple function with only one type of input, all inputs are scalars.
# Define Implicit Function
ffi_nonlinear <- function(fl_A, fl_alpha){
fl_out <- (fl_A + fl_alpha*fl_A)/(fl_A)^2
return(fl_out)
}Apply the function over the dataframe, note five different ways below, the third way allows for parameters to be strings.
# variable names
svr_fl_A <- 'fl_A'
svr_fl_alpha <- 'fl_alpha'
# Evaluate
tb_nN_by_nQ_A_alpha_mutate_rows <- tb_nN_by_nQ_A_alpha %>%
mutate(fl_out_m1 = ffi_nonlinear(fl_A=.$fl_A, fl_alpha=.$fl_alpha),
fl_out_m2 = ffi_nonlinear(fl_A=`$`(., 'fl_A'), fl_alpha=`$`(., 'fl_alpha')),
fl_out_m3 = ffi_nonlinear(fl_A=.[[svr_fl_A]], fl_alpha=.[[svr_fl_alpha]]),
fl_out_m4 = ffi_nonlinear(fl_A=fl_A, fl_alpha=fl_alpha),
fl_out_m5 = ffi_nonlinear(fl_A, fl_alpha))
# print
kable(tb_nN_by_nQ_A_alpha_mutate_rows) %>% kable_styling_fc()| fl_A | fl_alpha | fl_N | fl_out_m1 | fl_out_m2 | fl_out_m3 | fl_out_m4 | fl_out_m5 |
|---|---|---|---|---|---|---|---|
| -2 | 0.1 | 0.0666667 | -0.55 | -0.55 | -0.55 | -0.55 | -0.55 |
| -1 | 0.3 | 0.1333333 | -1.30 | -1.30 | -1.30 | -1.30 | -1.30 |
| 0 | 0.5 | 0.2000000 | NaN | NaN | NaN | NaN | NaN |
| 1 | 0.7 | 0.2666667 | 1.70 | 1.70 | 1.70 | 1.70 | 1.70 |
| 2 | 0.9 | 0.3333333 | 0.95 | 0.95 | 0.95 | 0.95 | 0.95 |
Test non-linear Equation.
# Test Parameters
fl_N_agg = 100
fl_rho = -1
fl_N_q = ar_nN_N_choice[4]*fl_N_agg
ar_A_alpha = mt_nN_by_nQ_A_alpha[4,]
# Apply Function
ar_p1_s1 = exp((ar_A_alpha[1] - ar_nN_A)*fl_rho)
ar_p1_s2 = (ar_A_alpha[2]/ar_nN_alpha)
ar_p1_s3 = (1/(ar_nN_alpha*fl_rho - 1))
ar_p1 = (ar_p1_s1*ar_p1_s2)^ar_p1_s3
ar_p2 = fl_N_q^((ar_A_alpha[2]*fl_rho-1)/(ar_nN_alpha*fl_rho-1))
ar_overall = ar_p1*ar_p2
fl_overall = fl_N_agg - sum(ar_overall)
print(fl_overall)## [1] -598.2559Implement the non-linear problem’s evaluation using apply over all \(N\) individuals.
# Define Implicit Function
ffi_nonlin_dplyrdo <- function(fl_A, fl_alpha, fl_N, ar_A, ar_alpha, fl_N_agg, fl_rho){
# ar_A_alpha[1] is A
# ar_A_alpha[2] is alpha
# # Test Parameters
# fl_N = 100
# fl_rho = -1
# fl_N_q = 10
# Apply Function
ar_p1_s1 = exp((fl_A - ar_A)*fl_rho)
ar_p1_s2 = (fl_alpha/ar_alpha)
ar_p1_s3 = (1/(ar_alpha*fl_rho - 1))
ar_p1 = (ar_p1_s1*ar_p1_s2)^ar_p1_s3
ar_p2 = fl_N^((fl_alpha*fl_rho-1)/(ar_alpha*fl_rho-1))
ar_overall = ar_p1*ar_p2
fl_overall = fl_N_agg - sum(ar_overall)
return(fl_overall)
}
# Parameters
fl_rho = -1
# Evaluate Function
print(ffi_nonlin_dplyrdo(mt_nN_by_nQ_A_alpha[1,1],
mt_nN_by_nQ_A_alpha[1,2],
mt_nN_by_nQ_A_alpha[1,3]*fl_N_agg,
ar_nN_A, ar_nN_alpha, fl_N_agg, fl_rho))## [1] 81.86645for (i in seq(1,dim(mt_nN_by_nQ_A_alpha)[1])){
fl_eval = ffi_nonlin_dplyrdo(mt_nN_by_nQ_A_alpha[i,1],
mt_nN_by_nQ_A_alpha[i,2],
mt_nN_by_nQ_A_alpha[i,3]*fl_N_agg,
ar_nN_A, ar_nN_alpha, fl_N_agg, fl_rho)
print(fl_eval)
}## [1] 81.86645
## [1] 54.48885
## [1] -65.5619
## [1] -598.2559
## [1] -3154.072# Define Implicit Function
ffi_nonlin_dplyrdo <- function(fl_A, fl_alpha, fl_N, ar_A, ar_alpha, fl_N_agg, fl_rho){
# Test Parameters
# ar_A = ar_nN_A
# ar_alpha = ar_nN_alpha
# fl_N = 100
# fl_rho = -1
# fl_N_q = 10
# Apply Function
ar_p1_s1 = exp((fl_A - ar_A)*fl_rho)
ar_p1_s2 = (fl_alpha/ar_alpha)
ar_p1_s3 = (1/(ar_alpha*fl_rho - 1))
ar_p1 = (ar_p1_s1*ar_p1_s2)^ar_p1_s3
ar_p2 = (fl_N*fl_N_agg)^((fl_alpha*fl_rho-1)/(ar_alpha*fl_rho-1))
ar_overall = ar_p1*ar_p2
fl_overall = fl_N_agg - sum(ar_overall)
return(fl_overall)
}
# fl_A, fl_alpha are from columns of tb_nN_by_nQ_A_alpha
tb_nN_by_nQ_A_alpha = tb_nN_by_nQ_A_alpha %>% rowwise() %>%
mutate(dplyr_eval = ffi_nonlin_dplyrdo(fl_A, fl_alpha, fl_N,
ar_nN_A, ar_nN_alpha,
fl_N_agg, fl_rho))
# Show
kable(tb_nN_by_nQ_A_alpha) %>%
kable_styling_fc()| fl_A | fl_alpha | fl_N | dplyr_eval |
|---|---|---|---|
| -2 | 0.1 | 0.0666667 | 81.86645 |
| -1 | 0.3 | 0.1333333 | 54.48885 |
| 0 | 0.5 | 0.2000000 | -65.56190 |
| 1 | 0.7 | 0.2666667 | -598.25595 |
| 2 | 0.9 | 0.3333333 | -3154.07226 |