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).
Apply a function over rows of a matrix using mutate, rowwise, etc.
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)
# N by Q varying parameters
mt_nN_by_nQ_A_alpha = cbind(ar_nN_A, ar_nN_alpha)
# display
kable(mt_nN_by_nQ_A_alpha) %>%
kable_styling_fc()| ar_nN_A | ar_nN_alpha |
|---|---|
| -2 | 0.1 |
| -1 | 0.3 |
| 0 | 0.5 |
| 1 | 0.7 |
| 2 | 0.9 |
# Convert Matrix to Tibble
ar_st_col_names = c('fl_A', 'fl_alpha')
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 |
|---|---|
| -2 | 0.1 |
| -1 | 0.3 |
| 0 | 0.5 |
| 1 | 0.7 |
| 2 | 0.9 |
# Define Implicit Function
ffi_linear_dplyrdo <- function(fl_A, fl_alpha, ar_nN_A, ar_nN_alpha){
# ar_A_alpha[1] is A
# ar_A_alpha[2] is alpha
print(paste0('cur row, fl_A=', fl_A, ', fl_alpha=', fl_alpha))
fl_out = sum(fl_A*ar_nN_A + 1/(fl_alpha + 1/ar_nN_alpha))
return(fl_out)
}
# Evaluate function row by row of tibble
# fl_A, fl_alpha are from columns of tb_nN_by_nQ_A_alpha
tb_nN_by_nQ_A_alpha_show <- tb_nN_by_nQ_A_alpha %>%
rowwise() %>%
mutate(dplyr_eval =
ffi_linear_dplyrdo(fl_A, fl_alpha, ar_nN_A, ar_nN_alpha))## [1] "cur row, fl_A=-2, fl_alpha=0.1"
## [1] "cur row, fl_A=-1, fl_alpha=0.3"
## [1] "cur row, fl_A=0, fl_alpha=0.5"
## [1] "cur row, fl_A=1, fl_alpha=0.7"
## [1] "cur row, fl_A=2, fl_alpha=0.9"# Show
kable(tb_nN_by_nQ_A_alpha_show) %>%
kable_styling_fc()| fl_A | fl_alpha | dplyr_eval |
|---|---|---|
| -2 | 0.1 | 2.346356 |
| -1 | 0.3 | 2.094273 |
| 0 | 0.5 | 1.895316 |
| 1 | 0.7 | 1.733708 |
| 2 | 0.9 | 1.599477 |
same as before, still rowwise, but hard code some inputs:
# Define function, fixed inputs are not parameters, but
# defined earlier as a part of the function
# ar_nN_A, ar_nN_alpha are fixed, not parameters
ffi_linear_dplyrdo_func <- function(fl_A, fl_alpha){
fl_out <- sum(fl_A*ar_nN_A + 1/(fl_alpha + 1/ar_nN_alpha))
return(fl_out)
}
# Evaluate function row by row of tibble
tbfunc_A_nN_by_nQ_A_alpha_rowwise = tb_nN_by_nQ_A_alpha %>% rowwise() %>%
mutate(dplyr_eval = ffi_linear_dplyrdo_func(fl_A, fl_alpha))
# Show
kable(tbfunc_A_nN_by_nQ_A_alpha_rowwise) %>%
kable_styling_fc()| fl_A | fl_alpha | dplyr_eval |
|---|---|---|
| -2 | 0.1 | 2.346356 |
| -1 | 0.3 | 2.094273 |
| 0 | 0.5 | 1.895316 |
| 1 | 0.7 | 1.733708 |
| 2 | 0.9 | 1.599477 |
Apparantly rowwise() is not a good idea, and pmap should be used, below is the pmap solution to the problem. Which does seem nicer. Crucially, don’t have to define input parameter names, automatically I think they are matching up to the names in the function
# Define function, fixed inputs are not parameters, but defined
# earlier as a part of the function Rorate fl_alpha and fl_A name
# compared to before to make sure pmap tracks by names
ffi_linear_dplyrdo_func <- function(fl_alpha, fl_A){
fl_out <- sum(fl_A*ar_nN_A + 1/(fl_alpha + 1/ar_nN_alpha))
return(fl_out)
}
# Evaluate a function row by row of dataframe, generate list,
# then to vector
tb_nN_by_nQ_A_alpha %>% pmap(ffi_linear_dplyrdo_func) %>% unlist()## [1] 2.346356 2.094273 1.895316 1.733708 1.599477# Same as above, but in line line and save output as new column
# in dataframe note this ONLY works if the tibble only has variables
# that are inputs for the function if tibble contains additional
# variables, those should be droppd, or only the ones needed selected,
# inside the pmap call below.
tbfunc_A_nN_by_nQ_A_alpha_pmap <- tb_nN_by_nQ_A_alpha %>%
mutate(dplyr_eval_pmap =
unlist(
pmap(tb_nN_by_nQ_A_alpha, ffi_linear_dplyrdo_func)
)
)
# Show
kable(tbfunc_A_nN_by_nQ_A_alpha_pmap) %>%
kable_styling_fc()| fl_A | fl_alpha | dplyr_eval_pmap |
|---|---|---|
| -2 | 0.1 | 2.346356 |
| -1 | 0.3 | 2.094273 |
| 0 | 0.5 | 1.895316 |
| 1 | 0.7 | 1.733708 |
| 2 | 0.9 | 1.599477 |
Now, we have three types of parameters, for something like a bisection type calculation. We will supply the program with a function with some hard-coded value inside, and as parameters, we will have one parameter which is a row in the current matrix, and another parameter which is a sclar values. The three types of parameters are dealt with sparately:
second scalar value parameter for the function
dplyr mutate function applow to each row dot notation
note rowwise might be bad according to Hadley, should use pmap?
ffi_linear_dplyrdo_fdot <- function(ls_row, fl_param){
# Type 1 Param = ar_nN_A, ar_nN_alpha
# Type 2 Param = ls_row$fl_A, ls_row$fl_alpha
# Type 3 Param = fl_param
fl_out <- (sum(ls_row$fl_A*ar_nN_A +
1/(ls_row$fl_alpha + 1/ar_nN_alpha))) + fl_param
return(fl_out)
}
cur_func <- ffi_linear_dplyrdo_fdot
fl_param <- 0
dplyr_eval_flex <- tb_nN_by_nQ_A_alpha %>% rowwise() %>%
do(dplyr_eval_flex = cur_func(., fl_param)) %>%
unnest(dplyr_eval_flex)
tbfunc_B_nN_by_nQ_A_alpha <- tb_nN_by_nQ_A_alpha %>% add_column(dplyr_eval_flex)
# Show
kable(tbfunc_B_nN_by_nQ_A_alpha) %>%
kable_styling_fc()| fl_A | fl_alpha | dplyr_eval_flex |
|---|---|---|
| -2 | 0.1 | 2.346356 |
| -1 | 0.3 | 2.094273 |
| 0 | 0.5 | 1.895316 |
| 1 | 0.7 | 1.733708 |
| 2 | 0.9 | 1.599477 |
# Show overall Results
mt_results <- cbind(tb_nN_by_nQ_A_alpha_show['dplyr_eval'],
tbfunc_A_nN_by_nQ_A_alpha_rowwise['dplyr_eval'],
tbfunc_A_nN_by_nQ_A_alpha_pmap['dplyr_eval_pmap'],
tbfunc_B_nN_by_nQ_A_alpha['dplyr_eval_flex'],
mt_nN_by_nQ_A_alpha)
colnames(mt_results) <- c('eval_dplyr_mutate',
'eval_dplyr_mutate_hcode',
'eval_dplyr_mutate_pmap',
'eval_dplyr_mutate_flex',
'A_child', 'alpha_child')
kable(mt_results) %>%
kable_styling_fc_wide()| eval_dplyr_mutate | eval_dplyr_mutate_hcode | eval_dplyr_mutate_pmap | eval_dplyr_mutate_flex | A_child | alpha_child |
|---|---|---|---|---|---|
| 2.346356 | 2.346356 | 2.346356 | 2.346356 | -2 | 0.1 |
| 2.094273 | 2.094273 | 2.094273 | 2.094273 | -1 | 0.3 |
| 1.895316 | 1.895316 | 1.895316 | 1.895316 | 0 | 0.5 |
| 1.733708 | 1.733708 | 1.733708 | 1.733708 | 1 | 0.7 |
| 1.599477 | 1.599477 | 1.599477 | 1.599477 | 2 | 0.9 |