data-raw/fns/make.R
In ready4-dev/specific: Specify Models to Solve Inverse Problems
make_abstract_args_ls <- function(results_ls, # Duplicate name from ready4show - Is This Deliberate?
fl_nm_1L_chr = "abstract.txt"){
mdl_cmprsns_ls <- get_mdl_cmprsns(results_ls, as_list_1L_lgl = T)
abstract_args_ls <- list(abstract_ls = list(Background = get_background_text(results_ls),
Objectives = paste0("We aimed to identify the best regression models to predict ",
get_hlth_utl_nm(results_ls, short_nm_1L_lgl = F),
" (",
get_hlth_utl_nm(results_ls),
") utility and evaluate the predictive ability of ",
get_nbr_of_predrs(results_ls),
" candidate measure",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1,"s",""),
" of ",
get_predr_ctgs(results_ls),
"."),
Methods = paste0(results_ls$study_descs_ls$sample_desc_1L_chr,
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
"",
paste0(" Follow-up measurements were ",
results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr,
" after baseline. ")),
paste0(length(mdl_cmprsns_ls$OLS) %>%
xfun::numbers_to_words() %>%
Hmisc::capitalize()),
" ordinary least squares (OLS) and ",
length(mdl_cmprsns_ls$GLM) %>%
xfun::numbers_to_words(),
" generalised linear models (GLMs) were explored to identify the best algorithm. ",
" Predictive ability of ",
get_nbr_of_predrs(results_ls),
" candidate measure",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1,"s",""),
" of ",
get_predr_ctgs(results_ls),
" were assessed using ten fold cross validation",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1," and forest models",""),
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
". ",
paste0(". Linear / generalised linear mixed effect models were then used to construct longitudinal predictive models for ",
get_hlth_utl_nm(results_ls),
" change."))),
Results = paste0(make_ten_fold_text(results_ls, for_abstract_1L_lgl = T),
". ",
make_selected_mdl_text(results_ls, for_abstract_1L_lgl = T),
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
"",
paste0(" The mean ratio between the within-person and between-person associated coefficients was ",
make_within_between_ratios_text(results_ls,
exclude_covars_1L_lgl = T),
"."))
),
Conclusions = get_conclusion_text(results_ls),
Data = make_data_availability_text(results_ls)),
fl_nm_1L_chr = fl_nm_1L_chr)
return(abstract_args_ls)
}
make_all_mdl_types_smry_tbl <- function(outp_smry_ls,
mdls_tb){
mdls_ls <- make_mdls_ls(outp_smry_ls,
mdls_tb = mdls_tb)
all_mdl_types_smry_tbl_tb <- 1:length(mdls_ls) %>% # Modified from 1:2 - need to test.
purrr::map_dfc(
~ {
make_mdl_type_smry_tbl(mdls_tb = mdls_tb,
mdl_nms_chr = mdls_ls[[.x]],
mdl_type_1L_chr = outp_smry_ls$prefd_mdl_types_chr[.x],
add_mdl_nm_sfx_1L_lgl = T)
}
) %>%
dplyr::select(-paste0("Parameter_",outp_smry_ls$prefd_mdl_types_chr[-1])) %>%
dplyr::rename_with(~"Parameter",.cols = paste0("Parameter_",outp_smry_ls$prefd_mdl_types_chr[1]))
return(all_mdl_types_smry_tbl_tb)
}
make_analysis_core_params_ls <- function(ds_descvs_ls,
mdl_smry_ls = make_mdl_smry_ls(),
output_format_ls = make_output_format_ls(),
predictors_lup,
control_ls = NULL,
iters_1L_int = 4000L,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
prior_ls = NULL,
seed_1L_int = 12345
){
candidate_covar_nms_chr <- ds_descvs_ls$candidate_covar_nms_chr
use_fake_data_1L_lgl <- ds_descvs_ls$is_fake_1L_lgl
analysis_core_params_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
ds_descvs_ls = ds_descvs_ls,
iters_1L_int = iters_1L_int,
mdl_smry_ls = mdl_smry_ls,
nbr_of_digits_1L_int = output_format_ls$supplementary_digits_1L_int,
output_type_1L_chr = output_format_ls$supplementary_outp_1L_chr,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
seed_1L_int = seed_1L_int,
use_fake_data_1L_lgl = use_fake_data_1L_lgl,
prior_ls = prior_ls,
control_ls = control_ls)
return(analysis_core_params_ls)
}
make_analysis_ds_smry_ls <- function(ds_descvs_ls,
candidate_covar_nms_chr,
predictors_lup){
analysis_ds_smry_ls <- list(candidate_predrs_chr = ds_descvs_ls$candidate_predrs_chr,
candidate_covar_nms_chr = candidate_covar_nms_chr,
depnt_var_nm_1L_chr = ds_descvs_ls$utl_wtd_var_nm_1L_chr,
id_var_nm_1L_chr = ds_descvs_ls$id_var_nm_1L_chr,
predictors_lup = predictors_lup,
round_var_nm_1L_chr = ds_descvs_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = ds_descvs_ls$round_vals_chr[1],
dictionary_tb = ds_descvs_ls$dictionary_tb)
return(analysis_ds_smry_ls)
}
make_bl_fup_add_to_row_ls <- function(df,
n_at_bl_1L_int,
n_at_fup_1L_int){
if(is.na(n_at_fup_1L_int)){
fup_1L_chr <- character(0)
}else{
fup_1L_chr <- paste0(" & \\multicolumn{2}{c}{\\textbf{Follow-up (N=",n_at_fup_1L_int,")}}")
}
add_to_row_ls <- list(pos = list(-1, nrow(df)),
command = c(paste("\\toprule \n",
paste0("\\multicolumn{2}{c}{} & \\multicolumn{2}{c}{\\textbf{Baseline (N=",n_at_bl_1L_int,")}}",fup_1L_chr," \\\\\n")),
paste("\\bottomrule \n"
)
)
)
return(add_to_row_ls)
}
make_brms_mdl_plt <- function(outp_smry_ls,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_desc_1L_chr,
mdl_nm_1L_chr,
type_1L_chr,
base_size_1L_dbl = 8,
brms_mdl = NULL,
correspondences_lup = NULL,
new_var_nm_1L_chr = "Predicted",
predn_type_1L_chr = NULL,
x_lbl_1L_chr = NA_character_,
y_lbl_1L_chr = NA_character_){
sfx_1L_chr <- " from brmsfit"
mdl_types_lup <- outp_smry_ls$mdl_types_lup
if(is.null(brms_mdl)){
incld_mdl_paths_chr <- make_incld_mdl_paths(outp_smry_ls)
brms_mdl <- readRDS(paste0(outp_smry_ls$path_to_write_to_1L_chr,"/",
incld_mdl_paths_chr[incld_mdl_paths_chr %>% endsWith(paste0(mdl_nm_1L_chr,".RDS"))]))
}
mdl_type_1L_chr <- get_mdl_type_from_nm(mdl_nm_1L_chr,
mdl_types_lup = mdl_types_lup)
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "tfmn_chr",
evaluate_1L_lgl = F)
plot_fn_and_args_ls <- make_plot_fn_and_args_ls(brms_mdl = brms_mdl,
tfd_data_tb = outp_smry_ls$scored_data_tb %>%
transform_tb_to_mdl_inp(depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,##
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
predr_vars_nms_chr = outp_smry_ls$predr_vars_nms_ls %>% purrr::flatten_chr() %>% unique(),
id_var_nm_1L_chr = outp_smry_ls$id_var_nm_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr,
scaling_fctr_dbl = make_scaling_fctr_dbl(outp_smry_ls)),
base_size_1L_dbl = base_size_1L_dbl,
correspondences_lup = correspondences_lup,
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
new_var_nm_1L_chr = new_var_nm_1L_chr,
predn_type_1L_chr = predn_type_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
sd_dbl = NA_real_,
sfx_1L_chr = sfx_1L_chr,
tfmn_1L_chr = tfmn_1L_chr,
type_1L_chr = type_1L_chr,
utl_min_val_1L_dbl = ifelse(!is.null(outp_smry_ls$utl_min_val_1L_dbl),
outp_smry_ls$utl_min_val_1L_dbl,
-1),
x_lbl_1L_chr = x_lbl_1L_chr,
y_lbl_1L_chr = y_lbl_1L_chr)
plt <- rlang::exec(plot_fn_and_args_ls$plt_fn, !!!plot_fn_and_args_ls$fn_args_ls)
return(plt)
}
make_brms_mdl_print_ls <- function (mdl_ls, label_stub_1L_chr, caption_1L_chr, output_type_1L_chr = "PDF",
digits_1L_dbl = 2, big_mark_1L_chr = " ")
{
smry_mdl_ls <- summary(mdl_ls, digits = 4)
mdl_smry_chr <- smry_mdl_ls %>% utils::capture.output()
idx_dbl <- c("Formula: ",
" Draws:",#"Samples: ",
"Group-Level Effects: ",
"Population-Level Effects: ",
"Family Specific Parameters: ",
"Draws were sampled using "#"Samples were drawn using "
) %>%
purrr::map_dbl(~mdl_smry_chr %>%
startsWith(.x) %>% which())
data_tb <- make_brms_mdl_smry_tbl(smry_mdl_ls, grp_1L_chr = mdl_smry_chr[idx_dbl[3]],
popl_1L_chr = mdl_smry_chr[idx_dbl[4]], fam_1L_chr = mdl_smry_chr[idx_dbl[5]])
bold_lgl <- data_tb$Parameter %in% c(mdl_smry_chr[idx_dbl[3]],
mdl_smry_chr[idx_dbl[4]], mdl_smry_chr[idx_dbl[5]])
if (output_type_1L_chr == "PDF") {
data_tb <- data_tb %>% dplyr::mutate(Parameter = purrr::map_chr(Parameter,
~.x %>% Hmisc::latexTranslate()))
}
data_tb <- data_tb %>% dplyr::mutate(Parameter = Parameter %>%
purrr::map2_chr(dplyr::all_of(bold_lgl), ~ifelse(.y &
output_type_1L_chr == "PDF", paste0("\\textbf{",
.x, "}"), .x)))
if (output_type_1L_chr != "PDF") {
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(c(Bulk_ESS,
Tail_ESS), ~format(., big.mark = big_mark_1L_chr)))
}
if (output_type_1L_chr == "HTML") {
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(where(is.numeric),
~format(round(., digits = digits_1L_dbl), digits = digits_1L_dbl,
nsmall = digits_1L_dbl)))
}
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(where(is.character),
~dplyr::case_when(is.na(.) ~ "", . == "NA" ~ "", endsWith(.,
" NA") ~ "", TRUE ~ .)))
end_matter_1L_chr <- trimws(mdl_smry_chr[idx_dbl[6]:length(mdl_smry_chr)]) %>%
paste0(collapse = " ")
brms_mdl_print_ls <- list(part_1 = mdl_smry_chr[idx_dbl[1]],
part_2 = "\n\n", part_3 = c(trimws(mdl_smry_chr[1:(idx_dbl[2] -
1)][-idx_dbl[1]]), paste0(trimws(mdl_smry_chr[idx_dbl[2]]),
" ", trimws(mdl_smry_chr[idx_dbl[2] + 1]), collapse = " ")) %>%
paste0(collapse = ifelse(output_type_1L_chr == "PDF",
"\n\n", "\n")), part_4 = "\n\n", part_5 = list(data_tb = data_tb,
output_type_1L_chr = output_type_1L_chr, caption_1L_chr = caption_1L_chr,
mkdn_tbl_ref_1L_chr = paste0("tab:", label_stub_1L_chr), merge_row_idx_int = as.integer(which(bold_lgl)),
digits_dbl = c(ifelse(output_type_1L_chr == "PDF",
0, NA_real_) %>% purrr::discard(is.na), names(data_tb) %>%
purrr::map_dbl(~ifelse(.x %in% c("Bulk_ESS",
"Tail_ESS"), 0, digits_1L_dbl))), big_mark_1L_chr = big_mark_1L_chr,
hline_after_ls = c(-1, 0), sanitize_fn = force, footnotes_chr = NA_character_),
part_6 = end_matter_1L_chr)
if (output_type_1L_chr != "PDF") {
brms_mdl_print_ls$part_5$footnotes_chr <- c(paste0(brms_mdl_print_ls$part_1,
ifelse(output_type_1L_chr == "Word", "", "\n")),
brms_mdl_print_ls$part_3, brms_mdl_print_ls$part_6)
brms_mdl_print_ls$part_6 <- NULL
}
else {
footnotes_chr <- c(mdl_smry_chr[idx_dbl[1]], trimws(mdl_smry_chr[1:(idx_dbl[2] -
1)][-idx_dbl[1]]), trimws(mdl_smry_chr[idx_dbl[2]]),
trimws(mdl_smry_chr[idx_dbl[2] + 1]), trimws(mdl_smry_chr[idx_dbl[6]:length(mdl_smry_chr)])) %>%
Hmisc::latexTranslate()
footnotes_chr[1] <- footnotes_chr[1] %>% stringr::str_replace("~",
"\\\\textasciitilde")
brms_mdl_print_ls$part_5$add_to_row_ls <- list(pos = purrr::map(c(0,
rep(nrow(data_tb), length(footnotes_chr) + 1)), ~.x),
command = c(names(data_tb) %>% Hmisc::latexTranslate() %>%
paste0(collapse = " & ") %>% paste0("\\\\\n"),
c("\\toprule\n"), footnotes_chr %>% purrr::map_chr(~paste0("\\multicolumn{",
ncol(data_tb), "}{l}{", paste0("{\\footnotesize ",
.x, "}\n", collapse = ","), "}\\\\\n"))))
}
return(brms_mdl_print_ls)
}
make_brms_mdl_smry_tbl <- function (smry_mdl_ls, grp_1L_chr, popl_1L_chr, fam_1L_chr)
{
brms_mdl_smry_tb <- purrr::map(1:length(smry_mdl_ls$random),
~make_mdl_smry_elmt_tbl(ctg_chr = c(ifelse(.x == 1, grp_1L_chr,
character(0)),
paste0(names(smry_mdl_ls$ngrps)[.x],
" (Number of levels: ",
smry_mdl_ls$ngrps[.x][[1]],
")")),
mat = smry_mdl_ls$random[.x][[1]])) %>%
dplyr::bind_rows(make_mdl_smry_elmt_tbl(mat = smry_mdl_ls$fixed,
ctg_chr = popl_1L_chr),
make_mdl_smry_elmt_tbl(mat = smry_mdl_ls$spec_pars,
ctg_chr = fam_1L_chr))
return(brms_mdl_smry_tb)
}
make_cmpst_sctr_and_dnst_plt <- function(outp_smry_ls,
output_data_dir_1L_chr = NA_character_,
predr_var_nms_chr = NA_character_,
base_size_1L_dbl = 16,
correspondences_lup = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_desc_1L_chr = NA_character_,
labels_chr = c("A","B","C","D"),
label_x_1L_dbl = 0.1,
label_y_1L_dbl = 0.9,
label_size_1L_dbl = 22,
mdl_indcs_int = 1:2,
use_png_fls_1L_lgl = T){
if(use_png_fls_1L_lgl){
filtered_paths_chr <- outp_smry_ls$file_paths_chr %>% purrr::discard(~endsWith(.x,"_sim_sctr.png")|endsWith(.x,"_sim_dnst.png")|endsWith(.x,"_cnstrd_sctr_plt.png")|endsWith(.x,"_cnstrd_dnst.png"))
filtered_paths_chr <- paste0(output_data_dir_1L_chr,"/",filtered_paths_chr[filtered_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,paste0(predr_var_nms_chr,"_1")) & (stringr::str_detect(.x,"_dnst.png") | stringr::str_detect(.x,"_sctr_plt.png")))])
mdl_types_chr <- filtered_paths_chr %>% purrr::map_chr(~DescTools::SplitPath(.x)$filename %>%
stringr::str_remove("_dnst") %>%
stringr::str_remove("_sctr_plt") %>%
get_mdl_type_from_nm())
ordered_paths_chr <- outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map(~filtered_paths_chr[which(mdl_types_chr==.x)]) %>%
purrr::flatten_chr()
plot_ls <- ordered_paths_chr %>% purrr::map(~cowplot::ggdraw() + cowplot::draw_image(.x))
}else{
plots_chr <- outp_smry_ls$mdl_nms_ls %>%
purrr::flatten_chr()
plots_chr <- plots_chr[mdl_indcs_int]
plot_ls <- plots_chr %>%
purrr::map(~{
mdl_nm_1L_chr <- .x
brms_mdl <- get_brms_mdl(outp_smry_ls,
mdl_nm_1L_chr = mdl_nm_1L_chr)
if(is.na(depnt_var_desc_1L_chr)){
depnt_var_desc_1L_chr <- get_hlth_utl_nm(outp_smry_ls$results_ls,
short_nm_1L_lgl = T)
}
purrr::map(c("dnst", "sctr_plt"),
~ {
make_brms_mdl_plt(outp_smry_ls,
base_size_1L_dbl = base_size_1L_dbl,
brms_mdl = brms_mdl,
correspondences_lup = correspondences_lup,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,#
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
mdl_nm_1L_chr = mdl_nm_1L_chr,
type_1L_chr = .x,
predn_type_1L_chr = NULL,
x_lbl_1L_chr = paste0("Observed ", depnt_var_desc_1L_chr),
y_lbl_1L_chr = paste0("Predicted ", depnt_var_desc_1L_chr))
})
}) %>%
purrr::flatten()
}
composite_plt <- cowplot::plot_grid(plot_ls[[1]],plot_ls[[2]],plot_ls[[3]],plot_ls[[4]],
nrow = 2,
labels = labels_chr,
label_x = label_x_1L_dbl,
label_y = label_y_1L_dbl,
label_size = label_size_1L_dbl)
return(composite_plt)
}
make_cndt_predr_text <- function(results_ls,
type_1L_chr = "description"){
nbr_of_predrs_1L_int <- get_nbr_of_predrs(results_ls,
as_words_1L_lgl = F)
if(type_1L_chr == "description"){
text_1L_chr <- paste0(get_nbr_of_predrs(results_ls) %>% Hmisc::capitalize(),
" measure",
ifelse(nbr_of_predrs_1L_int>1,
"s",
""),
" of ",
get_nbr_of_predrs_by_ctg(results_ls),
ifelse(nbr_of_predrs_1L_int>1," were"," was"),
" used as ",
ifelse(nbr_of_predrs_1L_int>1,
"",
"a "),
"candidate predictor",
ifelse(nbr_of_predrs_1L_int>1,
"s",
""),
" to construct models.")
}
if(type_1L_chr == "comparison"){
text_1L_chr <- paste0(ifelse(nbr_of_predrs_1L_int > 1,
paste0("We ",
"evaluated",
" the independent predictive ability of different candidate predictors using 10-fold cross-validation."),
""))
}
return(text_1L_chr)
}
make_cohort_ls <- function(descv_tbls_ls,
ctgl_vars_regrouping_ls = NULL,
nbr_of_digits_1L_int = 2L){
numeric_vars_chr <- descv_tbls_ls$cohort_desc_tb %>% dplyr::filter(label ==
"Median (Q1, Q3)") %>% dplyr::pull(variable)
ctgl_vars_chr <- unique(descv_tbls_ls$cohort_desc_tb$variable[!descv_tbls_ls$cohort_desc_tb$variable %in% numeric_vars_chr])
nbr_by_round_dbl <- paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr,"_val_1_dbl") %>%
purrr::map_dbl(~descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == ctgl_vars_chr[1]) %>%
dplyr::pull(.x) %>%
purrr::discard(~.x=="") %>%
as.numeric() %>% purrr::map_dbl(~.x[[1]]) %>% sum())
numeric_vars_smry_ls <- numeric_vars_chr %>%
purrr::map(~{
var_smry_tb <- descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == .x)
list(bl_min_1L_dbl = var_smry_tb %>%
dplyr::filter(label == "Min - Max") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_1_dbl"))) %>%
as.numeric(),
bl_max_1L_dbl = var_smry_tb %>%
dplyr::filter(label == "Min - Max") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_2_ls"))) %>%
as.numeric(),
bl_mean_1L_dbl = round(var_smry_tb %>% dplyr::filter(label == "Mean (SD)") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_1_dbl"))) %>%
as.numeric(),
nbr_of_digits_1L_int),
bl_sd_1L_dbl = round(var_smry_tb %>% dplyr::filter(label == "Mean (SD)") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_2_ls"))) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric(),
nbr_of_digits_1L_int))
}) %>% stats::setNames(numeric_vars_chr)
cohort_ls <- list(n_all_1l_dbl = descv_tbls_ls$ds_descvs_ls$nbr_participants_1L_int,
n_inc_1L_dbl = nbr_by_round_dbl[1],
n_fup_1L_dbl = nbr_by_round_dbl[2],
numeric_vars_smry_ls = numeric_vars_smry_ls)
if(!is.null(ctgl_vars_regrouping_ls)){
append_ls <- ctgl_vars_regrouping_ls %>%
purrr::map2(names(ctgl_vars_regrouping_ls),
~{
var_nm_1L_chr <- .y
.x %>%
purrr::map(~{
list(name_1L_chr = .x$name_1L_chr,
n_in_group_1L_dbl = descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == var_nm_1L_chr) %>%
dplyr::filter(label %in% .x$ctgs_chr) %>%
dplyr::pull(Baseline_val_1_dbl) %>%
as.numeric() %>% purrr::map_dbl(~.x) %>% sum(),
n_msng_1L_dbl = descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == var_nm_1L_chr) %>%
dplyr::filter(label == "Missing") %>%
dplyr::pull(Baseline_val_1_dbl) %>%
as.numeric())
}
)
})
cohort_ls <- append(cohort_ls,append_ls)
}
return(cohort_ls)
}
make_coi_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$coi_1L_chr),
"",
results_ls$study_descs_ls$coi_1L_chr)
return(text_1L_chr)
}
make_correlation_text <- function(results_ls){
correlation_text_1L_chr <- ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<2,
"",
paste0(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[1],
" was found to have the highest correlation with utility score both at baseline and follow-up followed by ",
results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[2],
ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<3,"",paste0(" and ", results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[3])),
ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<4,"",paste0("; baseline and follow-up ",results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)]," was found to have the lowest correlation coefficients with utility score")),
"."))
return(correlation_text_1L_chr)
}
make_covar_ttu_tbl_refs <- function(params_ls){
results_ls <- params_ls$results_ls
n_mdls_1L_int <- length(results_ls$ttu_lngl_ls$best_mdls_tb$model_type)
n_covars_1L_int <- length(results_ls$ttu_lngl_ls$incld_covars_chr %>% purrr::discard(is.na))
text_1L_chr <- paste0(ifelse(n_covars_1L_int < 1,
"",
paste0(" (see ",
ifelse(params_ls$output_type_1L_chr == "Word","","Table"),
"s ",
paste0("\\@ref(tab:coefscovarstype",1:n_mdls_1L_int,")", collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
")."
))
)
return(text_1L_chr)
}
make_covar_ttu_tbl_title <- function(results_ls, # Generalise from TTU
ref_1L_int = 1){
title_1L_chr <- paste0('Estimated coefficients from utility mapping models based on individual candidate predictors with ',
results_ls$ttu_lngl_ls$incld_covars_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(results_ls$mdl_ingredients_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_desc_chr")) %>%
ready4::make_list_phrase() %>%
paste0(collapse = ", ") %>% stringi::stri_replace_last(fixed = ",", " and"),
' using ', results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,"model_type"]], ' (', results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,"link_and_tfmn_chr"]],')')
return(title_1L_chr)
}
make_covariates_text <- function(results_ls){ # Generalise from utility
if(!is.null(results_ls$candidate_covars_ls)){
if(length(results_ls$candidate_covars_ls)<1){
text_1L_chr <- ""
}else{
n_predrs_1L_int <- get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)
tfmn_fn <- function(x, results_ls){ifelse(is.na(results_ls$cohort_ls$n_fup_1L_dbl),Hmisc::capitalize(x),x)}
text_1L_chr <- paste0("The confounding effect of other participant characteristics when using the candidate predictors in predicting utility score were also evaluated. ",
ifelse(is.na(results_ls$cohort_ls$n_fup_1L_dbl),"","Using the baseline data, "),
ifelse(is.na(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr[1]),
"no confounding factor",
results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(data_lookup_tb =results_ls$mdl_ingredients_ls$dictionary_tb,match_var_nm_1L_chr = "var_nm_chr", match_value_xx = .x, target_var_nm_1L_chr = "var_desc_chr")) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
tfmn_fn(results_ls)),
" ",
ifelse(is.na(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr[1]),"was",ifelse(length(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr)==1,"was","were")),
" found to independently predict utility scores in models for ",
ifelse(n_predrs_1L_int == 1,
"the ",
ifelse(n_predrs_1L_int == 2,
"both ",
paste0("all ", get_nbr_of_predrs(results_ls)," "))),
"candidate predictor",
ifelse(n_predrs_1L_int == 1," ","s "),
"*(p<0.01)*.")
mdls_with_signft_covars_ls <- results_ls$mdls_with_signft_covars_ls
duplicates_int <- which(duplicated(mdls_with_signft_covars_ls))
if(!identical(integer(0), duplicates_int)){
unduplicated_ls <- mdls_with_signft_covars_ls[!duplicated(mdls_with_signft_covars_ls)]
duplicated_ls <- mdls_with_signft_covars_ls[duplicates_int]
add_to_chr <- duplicates_int %>%
purrr::map(~{
match_chr <- mdls_with_signft_covars_ls[[.x]]
mdls_with_signft_covars_ls[1:(.x-1)] %>%
purrr::map_lgl(~identical(.x,match_chr)) %>%
names()
}) %>%
purrr::flatten_chr() %>% unique()
signft_covars_chr <- names(unduplicated_ls) %>%
purrr::map(~{
vars_chr <- c(.x,names(duplicated_ls)[which(.x == add_to_chr)])
paste0(vars_chr %>%
purrr::map_chr(~ transform_names(.x,
rename_lup = results_ls$var_nm_change_lup)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
ifelse(length(vars_chr)>1," were significant covariates *(p<0.01)*"," was a significant covariate *(p<0.01)*"),
" in the ")
}) %>%
purrr::flatten_chr()
mdls_ls <- unduplicated_ls
}else{
if(!is.na(names(mdls_with_signft_covars_ls)[1])){
signft_covars_chr <- names(mdls_with_signft_covars_ls) %>%
purrr::map_chr(~paste0(transform_names(.x,
rename_lup = results_ls$var_nm_change_lup),
" was a significant covariate *(p<0.01)* in the "))
mdls_ls <- mdls_with_signft_covars_ls
}else{
signft_covars_chr <- ""
mdls_ls <- NULL
}
}
if(!is.null(mdls_ls)){
nbr_predrs_1L_int <- get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)
sig_for_some_int <- which(mdls_ls %>% purrr::map_lgl(~length(.x) != nbr_predrs_1L_int)) %>% unname()
if(!identical(sig_for_some_int, integer(0))){
mdls_ls <- mdls_ls[sig_for_some_int]
signft_covars_chr <- signft_covars_chr[sig_for_some_int]
text_1L_chr <- paste0(text_1L_chr,
" ",
mdls_ls %>% purrr::map_chr(~ .x %>%
purrr::map_chr(~ transform_names(.x,
rename_lup = results_ls$var_nm_change_lup)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")) %>%
purrr::map2_chr(signft_covars_chr,
~ paste0(.y,
.x,
" model",
ifelse(stringr::str_detect(.x," and "),"s. ",". "))) %>%
paste0(collapse = ""))
}
}
}
}else{
text_1L_chr <- ""
}
return(text_1L_chr)
}
make_cs_ts_ratios_tb <- function(predr_ctgs_ls,
mdl_coef_ratios_ls,
candidate_predrs_chr = NULL,
nbr_of_digits_1L_int = 2L,
fn_ls = NULL){
if(is.null(fn_ls))
fn_ls <- purrr::map(1:length(predr_ctgs_ls),
~ make_mdl_coef_range_text)
if(is.null(candidate_predrs_chr)){
candidate_predrs_chr <- predr_ctgs_ls %>% purrr::flatten_chr()
}
cs_ts_ratios_tb <- 1:length(predr_ctgs_ls) %>%
purrr::map_dfr(
~ {
if(length(predr_ctgs_ls %>% purrr::pluck(.x))>1){
predr_nm_1L_chr <- paste0(names(predr_ctgs_ls)[.x] %>% tolower(),
" measurements")
}else{
predr_nm_1L_chr <- predr_ctgs_ls %>% purrr::pluck(.x)
}
tibble::tibble(predr_nm_chr = predr_nm_1L_chr,
ratios_chr = ifelse(identical(make_mdl_coef_range_text,fn_ls %>% purrr::pluck(.x)),
make_mdl_coef_range_text(mdl_coef_ratios_ls %>%
purrr::pluck(names(predr_ctgs_ls)[.x]),
nbr_of_digits_1L_int = nbr_of_digits_1L_int),
paste0(round(rlang::exec(fn_ls %>%
purrr::pluck(.x),
mdl_coef_ratios_ls %>%
purrr::pluck(names(predr_ctgs_ls)[.x])),
nbr_of_digits_1L_int),
ifelse(identical(min,fn_ls %>% purrr::pluck(.x)),
" or over",
ifelse(identical(max,fn_ls %>% purrr::pluck(.x)),
" or under",
"")))),
contains_cndt_predr_lgl = predr_ctgs_ls[[.x]] %>%
purrr::map_lgl(~!identical(intersect(.x, candidate_predrs_chr), character(0))) %>% unname()
)
})
cs_ts_ratios_tb <- dplyr::distinct(cs_ts_ratios_tb)
return(cs_ts_ratios_tb)
}
make_csnl_example_predrs <- function(){ # New to specific
predictors_r3 <- Ready4useRepos(dv_nm_1L_chr = "TTU",
dv_ds_nm_1L_chr = "https://doi.org/10.7910/DVN/DKDIB0",
dv_server_1L_chr = "dataverse.harvard.edu") %>%
ingest(fls_to_ingest_chr = c("predictors_r3"),
metadata_1L_lgl = F)
predictors_r3 <- renew.specific_predictors(predictors_r3,
filter_cdn_1L_chr = "short_name_chr == 'SOFAS'") %>%
renew.specific_predictors(short_name_chr = c("K10", "MLT", "CHU9D", "AQOL6D"),
long_name_chr = c("K10 total score", "MLT total score", "CHU9D health utility", "AQOL6D health utility"),
min_val_dbl = c(10,0,-0.1059,0.03),
max_val_dbl = c(50,100,1,1),
class_chr = c("integer","numeric","numeric","numeric"),
increment_dbl = 1,
class_fn_chr = c("youthvars::youthvars_k10_aus","as.double","youthvars::youthvars_chu9d_adolaus","youthvars::youthvars_aqol6d_adol"),
mdl_scaling_dbl = c(0.01,0.01,1,1),
covariate_lgl = F) %>%
dplyr::mutate(covariate_lgl = dplyr::case_when(short_name_chr == "SOFAS" ~ F,
T ~ covariate_lgl))
return(predictors_r3)
}
make_data_availability_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$dv_ds_nm_and_url_chr),
"None available",
paste0("Detailed results in the form of catalogues of the models produced by this study and other supporting information are available in the online repository: ",results_ls$dv_ds_nm_and_url_chr[2]))
return(text_1L_chr)
}
make_dnst_and_sctr_plt_title <- function(results_ls){ # Generalise from utility
title_1L_chr <- paste0("Comparison of observed and predicted ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" score from longitudinal model using ",
results_ls$predr_var_nms_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",",
" and"),
" (A) Density plots of observed and predicted utility scores (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(1),
") (B) Scatter plots of observed and predicted utility scores by timepoint (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(1),
") (C) Density plots of observed and predicted results (",
ifelse(nrow(results_ls$ttu_lngl_ls$best_mdls_tb)>1,
paste0(results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(2),
") (D) Scatter plots of observed and predicted results by timepoint (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(2),")"),
""))
return(title_1L_chr)
}
make_ds_descvs_ls <- function(candidate_predrs_chr,# Generalise from utility
cohort_descv_var_nms_chr,
dictionary_tb,
id_var_nm_1L_chr,
msrmnt_date_var_nm_1L_chr,
round_var_nm_1L_chr,
round_vals_chr,
maui_item_pfx_1L_chr,
utl_wtd_var_nm_1L_chr = "wtd_utl_dbl",
utl_unwtd_var_nm_1L_chr = "unwtd_utl_dbl",
candidate_covar_nms_chr = NULL,
is_fake_1L_lgl = NULL){
ds_descvs_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
candidate_predrs_chr = candidate_predrs_chr,
cohort_descv_var_nms_chr = cohort_descv_var_nms_chr,
dictionary_tb = dictionary_tb,
id_var_nm_1L_chr = id_var_nm_1L_chr,
is_fake_1L_lgl = is_fake_1L_lgl,
msrmnt_date_var_nm_1L_chr = msrmnt_date_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
round_vals_chr = round_vals_chr,
maui_item_pfx_1L_chr = maui_item_pfx_1L_chr,
utl_wtd_var_nm_1L_chr = utl_wtd_var_nm_1L_chr,
utl_unwtd_var_nm_1L_chr = utl_unwtd_var_nm_1L_chr)
return(ds_descvs_ls)
}
make_ds_smry_ls <- function(candidate_predrs_chr,
candidate_covar_nms_chr,
depnt_var_nm_1L_chr,
dictionary_tb,
id_var_nm_1L_chr,
round_var_nm_1L_chr,
round_bl_val_1L_chr,
predictors_lup){
ds_smry_ls <- list(candidate_predrs_chr = candidate_predrs_chr,
candidate_covar_nms_chr = candidate_covar_nms_chr,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
dictionary_tb = dictionary_tb,
id_var_nm_1L_chr = id_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
round_bl_val_1L_chr = round_bl_val_1L_chr,
predictors_lup = predictors_lup)
return(ds_smry_ls)
}
# make_eq5d_ds_dict <- function(data_tb = make_fake_eq5d_ds(),
# predictors_lup = make_psych_predrs_lup()){
# dictionary_tb <- youthvars::make_tfd_repln_ds_dict_r3() %>%
# dplyr::filter(var_nm_chr %in% names(data_tb)) %>%
# youthvars::make_final_repln_ds_dict(additions_tb = ready4use::make_pt_ready4use_dictionary(var_nm_chr = c("uid",
# "Timepoint", "data_collection_dtm",
# paste0("eq5dq_",c("MO", "SC", "UA", "PD", "AD")),
# "EQ5D_total_dbl",
# "EQ5d_cumulative_dbl",
# predictors_lup$short_name_chr),
# var_ctg_chr = c("Identifier",
# rep("Temporal",2),
# rep("Multi-Attribute Utility Instrument Question",5),
# rep("Multi-Attribute Utility Instrument Score",2),
# c("Psychological distress", "Psychological wellbeing")),
# var_desc_chr = c("Unique identifier",
# "Data collection round",
# "Date of data collection",
# "EQ5D - Mobility domain score",
# "EQ5D - Self-Care domain score",
# "EQ5D - Usual Activities domain score",
# "EQ5D - Pain / Discomfort domain score",
# "EQ5D - Anxiety / Depression domain score",
# "EQ5D",
# "EQ5D - total unweighted score",
# predictors_lup$long_name_chr),
# var_type_chr = c("integer",
# "character","date",
# rep("integer",5),
# "double",
# "integer",
# predictors_lup$class_chr
# ))) %>%
# dplyr::arrange(var_ctg_chr)
# return(dictionary_tb)
# }
make_ethics_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$ethics_1L_chr),
"",
results_ls$study_descs_ls$ethics_1L_chr)
return(text_1L_chr)
}
# make_fake_eq5d_ds <- function(country_1L_chr = "UK",
# version_1L_chr = "5L",
# type_1L_chr = "CW",
# force_attach_1L_lgl = T,
# prop_with_fup_data_1L_dbl = 0.65,
# seed_1L_int = 1234,
# sample_from_1L_int = 10000){
# set.seed(seed_1L_int)
# # requireNamespace("eq5d")
# # if(force_attach_1L_lgl)
# # attachNamespace("eq5d")
# data_tb <- purrr::map(c("MO","SC","UA","PD","AD"),
# ~list(1:5) %>% stats::setNames(.x)) %>%
# purrr::flatten_dfr() %>%
# tidyr::expand(MO,SC,UA,PD,AD) %>%
# dplyr::mutate(total_eq5d = eq5d::eq5d(., country = country_1L_chr, version = version_1L_chr, type = type_1L_chr))
# k10_lup_tb <- tibble::tibble(K10_int = (9.5 + rexp(sample_from_1L_int,rate=0.18)) %>% purrr::map_int(~as.integer(min(max(.x,10),50))),
# predd_eq5d_dbl = purrr::map2_dbl(K10_int,rnorm(sample_from_1L_int,0,0.075), ~ predict_utl_from_k10(.x,
# eq5d_error_1L_dbl = .y)[2]),
# match_idx_int = purrr::map_int(predd_eq5d_dbl, ~which.min(abs(data_tb$total_eq5d-.x))))
# data_tb <- dplyr::left_join(k10_lup_tb,
# data_tb %>% dplyr::mutate(match_idx_int = 1:dplyr::n()))
# data_tb <- data_tb %>%
# dplyr::mutate(Timepoint = total_eq5d %>%
# purrr::map2_chr(runif(sample_from_1L_int),
# ~{
# p_1L_dbl <- ifelse(.x>median(data_tb$total_eq5d),0.55,0.45)
# ifelse(.y>p_1L_dbl,"FUP","BL")
# })) %>%
# dplyr::group_by(Timepoint) %>%
# dplyr::mutate(uid = 1:dplyr::n()) %>%
# dplyr::ungroup() %>%
# dplyr::arrange(uid, Timepoint)
# bl_uids_chr <- data_tb %>% dplyr::filter(Timepoint == "BL") %>% dplyr::pull(uid)
# fup_uids_chr <- sample(bl_uids_chr,round((prop_with_fup_data_1L_dbl * length(bl_uids_chr)),0))
# data_tb <- data_tb %>%
# dplyr::filter(uid %in% bl_uids_chr) %>%
# dplyr::filter(Timepoint == "BL" | uid %in% fup_uids_chr)
# data_tb <- data_tb %>%
# dplyr::mutate(Psych_well_int = faux::rnorm_pre(K10_int, mu = 69.9, sd = 9.9, r = -0.56) %>%
# round(0) %>% purrr::map_int(~min(.x,90) %>% max(18) %>%
# as.integer()))
# data_tb <- data_tb %>% dplyr::select(uid,Timepoint,MO,SC,UA,PD,AD,K10_int,Psych_well_int)
# data("replication_popl_tb", package = "youthvars", envir = environment())
# demog_data_tb <- replication_popl_tb %>%
# youthvars::transform_raw_ds_for_analysis() %>%
# dplyr::filter(round == "Baseline") %>%
# dplyr::mutate(uid = 1:dplyr::n()) %>%
# dplyr::select(uid,
# d_interview_date,
# d_age,
# Gender,
# d_sex_birth_s,
# d_sexual_ori_s,
# d_relation_s,
# d_ATSI,
# CALD,
# Region,
# d_studying_working) %>%
# dplyr::rename(data_collection_dtm =
# d_interview_date)
# data_tb <- dplyr::left_join(data_tb %>%
# dplyr::filter(uid %in% demog_data_tb$uid),
# demog_data_tb) %>%
# dplyr::select(uid,
# Timepoint,
# data_collection_dtm,
# d_age,
# Gender,
# d_sex_birth_s,
# d_sexual_ori_s,
# d_relation_s,
# d_ATSI,
# CALD,
# Region,
# d_studying_working,
# dplyr::everything()) %>%
# dplyr::rename_with(~stringr::str_c("eq5dq_", .), .cols = c("MO", "SC", "UA", "PD", "AD")) %>%
# dplyr::mutate(data_collection_dtm = dplyr::case_when(Timepoint == "FUP" ~ data_collection_dtm + lubridate::days(120),
# T ~ data_collection_dtm))
# data_tb <- data_tb %>%
# dplyr::mutate(d_age = dplyr::case_when(Timepoint == "FUP" ~ d_age %>% purrr::map2_int(runif(nrow(data_tb)), ~ ifelse((.y + 120/365.25)>=1,.x+1L,.x)),
# T ~ d_age))
# return(data_tb)
# }
make_fake_ts_data <- function (outp_smry_ls, depnt_var_min_val_1L_dbl = numeric(0),
depnt_vars_are_NA_1L_lgl = T) {
data_tb <- outp_smry_ls$scored_data_tb %>% transform_tb_to_mdl_inp(depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
predr_vars_nms_chr = outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>% unique(),
id_var_nm_1L_chr = outp_smry_ls$id_var_nm_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr,
scaling_fctr_dbl = outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>% unique() %>%
purrr::map_dbl(~ifelse(.x %in% outp_smry_ls$predictors_lup$short_name_chr,
ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "mdl_scaling_dbl"),
1)),
tidy_1L_lgl = T)
fk_data_ls <- synthpop::syn(data_tb, visit.sequence = names(data_tb)[names(data_tb) !=
outp_smry_ls$id_var_nm_1L_chr], seed = outp_smry_ls$seed_1L_int)
fk_data_tb <- fk_data_ls$syn
if (identical(outp_smry_ls$round_var_nm_1L_chr, character(0)) |
ifelse(identical(outp_smry_ls$round_var_nm_1L_chr, character(0)),
T, is.na(outp_smry_ls$round_var_nm_1L_chr))) {
fk_data_tb <- fk_data_tb %>% dplyr::ungroup()
}
else {
fk_data_tb <- fk_data_tb %>% dplyr::mutate(`:=`(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr),
as.character(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr)))) %>%
dplyr::group_by(!!rlang::sym(outp_smry_ls$id_var_nm_1L_chr)) %>%
dplyr::mutate(`:=`(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr),
!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr) %>%
transform_timepoint_vals(timepoint_levels_chr = outp_smry_ls$scored_data_tb %>%
dplyr::pull(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr)) %>%
unique(), bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr))) %>%
dplyr::ungroup()
}
if (depnt_vars_are_NA_1L_lgl) {
depnt_vars_chr <- names(fk_data_tb)[names(fk_data_tb) %>%
purrr::map_lgl(~startsWith(.x, outp_smry_ls$depnt_var_nm_1L_chr))]
fk_data_tb <- fk_data_tb %>% dplyr::mutate(dplyr::across(dplyr::all_of(depnt_vars_chr),
~NA_real_))
}
return(fk_data_tb)
}
make_folds_ls <- function (data_tb, # Generalise for use by heterodox
depnt_var_nm_1L_chr = "utl_total_w",
folds_1L_int = 10L)
{
folds_ls <- caret::createFolds(data_tb %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
k = folds_1L_int, list = TRUE, returnTrain = FALSE)
return(folds_ls)
}
make_funding_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$funding_1L_chr),
"",
results_ls$study_descs_ls$funding_1L_chr)
return(text_1L_chr)
}
make_hlth_utl_and_predrs_ls <- function(outp_smry_ls, # Generalise from HU
descv_tbls_ls,
nbr_of_digits_1L_int = 2L,
old_nms_chr = NULL,
new_nms_chr = NULL){
ranked_predrs_ls <- make_ranked_predrs_ls(descv_tbls_ls,
old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
var_nm_1L_chr <- descv_tbls_ls$ds_descvs_ls$dictionary_tb %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "var_nm_chr",
match_value_xx = outp_smry_ls$depnt_var_nm_1L_chr,
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F) %>% as.vector()
hlth_utl_and_predrs_ls = list(bl_hu_mean_1L_dbl = descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],
"_val_1_dbl"),
evaluate_1L_lgl = F) %>%
as.numeric() %>%
round(nbr_of_digits_1L_int),
bl_hu_sd_1L_dbl = descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],
"_val_2_ls"),
evaluate_1L_lgl = F) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric() %>%
round(nbr_of_digits_1L_int),
fup_hu_mean_1L_dbl = ifelse(length(descv_tbls_ls$ds_descvs_ls$round_vals_chr)<2,
NA_real_,
descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[2],
"_val_1_dbl"),
evaluate_1L_lgl = F) %>%
as.numeric() %>%
round(nbr_of_digits_1L_int)),
fup_hu_sd_1L_dbl = ifelse(length(descv_tbls_ls$ds_descvs_ls$round_vals_chr)<2,
NA_real_,
descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[2],
"_val_2_ls"),
evaluate_1L_lgl = F) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric() %>%
round(nbr_of_digits_1L_int)),
predrs_nartv_seq_chr = ranked_predrs_ls$unranked_predrs_chr,
cor_seq_dscdng_chr = ranked_predrs_ls$ranked_predrs_chr)
return(hlth_utl_and_predrs_ls)
}
make_incld_mdl_paths <- function(outp_smry_ls){
incld_mdl_paths_chr <- outp_smry_ls$file_paths_chr %>%
purrr::map_chr(~{
file_path_1L_chr <- .x
mdl_fl_nms_chr <- paste0(outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr(),".RDS")
mdl_fl_nms_locn_ls <- mdl_fl_nms_chr %>% purrr::map(~stringr::str_locate(file_path_1L_chr,.x))
match_lgl <- mdl_fl_nms_locn_ls %>% purrr::map_lgl(~!(is.na(.x[[1,1]]) | is.na(.x[[1,2]])))
if(any(match_lgl)){
file_path_1L_chr
}else{
NA_character_
}
})
incld_mdl_paths_chr <- incld_mdl_paths_chr[!is.na(incld_mdl_paths_chr)]
ranked_mdl_nms_chr <- outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr()
sorted_mdl_nms_chr <- sort(ranked_mdl_nms_chr)
rank_indcs_int <- purrr::map_int(sorted_mdl_nms_chr,~which(ranked_mdl_nms_chr==.x))
incld_mdl_paths_chr <- incld_mdl_paths_chr[order(rank_indcs_int)]
return(incld_mdl_paths_chr)
}
make_indpnt_predrs_lngl_tbls_ref <- function(params_ls){
results_ls <- params_ls$results_ls
n_mdls_1L_int <- length(results_ls$ttu_lngl_ls$best_mdls_tb$model_type)
text_1L_chr <- paste0(ifelse(params_ls$output_type_1L_chr=="Word","","Table"),
ifelse(n_mdls_1L_int < 3,
" \\@ref(tab:cfscl)",
paste0("s ",
paste0("\\@ref(tab:cfscl",1:n_mdls_1L_int,")", collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
))
)
return(text_1L_chr)
}
make_indpnt_predrs_lngl_tbl_title <- function (results_ls, ref_1L_int = 1)# Generalise from HU
{
title_1L_chr <- paste0("Estimated coefficients for single predictor longitudinal models using ",
results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,
"model_type"]], " (", results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,
"link_and_tfmn_chr"]], ")")
return(title_1L_chr)
}
make_inner_loop_mdl_smry <- function(idx_1L_int,
data_tb,
mdl_nms_ls,
mdl_smry_dir_1L_chr,
mdl_types_lup,
predictors_lup,
predr_vars_nms_ls,
backend_1L_chr = getOption("brms.backend", "rstan"),
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w",
id_var_nm_1L_chr = "fkClientID",
iters_1L_int = 4000L,
options_chr = c("Y", "N"),
prior_ls = NULL,
round_var_nm_1L_chr = "round",
round_bl_val_1L_chr = "Baseline",
seed_1L_int = 1000L,
utl_min_val_1L_dbl = -1){
mdls_smry_tb <- purrr::map_dfr(mdl_nms_ls[[idx_1L_int]], ~{
smry_ls <- make_smry_of_ts_mdl_outp(backend_1L_chr = backend_1L_chr,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
control_ls = control_ls,
data_tb = data_tb,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
id_var_nm_1L_chr = id_var_nm_1L_chr,
iters_1L_int = iters_1L_int,
predr_vars_nms_chr = predr_vars_nms_ls[[idx_1L_int]],
mdl_nm_1L_chr = .x,
mdl_types_lup = mdl_types_lup,
options_chr = options_chr,
path_to_write_to_1L_chr = mdl_smry_dir_1L_chr,
predictors_lup = predictors_lup,
prior_ls = prior_ls,
round_bl_val_1L_chr = round_bl_val_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl,
seed_1L_int = seed_1L_int)
Sys.sleep(5)
smry_ls$smry_of_ts_mdl_tb
})
return(mdls_smry_tb)
}
make_input_params <- function(ds_tb, # Generalise MAUI
ds_descvs_ls,
header_yaml_args_ls,
maui_params_ls,
predictors_lup,
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
dv_ds_nm_and_url_chr = NULL,
iters_1L_int = 4000L,
mdl_smry_ls = make_mdl_smry_ls(),
options_chr = c("Y", "N"),
output_format_ls = make_output_format_ls(),
path_params_ls = NULL,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
prior_ls = NULL,
seed_1L_int = 12345,
scndry_anlys_params_ls = NULL,
write_new_dir_1L_lgl = T){
path_params_ls <- ready4show::make_path_params_ls(use_fake_data_1L_lgl = ds_descvs_ls$is_fake_1L_lgl,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
dv_ds_nm_and_url_chr = dv_ds_nm_and_url_chr,
options_chr = options_chr,
write_new_dir_1L_lgl = write_new_dir_1L_lgl)
params_ls_ls <- make_analysis_core_params_ls(ds_descvs_ls = ds_descvs_ls,
output_format_ls = output_format_ls,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
mdl_smry_ls = mdl_smry_ls,
control_ls = control_ls,
iters_1L_int = iters_1L_int,
prior_ls = prior_ls,
seed_1L_int = seed_1L_int) %>%
make_valid_params_ls_ls(ds_tb = ds_tb,
maui_params_ls = maui_params_ls,
path_params_ls = path_params_ls)
params_ls_ls$header_yaml_args_ls <- header_yaml_args_ls
params_ls_ls$output_format_ls <- output_format_ls
params_ls_ls$scndry_anlys_params_ls <- scndry_anlys_params_ls
return(params_ls_ls)
}
make_knit_pars_ls <- function (rltv_path_to_data_dir_1L_chr, mdl_types_chr, predr_vars_nms_ls,
output_type_1L_chr = "HTML", mdl_types_lup = NULL, plt_types_lup = NULL,
plt_types_chr = NA_character_, section_type_1L_chr = "#")
{
if (is.null(mdl_types_lup))
utils::data(mdl_types_lup, envir = environment())
if (is.null(plt_types_lup))
utils::data(plt_types_lup, envir = environment())
if(is.na(plt_types_chr)){
plt_types_chr <- plt_types_lup$short_name_chr
}
paths_to_all_data_fls_chr <- list.files(rltv_path_to_data_dir_1L_chr,full.names = T)
lab_idx_dbl <- 1:(length(mdl_types_chr) * length(predr_vars_nms_ls))
knit_pars_ls <- purrr::pmap(list(predr_vars_nms_ls,
split(lab_idx_dbl,
ceiling(seq_along(lab_idx_dbl)/length(mdl_types_chr))),
make_mdl_nms_ls(predr_vars_nms_ls,
mdl_types_chr = mdl_types_chr)),
~{
mdl_nms_chr <- ..3
mdl_data_paths_ls <- mdl_nms_chr %>%
purrr::map(~paths_to_all_data_fls_chr[stringr::str_detect(paths_to_all_data_fls_chr,.x)]) %>%
stats::setNames(mdl_nms_chr)
paths_to_mdls_chr <- mdl_data_paths_ls %>%
purrr::map_chr(~ifelse(identical(.x[endsWith(.x,".RDS")],character(0)),
NA_character_,
.x[endsWith(.x,".RDS")]
)) %>% unname()
paths_to_mdl_plts_ls <- mdl_data_paths_ls %>%
purrr::map(~{
paths_to_all_plots_chr <- .x[endsWith(.x,".png")]
plt_types_chr %>%
purrr::map(~ {
sfx_1L_chr <- paste0(.x,".png")
paths_to_all_plots_chr[paths_to_all_plots_chr %>%
purrr::map_lgl(~endsWith(.x,sfx_1L_chr))][paths_to_all_plots_chr[paths_to_all_plots_chr %>%
purrr::map_lgl(~endsWith(.x,sfx_1L_chr))] %>%
nchar() %>%
which.min()]
}) %>%
purrr::flatten_chr() %>% unique()
})
mdl_tots_chr <- paste0(..1[1], ifelse(is.na(..1[2]),
"",
paste(" with ", ..1[2])),
" ",
mdl_types_chr %>% purrr::map_chr(~paste0(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "mixed_type_chr",
evaluate_1L_lgl = F),
" with ",
ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F))))
section_tots_chr <- paste0(section_type_1L_chr, " ", mdl_tots_chr)
plt_nms_ls <- paths_to_mdl_plts_ls %>% purrr::map2(mdl_tots_chr,~{
paths_to_mdl_plts_chr <- .x
mdl_tot_1L_chr <- .y
transform_1L_lgl <- paths_to_mdl_plts_chr %>% endsWith("_coefs.png") %>% any()
if(paths_to_mdl_plts_chr %>% endsWith("_hetg.png") %>% any())
transform_1L_lgl <- F # ALL OF THIS TFMN LOGIC CAN BE BINNED WHEN NEW CATEGORY OF PLOT TYPE IS ADDED.
plt_types_chr %>% purrr::map(~{
if(endsWith(paths_to_mdl_plts_chr,paste0("_",.x,".png")) %>% any()){
paste0(mdl_tot_1L_chr,
" ",
ifelse(transform_1L_lgl & .x == "coefs",
"population and group level effects",
ready4::get_from_lup_obj(plt_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "long_name_chr",
evaluate_1L_lgl = F)))
}else{
character(0)
}}) %>% purrr::flatten_chr()
})
list(plt_nms_ls = plt_nms_ls,
paths_to_mdls_chr = paths_to_mdls_chr,
tbl_captions_chr = mdl_tots_chr,
label_stubs_chr = paste0("lab", ..2),
output_type_1L_chr = output_type_1L_chr,
section_tots_chr = section_tots_chr,
paths_to_mdl_plts_ls = paths_to_mdl_plts_ls)
}) %>%
stats::setNames(predr_vars_nms_ls %>% purrr::map_chr(~paste(.x,collapse="_")))
return(knit_pars_ls)
}
make_lngl_ttu_r2_text <- function(results_ls, # rename / generalise TTU
part_int = 1){
if(1 %in% part_int){
text_1L_chr <- ifelse(length(results_ls$candidate_predrs_chr) == 1,
"",
paste0("In ",
ifelse(length(results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique())>1,
"",
ifelse(nrow(results_ls$ttu_lngl_ls$best_mdls_tb)==2,
"both ",
"all ")),
results_ls$ttu_lngl_ls$best_mdls_tb$model_type %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" models, the prediction models using ",
ifelse(length(results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique())==1,
results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique(),
results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" respectively")),
" had the highest R^2^ (",
results_ls$ttu_lngl_ls$best_mdls_tb$r2_dbl %>%
stringr::str_squish() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
")"))
}else{
text_1L_chr <- ""
}
if(2 %in% part_int){
mdl_types_chr <- results_ls$ttu_lngl_ls$best_mdls_tb$model_type
mdl_r2_var_nms_chr <- intersect(results_ls$tables_ls$ind_preds_coefs_tbl %>% names(),
c("R2_OLS_CLL","R2_GLM_GSN_LOG"))
mdl_r2_mins_dbl <- mdl_r2_var_nms_chr %>%
purrr::map_dbl(~results_ls$tables_ls$ind_preds_coefs_tbl %>%
dplyr::filter(!is.na(!!rlang::sym(.x))) %>%
dplyr::pull(!!rlang::sym(.x)) %>%
as.numeric() %>%
min())
mdl_r2_maxs_dbl <- mdl_r2_var_nms_chr %>%
purrr::map_dbl(~results_ls$tables_ls$ind_preds_coefs_tbl %>%
dplyr::filter(!is.na(!!rlang::sym(.x))) %>%
dplyr::pull(!!rlang::sym(.x)) %>%
as.numeric() %>%
max())
part_2_main_1L_chr <- list(mdl_types_chr,
mdl_r2_mins_dbl,
mdl_r2_maxs_dbl,
1:length(mdl_types_chr)) %>%
purrr::pmap_chr(~ paste0(ifelse(..4 == 1,"R^2^ was ",""),
ifelse(length(results_ls$candidate_predrs_chr) == 1,
paste0(,..2, " for the "),
paste0(ifelse(..2==..3,
paste0("",..2),
paste0("between ",..2," and ",..3," for all ")))),
..1,
ifelse(length(results_ls$candidate_predrs_chr) == 1,
paste0(""),
paste0("s"))
)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
text_1L_chr <- paste0(text_1L_chr,
ifelse(1 %in% part_int,". ",""),
part_2_main_1L_chr ,
ifelse(part_2_main_1L_chr=="","","."))
}
return(text_1L_chr)
}
make_lngl_ttu_with_covars_text <- function(results_ls){ # rename / generalise TTU
text_1L_chr <- ifelse((is.na(results_ls$ttu_lngl_ls$incld_covars_chr[1]) | length(results_ls$ttu_lngl_ls$incld_covars_chr) == 0),
"",
paste0("We also evaluated models with ",
results_ls$ttu_lngl_ls$incld_covars_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" at baseline"),
" and ",
results_ls$ttu_lngl_ls$incld_covars_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" change from baseline"),
" added to ",
names(results_ls$study_descs_ls$predr_ctgs_ls) %>%
tolower() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" predictors"))
return(text_1L_chr )
}
make_maui_params_ls <- function(maui_itm_short_nms_chr, # Leave in TTU?
maui_domains_pfxs_1L_chr = NULL,
maui_scoring_fn = NULL,
short_and_long_nm = NULL,
utl_min_val_1L_dbl = -1){
if(is.null(maui_scoring_fn)){
maui_scoring_fn <- function(data_tb,
maui_item_pfx_1L_chr,
id_var_nm_1L_chr,
utl_wtd_var_nm_1L_chr,
utl_unwtd_var_nm_1L_chr){
data_tb %>%
dplyr::mutate(`:=`(!!rlang::sym(utl_unwtd_var_nm_1L_chr),
rowSums(dplyr::across(dplyr::starts_with(maui_item_pfx_1L_chr))))) %>%
dplyr::filter(!is.na(!!rlang::sym(utl_unwtd_var_nm_1L_chr)))
}
}
maui_params_ls <- list(maui_domains_pfxs_1L_chr = maui_domains_pfxs_1L_chr,
maui_itm_short_nms_chr = maui_itm_short_nms_chr,
maui_scoring_fn = maui_scoring_fn,
short_and_long_nm = short_and_long_nm,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
return(maui_params_ls)
}
make_mdl <- function (data_tb,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr, covar_var_nms_chr = NA_character_, mdl_type_1L_chr = "OLS_NTF",
mdl_types_lup = NULL, control_1L_chr = NA_character_, start_1L_chr = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment())
data_tb <- transform_ds_for_mdlng(data_tb, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr, depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr)
if (is.null(start_1L_chr)) {
start_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "start_chr", evaluate_1L_lgl = F)
}
if (!is.na(control_1L_chr)) {
idx_1L_int <- 1 + stringi::stri_locate_last_fixed(mdl_type_1L_chr,
"_")[1, 1] %>% as.vector()
link_1L_chr <- get_link_from_tfmn(stringr::str_sub(mdl_type_1L_chr, start = idx_1L_int))
}
mdl_1L_chr <- paste0(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "fn_chr", evaluate_1L_lgl = F), "(",
transform_depnt_var_nm(depnt_var_nm_1L_chr, tfmn_1L_chr = tfmn_1L_chr),
" ~ ", predr_var_nm_1L_chr, ifelse(is.na(covar_var_nms_chr[1]),
"", paste0(" + ", paste0(covar_var_nms_chr, collapse = " + "))),
", data = data_tb", ifelse(!is.na(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr", evaluate_1L_lgl = F)),
paste0(", family = ", ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr", evaluate_1L_lgl = F)),
""), ifelse((!is.na(start_1L_chr)|(is.na(start_1L_chr) & !is.na(control_1L_chr))), ", ", ""), ifelse(!is.na(control_1L_chr),
paste0("link=\"", link_1L_chr, "\",control=", control_1L_chr,
"("), ""), ifelse(!is.na(start_1L_chr), paste0("start=c(",
start_1L_chr, ")"), ""), ifelse(!is.na(control_1L_chr),
")", ""), ")")
model_mdl <- eval(parse(text = mdl_1L_chr))
return(model_mdl)
}
make_mdl_coef_range_text <- function(coef_ratios_dbl,
nbr_of_digits_1L_int = 2L){
if(length(coef_ratios_dbl) == 1){
coef_range_text_chr <- as.character(round(coef_ratios_dbl, nbr_of_digits_1L_int))
}else{
min_1L_dbl <- round(min(coef_ratios_dbl), nbr_of_digits_1L_int)
max_1L_dbl <- round(max(coef_ratios_dbl), nbr_of_digits_1L_int)
coef_range_text_chr <- paste0("between ", min_1L_dbl," and ", max_1L_dbl)
}
return(coef_range_text_chr)
}
make_mdl_coef_ratio_ls <- function(mdl_ingredients_ls,
predr_ctgs_ls = NULL){
predrs_chr <- mdl_ingredients_ls$predictors_lup$short_name_chr
mdl_type_chr <- mdl_ingredients_ls$mdls_smry_tb$Model %>%
unique() %>%
purrr::map_chr(~get_mdl_type_from_nm(.x,
mdl_types_lup = mdl_ingredients_ls$mdl_types_lup)) %>%
unique()
main_mdls_ls <- predrs_chr %>% purrr::map(~paste0(paste0(.x,"_1_"),
mdl_type_chr))
ratios_ls <- main_mdls_ls %>%
purrr::map2(predrs_chr, ~{
mdls_chr <- .x
predr_1L_chr <- .y
mdls_chr %>% purrr::map_dbl(~{
coefs_dbl <- mdl_ingredients_ls$mdls_smry_tb %>% dplyr::filter(Model %in% .x) %>%
dplyr::filter(Parameter %in% paste0(predr_1L_chr,(c(" baseline", " scaled", " unscaled",
" change")))) %>%
dplyr::pull(Estimate)
coefs_dbl[2]/coefs_dbl[1]
})
}
) %>% stats::setNames(predrs_chr)
mdl_coef_ratios_ls = list(mean_ratios_dbl = ratios_ls %>% purrr::map_dbl(~mean(.x)))
if(!is.null(predr_ctgs_ls)){
append_ls <- purrr::map(predr_ctgs_ls,
~ mdl_coef_ratios_ls$mean_ratios_dbl[predrs_chr %in% .x]) %>%
stats::setNames(names(predr_ctgs_ls))
mdl_coef_ratios_ls <- append(mdl_coef_ratios_ls, append_ls)
}
return(mdl_coef_ratios_ls)
}
make_mdl_desc_lines <- function (outp_smry_ls,
mdl_nm_1L_chr,
output_type_1L_chr = "PDF"){
mdl_smry_tb <- outp_smry_ls$mdls_smry_tb %>% dplyr::filter(Model ==
mdl_nm_1L_chr)
predictors_chr <- mdl_smry_tb$Parameter[!mdl_smry_tb$Parameter %in%
c("SD (Intercept)", "Intercept", "R2", "RMSE", "Sigma")] %>%
purrr::map_chr(~stringr::str_remove(.x, " baseline") %>%
stringr::str_remove(" change") %>% stringr::str_remove(" scaled") %>% stringr::str_remove(" unscaled")) %>%
unique()
predictors_desc_chr <- predictors_chr %>% purrr::map_chr(~{
scaling_1L_dbl <- ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
match_value_xx = .x, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "mdl_scaling_dbl", evaluate_1L_lgl = F)
paste0(.x, " (", ready4::get_from_lup_obj(outp_smry_ls$dictionary_tb,
match_value_xx = .x, match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_desc_chr", evaluate_1L_lgl = F),
ifelse(scaling_1L_dbl == 1, "", paste0(" (multiplied by ",
scaling_1L_dbl, ")")), ")")
})
if (length(predictors_desc_chr) > 1)
predictors_desc_chr <- paste0(c(paste0("\n - ", predictors_desc_chr[-length(predictors_desc_chr)],
collapse = ";"), paste0("\n - ", predictors_desc_chr[length(predictors_desc_chr)])),
collapse = "; and")
mdl_desc_lines_chr <- paste0(paste0("This model predicts values at two timepoints for ",
ready4::get_from_lup_obj(outp_smry_ls$dictionary_tb,
match_value_xx = outp_smry_ls$depnt_var_nm_1L_chr,
match_var_nm_1L_chr = "var_nm_chr", target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F),
". The predictor variables are ",
"baseline values and subsequent changes in ", collapse = ""),
predictors_desc_chr,
". ",
"The catalogue reference for this model is ",
ifelse(output_type_1L_chr == "PDF",
paste0("\\texttt{\\detokenize{",
mdl_nm_1L_chr, "}}"),
mdl_nm_1L_chr),
".")
return(mdl_desc_lines_chr)
}
make_mdl_nms_ls <- function (predr_vars_nms_ls, mdl_types_chr)
{
mdl_nms_ls <- purrr::map2(predr_vars_nms_ls, make_unique_ls_elmt_idx_int(predr_vars_nms_ls),
~paste0(.x[1], "_", ifelse(is.na(.x[2]), "", paste0(.x[2],
"_")), .y, "_", mdl_types_chr))
return(mdl_nms_ls)
}
make_mdl_smry_elmt_tbl <- function (mat, ctg_chr)
{
tb <- mat %>% tibble::as_tibble() %>% dplyr::mutate(Parameter = rownames(mat)) %>%
dplyr::select(Parameter, dplyr::everything())
mdl_elmt_sum_tb <- tb %>% dplyr::filter(F) %>% tibble::add_case(Parameter = ctg_chr) %>%
dplyr::bind_rows(tb)
return(mdl_elmt_sum_tb)
}
make_mdl_smry_ls <- function(mdl_types_lup = get_cndts_for_mxd_mdls(),
mdl_types_chr = NULL,
choose_from_pfx_chr = NULL,
folds_1L_int = 10L,
max_nbr_of_boruta_mdl_runs_int = 300L){
if(is.null(mdl_types_lup))
data("mdl_types_lup",
package = "specific", #
envir = environment())
if(is.null(mdl_types_chr))
mdl_types_chr <- mdl_types_lup$short_name_chr
if(is.null(choose_from_pfx_chr))
choose_from_pfx_chr <- stringr::word(mdl_types_lup$short_name_chr,1,sep="\\_") %>% unique()
mdl_smry_ls <- list(mdl_types_lup = mdl_types_lup,
mdl_types_chr = mdl_types_chr,
choose_from_pfx_chr = choose_from_pfx_chr,
folds_1L_int = folds_1L_int,
max_nbr_of_boruta_mdl_runs_int = max_nbr_of_boruta_mdl_runs_int)
return(mdl_smry_ls)
}
make_mdl_type_smry_tbl <- function(mdls_tb,
mdl_nms_chr,
mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = T){
mdl_type_smry_tbl_tb <- mdl_nms_chr %>%
purrr::map_dfr(~make_sngl_mdl_smry_tb(mdls_tb,
mdl_nm_1L_chr = .x,
mdl_type_1L_chr = mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = add_mdl_nm_sfx_1L_lgl))
return(mdl_type_smry_tbl_tb)
}
make_mdls_ls <- function(outp_smry_ls,
mdls_tb){
mdls_chr <- mdls_tb$Model %>% unique()
mdls_ls <- outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map(~mdls_chr[mdls_chr %>% endsWith(.x)])
return(mdls_ls)
}
make_mdls_smry_tbls_ls <- function(outp_smry_ls,
nbr_of_digits_1L_int = 2L){
mdls_smry_tb <- outp_smry_ls$mdls_smry_tb %>%
dplyr::mutate(dplyr::across(c("Estimate","SE"),
~ round(.x,nbr_of_digits_1L_int) %>%
format(nsmall = nbr_of_digits_1L_int))) %>%
dplyr::mutate(`95% CI` = `95% CI` %>% transform_chr_digit_pairs(nbr_of_digits_1L_int = nbr_of_digits_1L_int)) # Fix
rownames(mdls_smry_tb) <- NULL
indpt_predrs_mdls_tb <- mdls_smry_tb %>% dplyr::filter(Model %in% (paste0(outp_smry_ls$predr_cmprsn_tb$predr_chr,"_1_") %>% purrr::map(~paste0(.x,
outp_smry_ls$prefd_mdl_types_chr)) %>% purrr::flatten_chr()))
covar_mdls_tb <- mdls_smry_tb %>% dplyr::filter(!Model %in% indpt_predrs_mdls_tb$Model)
mdl_types_chr <- indpt_predrs_mdls_tb$Model %>% purrr::map_chr(~get_mdl_type_from_nm(.x,
mdl_types_lup = outp_smry_ls$mdl_types_lup)) %>%
unique()
prefd_predr_mdl_smry_tb <- mdl_types_chr %>%
purrr::map_dfr(~{
mdl_type_1L_chr <- .x
mdl_type_smry_tb <- indpt_predrs_mdls_tb %>%
dplyr::filter(Model %>% purrr::map_lgl(~endsWith(.x, mdl_type_1L_chr)))
max_r2_dbl <- mdl_type_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::pull(Estimate) %>%
as.numeric() %>%
abs() %>%
max()
prefd_mdl_1L_chr <- mdl_type_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::filter(as.numeric(Estimate) == max_r2_dbl) %>%
dplyr::pull(Model) %>%
purrr::pluck(1)
mdl_type_smry_tb %>%
dplyr::filter(Model == prefd_mdl_1L_chr)
})
mdls_smry_tbls_ls <- list(indpt_predrs_mdls_tb = indpt_predrs_mdls_tb,
covar_mdls_tb = covar_mdls_tb,
prefd_predr_mdl_smry_tb = prefd_predr_mdl_smry_tb)
return(mdls_smry_tbls_ls)
}
make_ms_smry_tbls_ls <- function(outp_smry_ls,
mdls_smry_tbls_ls,
covars_mdls_ls,
descv_tbls_ls,
nbr_of_digits_1L_int = 2L){
mdl_types_tables_ls <- purrr::map(1:length(outp_smry_ls$prefd_mdl_types_chr),
~ make_mdl_type_smry_tbl(mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb,
mdl_nms_chr = covars_mdls_ls[[.x]],
mdl_type_1L_chr = outp_smry_ls$prefd_mdl_types_chr[.x],
add_mdl_nm_sfx_1L_lgl = F)) %>%
stats::setNames(1:length(outp_smry_ls$prefd_mdl_types_chr) %>%
purrr::map_chr(~paste0("mdl_type_",.x,"_covar_mdls_tb")))
ms_smry_tbls_ls <- append(mdl_types_tables_ls,
list(ind_preds_coefs_tbl = make_all_mdl_types_smry_tbl(outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$indpt_predrs_mdls_tb),
participant_descs = descv_tbls_ls$cohort_desc_tb,
predd_dist_and_cors = descv_tbls_ls$predr_pars_and_cors_tb,
tenf_prefd_mdl_tb = outp_smry_ls[["smry_of_mdl_sngl_predrs_tb"]] %>%
tibble::as_tibble() %>%
dplyr::mutate(dplyr::across(where(is.numeric), ~ .x %>% purrr::map_dbl(~min(max(.x,-1.1),1.1)))) %>%
transform_tbl_to_rnd_vars(nbr_of_digits_1L_int = nbr_of_digits_1L_int) %>%
dplyr::mutate(dplyr::across(.cols = dplyr::everything(), ~ .x %>%
stringr::str_replace_all("-1.10","< -1.00") %>%
stringr::str_replace_all("1.10","> 1.00"))),
tenf_sngl_predr_tb = make_tfd_sngl_predr_mdls_tb(outp_smry_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)))
return(ms_smry_tbls_ls)
}
make_nbr_included_text <- function(results_ls){
paste0(ifelse(results_ls$cohort_ls$n_inc_1L_dbl == results_ls$cohort_ls$n_all_1l_dbl,
"all ",
paste0(results_ls$cohort_ls$n_inc_1L_dbl,
" out of the ")),
results_ls$cohort_ls$n_all_1l_dbl,
" participants with complete ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" data")
}
make_nbr_at_fup_text <- function(results_ls){
nbr_at_fup_1L_chr <- paste0("There were ",
results_ls$cohort_ls$n_fup_1L_dbl,
" participants (",
(results_ls$cohort_ls$n_fup_1L_dbl / results_ls$cohort_ls$n_inc_1L_dbl * 100) %>% round(1),
"%) who completed ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" questions at the follow-up survey ",
results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr,
" after baseline assessment."
)
return(nbr_at_fup_1L_chr)
}
make_paths_to_ms_smry_plts_ls <- function(output_data_dir_1L_chr,
outp_smry_ls,
additional_paths_chr = "/dens_and_sctr.png"){
paths_to_ms_smry_plts_ls = list(combined_utl = paste0(output_data_dir_1L_chr,"/_Descriptives/combined_utl.png"),
composite = paste0(output_data_dir_1L_chr,additional_paths_chr[1]),
items = paste0(output_data_dir_1L_chr,"/_Descriptives/qstn_rspns.png"),
density = paste0(output_data_dir_1L_chr,"/",outp_smry_ls$file_paths_chr[outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"A_TFMN_CMPRSN_DNSTY"))]),#paste0(output_data_dir_1L_chr,"/A_TFMN_CMPRSN_DNSTY.png"), #Update
importance = paste0(output_data_dir_1L_chr,"/",outp_smry_ls$file_paths_chr[outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"B_PRED_CMPRSN_BORUTA_VAR_IMP"))]))
return(paths_to_ms_smry_plts_ls)
}
make_plot_fn_and_args_ls <- function(type_1L_chr,
depnt_var_desc_1L_chr,
args_ls = NULL,
base_size_1L_dbl = 11,
brms_mdl = NULL,
correspondences_lup = NULL,
depnt_var_nm_1L_chr = NULL,
new_var_nm_1L_chr = NA_character_,
predn_type_1L_chr = NULL,
round_var_nm_1L_chr = NULL,
sd_dbl = NA_real_,
seed_1L_dbl = 23456,
sfx_1L_chr = " from table",
table_predn_mdl = NULL,
tfmn_1L_chr = "NTF",
tfd_data_tb = NULL,
utl_min_val_1L_dbl = -1,
x_lbl_1L_chr = NA_character_,
y_lbl_1L_chr = NA_character_){
if(!is.null(brms_mdl)){
set.seed(seed_1L_dbl)
tfd_data_tb <- transform_ds_for_all_cmprsn_plts(tfd_data_tb = tfd_data_tb,
model_mdl = brms_mdl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
is_brms_mdl_1L_lgl = inherits(brms_mdl,"brmsfit"),
predn_type_1L_chr = predn_type_1L_chr,
sd_dbl = NA_real_,
sfx_1L_chr = ifelse(is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
if(!is.null(table_predn_mdl)){
tfd_data_tb <- transform_ds_for_all_cmprsn_plts(tfd_data_tb = tfd_data_tb,
model_mdl = table_predn_mdl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
is_brms_mdl_1L_lgl = F,
predn_type_1L_chr = predn_type_1L_chr,
sd_dbl = sd_dbl,
sfx_1L_chr = ifelse(!is.null(brms_mdl),
" from table",
sfx_1L_chr),
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
}
}
ref_idx_1L_int <- which(type_1L_chr == c("coefs", "hetg",
"dnst", "sctr_plt",
"sim_dnst", "sim_sctr",
"cnstrd_dnst", "cnstrd_sctr_plt",
"cnstrd_sim_dnst", "cnstrd_sim_sctr"))
if (ref_idx_1L_int %in% c(3,5,7,9)) {
plt_fn <- plot_obsd_predd_dnst
fn_args_ls <- list(tfd_data_tb = tfd_data_tb,
base_size_1L_dbl = base_size_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
new_var_nm_1L_chr = new_var_nm_1L_chr,
predd_val_var_nm_1L_chr = ifelse(ref_idx_1L_int %in% c(3,7),
transform_predd_var_nm("Predicted",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 3, ####
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 5,
NA_real_,
utl_min_val_1L_dbl))),
cmprsn_predd_var_nm_1L_chr = ifelse(is.null(table_predn_mdl),
NA_character_,
ifelse(ref_idx_1L_int %in% c(3,7), ##
transform_predd_var_nm("Predicted",
sfx_1L_chr = " from table",
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 3, ##
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr =" from table",
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 5, ##
NA_real_,
utl_min_val_1L_dbl)))))
}else{
plt_fn <- plot_obsd_predd_sctr_cmprsn
fn_args_ls <- list(tfd_data_tb = tfd_data_tb,
base_size_1L_dbl = base_size_1L_dbl,
correspondences_lup = correspondences_lup,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
predd_val_var_nm_1L_chr = ifelse(ref_idx_1L_int %in% c(4,8),
transform_predd_var_nm("Predicted",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 4,
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 6,
NA_real_,
utl_min_val_1L_dbl))),
args_ls = args_ls,
x_lbl_1L_chr = x_lbl_1L_chr,
y_lbl_1L_chr = y_lbl_1L_chr)
}
plot_fn_and_args_ls <- list(plt_fn = plt_fn,
fn_args_ls = fn_args_ls)
return(plot_fn_and_args_ls)
}
make_predn_ds_with_one_predr <- function(model_mdl,
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr, predr_vals_dbl, predn_type_1L_chr = NULL)
{
predn_ds_tb <- tibble::tibble(`:=`(!!rlang::sym(predr_var_nm_1L_chr),
predr_vals_dbl))
predn_ds_tb <- predn_ds_tb %>% dplyr::mutate(`:=`(!!rlang::sym(depnt_var_nm_1L_chr),
stats::predict(model_mdl, newdata = predn_ds_tb, type = predn_type_1L_chr) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr,
tfmn_is_outp_1L_lgl = T)))
return(predn_ds_tb)
}
make_predr_ctgs_ls <- function(outp_smry_ls,
include_idx_int = NULL){
predictors_chr <- outp_smry_ls$predr_vars_nms_ls %>% purrr::flatten_chr() %>% unique()
categories_chr <- predictors_chr %>%
purrr::map_chr(~outp_smry_ls$dictionary_tb %>%
ready4::get_from_lup_obj(match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_ctg_chr",
evaluate_1L_lgl = F)) %>% unique()
predr_ctgs_ls <- categories_chr %>% purrr::map(~outp_smry_ls$dictionary_tb %>%
ready4use::remove_labels_from_ds() %>%
dplyr::filter(var_ctg_chr == .x) %>%
dplyr::pull(var_nm_chr) %>%
intersect(predictors_chr)) %>%
stats::setNames(categories_chr)
if(!is.null(include_idx_int)){
predr_ctgs_ls <- include_idx_int %>%
purrr::map(~predr_ctgs_ls %>% purrr::pluck(.x)) %>%
stats::setNames(categories_chr[include_idx_int])
}
return(predr_ctgs_ls)
}
make_predr_vals <- function (predr_var_nm_1L_chr, candidate_predrs_lup = NULL)
{
if (is.null(candidate_predrs_lup)) {
utils::data("candidate_predrs_lup", envir = environment())
}
args_ls <- purrr::map_dbl(names(candidate_predrs_lup)[3:4],
~candidate_predrs_lup %>% ready4::get_from_lup_obj(match_value_xx = predr_var_nm_1L_chr,
match_var_nm_1L_chr = "short_name_chr", target_var_nm_1L_chr = .x,
evaluate_1L_lgl = F)) %>% as.list()
predr_vals_dbl <- rlang::exec(.fn = seq, !!!args_ls)
return(predr_vals_dbl)
}
make_predr_vars_nms_ls <- function (main_predrs_chr, covars_ls, combinations_1L_lgl = F, existing_predrs_ls = NULL, max_nbr_of_covars_1L_int = integer(0))
{
predr_vars_nms_ls <- covars_ls %>% purrr::map(~{
covars_chr <- .x
purrr::map(main_predrs_chr, ~list(c(.x), c(.x, covars_chr) %>% purrr::discard(is.na))) %>%
purrr::flatten()
}) %>% purrr::flatten() %>% unique()
predr_vars_nms_ls <- predr_vars_nms_ls[order(sapply(predr_vars_nms_ls,
length))]
if(combinations_1L_lgl){
main_predrs_ls <- predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~length(.x)==1)]
combinations_from_chr <- setdiff(predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~length(.x)>1)] %>% purrr::flatten_chr(), main_predrs_chr)
combinations_ls <- 1:(ifelse(identical(max_nbr_of_covars_1L_int,integer(0)),length(combinations_from_chr),min(max_nbr_of_covars_1L_int,length(combinations_from_chr)))) %>%
purrr::map(~gtools::combinations(length(combinations_from_chr),.x,combinations_from_chr) %>% t() %>% as.data.frame() %>% as.list() %>% unname()) %>% purrr::flatten()
combinations_ls <- main_predrs_ls %>%
purrr::map(~
{
main_1L_chr <- .x
combinations_ls %>%
purrr::map(~c(main_1L_chr,.x))
}) %>% purrr::flatten()
predr_vars_nms_ls <- append(main_predrs_ls,combinations_ls)
}
if(!is.null(existing_predrs_ls)){
predr_vars_nms_ls <- predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~{
test_chr <- .x
!any(existing_predrs_ls %>% purrr::map_lgl(~identical(.x,test_chr))
)})]
}
return(predr_vars_nms_ls)
}
make_predrs_for_best_mdls <- function(outp_smry_ls,
old_nms_chr = NULL,
new_nms_chr = NULL){
ordered_mdl_nms_chr <- outp_smry_ls$mdls_smry_tb %>% dplyr::filter(Parameter=="R2") %>% dplyr::arrange(dplyr::desc(Estimate)) %>% dplyr::pull(Model)
ind_predr_mdls_by_mdl_type_ls <- outp_smry_ls$prefd_mdl_types_chr %>% purrr::map(~{
mdl_type_1L_chr <- .x
paste0(outp_smry_ls$predr_cmprsn_tb$predr_chr,"_1_") %>% purrr::map(~paste0(.x,
mdl_type_1L_chr)) %>% purrr::flatten_chr()
})
ordered_mdls_by_type_ls <- ind_predr_mdls_by_mdl_type_ls %>%
purrr::map(~{
ind_predr_mdls_chr <- .x
ordered_mdl_nms_chr[ordered_mdl_nms_chr %>% purrr::map_lgl(~.x %in% ind_predr_mdls_chr)]
})
predrs_for_best_mdls_chr <- ordered_mdls_by_type_ls %>% purrr::map2_chr(outp_smry_ls$prefd_mdl_types_chr,
~{
.x[1] %>% stringr::str_remove(paste0("_1_",.y))
})
if(!is.null(old_nms_chr)){
predrs_for_best_mdls_chr <- transform_predr_nm_part_of_phrases(predrs_for_best_mdls_chr,
old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
}
return(predrs_for_best_mdls_chr)
}
make_prefd_mdls_vec <- function (smry_of_sngl_predr_mdls_tb,
choose_from_pfx_chr = c("BET","GLM", "OLS"),
mdl_types_lup = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment(),
package = "specific") #
ordered_mdl_types_chr <- dplyr::inner_join(smry_of_sngl_predr_mdls_tb %>%
dplyr::select(Model) %>%
dplyr::rename(long_name_chr = Model),
mdl_types_lup,
by = "long_name_chr") %>%
dplyr::pull(short_name_chr)
prefd_mdls_chr <- purrr::map_chr(choose_from_pfx_chr,
~ordered_mdl_types_chr[startsWith(ordered_mdl_types_chr,
.x)][1])
prefd_mdls_chr <- prefd_mdls_chr[order(prefd_mdls_chr %>% purrr::map_int(~which(ordered_mdl_types_chr==.x)))]
#prefd_mdls_chr <- prefd_mdls_chr[-max((1:length(prefd_mdls_chr))[prefd_mdls_chr %>% purrr::map_lgl(~(startsWith(.x,"BET") | startsWith(.x,"GLM")))])]
return(prefd_mdls_chr)
}
make_prmry_analysis_params_ls <- function(analysis_core_params_ls,
candidate_covar_nms_chr = NA_character_,
ds_tb,
path_params_ls,
maui_params_ls,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
raw_ds_tfmn_fn = NULL,
subtitle_1L_chr = "Methods Report 1: Analysis Program (Primary Analysis)",
utl_class_fn_1L_chr = "as.numeric"){
if(is.na(analysis_core_params_ls$candidate_covar_nms_chr[1]) & !is.na(candidate_covar_nms_chr[1])){
analysis_core_params_ls$candidate_covar_nms_chr <- candidate_covar_nms_chr
} # This logic is required to ensure soft deprecated arguments used in manuscript continue to work.
if(is.null(analysis_core_params_ls$prefd_covars_chr) & !is.null(prefd_covars_chr)){
analysis_core_params_ls$prefd_covars_chr <- prefd_covars_chr
}
if(is.null(analysis_core_params_ls$prefd_mdl_types_chr) & !is.null(prefd_mdl_types_chr)){
analysis_core_params_ls$prefd_mdl_types_chr <- prefd_mdl_types_chr
}
prmry_analysis_params_ls <- list(ds_tb = ds_tb,
raw_ds_tfmn_fn = raw_ds_tfmn_fn,
subtitle_1L_chr = subtitle_1L_chr,
utl_class_fn_1L_chr = utl_class_fn_1L_chr) %>%
append(analysis_core_params_ls) %>%
append(path_params_ls[1:2]) %>%
append(maui_params_ls)
return(prmry_analysis_params_ls)
}
make_psych_predrs_lup <- function(){ # Rename - example
predictors_lup <- TTU_predictors_lup(make_pt_TTU_predictors_lup(short_name_chr = c("K10_int","Psych_well_int"),
long_name_chr = c("Kessler Psychological Distress - 10 Item Total Score",
"Overall Wellbeing Measure (Winefield et al. 2012)"),
min_val_dbl = c(10,18),
max_val_dbl = c(50,90),
class_chr = "integer",
increment_dbl = 1,
class_fn_chr = "integer",
mdl_scaling_dbl = 0.01,
covariate_lgl = F))
return(predictors_lup)
}
make_random_forest_text <- function(results_ls,
for_abstract_1L_lgl = F){
if(for_abstract_1L_lgl){
text_1L_chr <- ifelse(length(results_ls$ttu_cs_ls$rf_seq_dscdng_chr) > 1,
paste0(ifelse(results_ls$ttu_cs_ls$mdl_predrs_and_rf_seqs_cmprsn_1L_chr == "is consistent",
" and the random forest model",
paste0(", while ",
results_ls$ttu_cs_ls$rf_seq_dscdng_chr[1],
" was the most \'important\' predictor in the random forest model"))),
"")
}else{
text_1L_chr <- ifelse(length(results_ls$ttu_cs_ls$rf_seq_dscdng_chr) > 1,
paste0("This ",
results_ls$ttu_cs_ls$mdl_predrs_and_rf_seqs_cmprsn_1L_chr,
" with the random forest model in which ",
results_ls$ttu_cs_ls$rf_seq_dscdng_chr[1],
" was found to be the most \'important\' predictor"),
"")
}
return(text_1L_chr)
}
make_ranked_predrs_ls <- function(descv_tbls_ls,
old_nms_chr = NULL,
new_nms_chr = NULL){
unranked_predrs_chr <- rownames(descv_tbls_ls[["bl_cors_tb"]])[-1]
if(!is.null(old_nms_chr))
unranked_predrs_chr <- unranked_predrs_chr %>%
transform_predr_nm_part_of_phrases(old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
ranks_dbl <- descv_tbls_ls[["bl_cors_tb"]][2:nrow(descv_tbls_ls[["bl_cors_tb"]]),1] %>%
purrr::map_dbl(~{
vec_dbl <- regmatches(.x, gregexpr("[[:digit:]]+", .x)) %>% unlist() %>% as.numeric()
vec_dbl[1]+vec_dbl[2]/100
}) %>% rank()
unique_ranks_dbl <- unique(ranks_dbl) %>% sort(decreasing = T)
ranked_predrs_chr <- purrr::map(unique_ranks_dbl, ~ unranked_predrs_chr[ranks_dbl == .x]) %>% purrr::flatten_chr()
ranked_predrs_ls <- list(unranked_predrs_chr = unranked_predrs_chr,
ranked_predrs_chr = ranked_predrs_chr)
return(ranked_predrs_ls)
}
make_results_ls <- function(spine_of_results_ls = NULL, # CORE OF S4 Classes - rename ts to lngl # and metamorphose methods
abstract_args_ls = NULL,
consent_1L_chr = "",
consent_indcs_int = 1L,
depnt_var_min_val_1L_dbl = numeric(0),
dv_ds_nm_and_url_chr = NULL,
options_chr = c("Y", "N"),
output_format_ls = NULL,
params_ls_ls = NULL,
path_params_ls = NULL,
study_descs_ls = NULL,
fn_ls = NULL,
include_idx_int = NULL,
var_nm_change_lup = NULL,
ctgl_vars_regrouping_ls = NULL,
make_cmpst_plt_1L_lgl = T,
outp_smry_ls = NULL,
sig_covars_some_predrs_mdls_tb = NULL,
sig_thresh_covars_1L_chr = NULL,
version_1L_chr = NULL){
if(is.null(spine_of_results_ls)){
spine_of_results_ls <- make_results_ls_spine(output_format_ls = output_format_ls,
params_ls_ls = params_ls_ls,
path_params_ls = path_params_ls,
study_descs_ls = study_descs_ls,
fn_ls = fn_ls,
include_idx_int = include_idx_int,
outp_smry_ls = outp_smry_ls,
var_nm_change_lup = var_nm_change_lup)
}
mdls_smry_tbls_ls <- make_mdls_smry_tbls_ls(spine_of_results_ls$outp_smry_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int)
covars_mdls_ls <- make_mdls_ls(spine_of_results_ls$outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb)
descv_tbls_ls <- paste0(spine_of_results_ls$output_data_dir_1L_chr,"/",spine_of_results_ls$outp_smry_ls$file_paths_chr[spine_of_results_ls$outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"descv_tbls_ls.RDS"))]) %>% readRDS()
if(make_cmpst_plt_1L_lgl){
composite_plt <- make_cmpst_sctr_and_dnst_plt(spine_of_results_ls$outp_smry_ls,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
output_data_dir_1L_chr = spine_of_results_ls$output_data_dir_1L_chr,
predr_var_nms_chr = spine_of_results_ls$outp_smry_ls$predr_vars_nms_ls[[1]])
ready4::write_with_consent(consented_fn = cowplot::save_plot,
prompt_1L_chr = paste0("Do you confirm that you want to write the file ",
paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
"?"),
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
consented_args_ls = list(filename = paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
plot = composite_plt,
base_height = 20),
consented_msg_1L_chr = paste0("File ",
paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
" has been written."),
declined_msg_1L_chr = "Write request cancelled - no new files have been written.",
options_chr = options_chr)
}
ttu_cs_ls <- make_ttu_cs_ls(spine_of_results_ls$outp_smry_ls,
sig_covars_some_predrs_mdls_tb = sig_covars_some_predrs_mdls_tb,
sig_thresh_covars_1L_chr = sig_thresh_covars_1L_chr)
mdl_types_chr <- mdls_smry_tbls_ls$prefd_predr_mdl_smry_tb$Model %>%
purrr::map_chr(~get_mdl_type_from_nm(.x)) %>%
unique()
ttu_cs_ls$rf_seq_dscdng_chr <- ttu_cs_ls$rf_seq_dscdng_chr %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x))
ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr <- ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x))
ttu_lngl_ls = list(best_mdls_tb = tibble::tibble(model_type = mdl_types_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(spine_of_results_ls$outp_smry_ls$mdl_types_lup,
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "mixed_acronym_chr",
evaluate_1L_lgl = F)),
link_and_tfmn_chr = mdl_types_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(spine_of_results_ls$outp_smry_ls$mdl_types_lup,
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F)),
name_chr = make_predrs_for_best_mdls(spine_of_results_ls$outp_smry_ls,
old_nms_chr = spine_of_results_ls$var_nm_change_lup$old_nms_chr,
new_nms_chr = spine_of_results_ls$var_nm_change_lup$new_nms_chr),
r2_dbl = mdls_smry_tbls_ls$prefd_predr_mdl_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::pull(Estimate)),
cs_ts_ratios_tb = spine_of_results_ls$cs_ts_ratios_tb,
incld_covars_chr = spine_of_results_ls$outp_smry_ls$prefd_covars_chr)
results_ls <- list(abstract_args_ls = abstract_args_ls,
candidate_covars_ls = spine_of_results_ls$candidate_covars_ls,
candidate_predrs_chr = spine_of_results_ls$candidate_predrs_chr,
cohort_ls = make_cohort_ls(descv_tbls_ls,
ctgl_vars_regrouping_ls = ctgl_vars_regrouping_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int),
dv_ds_nm_and_url_chr = dv_ds_nm_and_url_chr,
header_yaml_args_ls = params_ls_ls$header_yaml_args_ls,
hlth_utl_and_predrs_ls = make_hlth_utl_and_predrs_ls(spine_of_results_ls$outp_smry_ls,
descv_tbls_ls = descv_tbls_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int,
old_nms_chr = spine_of_results_ls$var_nm_change_lup$old_nms_chr,
new_nms_chr = spine_of_results_ls$var_nm_change_lup$new_nms_chr),
mdl_coef_ratios_ls = spine_of_results_ls$mdl_coef_ratios_ls,
mdl_ingredients_ls = spine_of_results_ls$mdl_ingredients_ls,
mdls_with_signft_covars_ls = spine_of_results_ls$mdls_with_signft_covars_ls,
output_format_ls = params_ls_ls$output_format_ls,
path_params_ls = params_ls_ls$path_params_ls,
paths_to_figs_ls = make_paths_to_ms_smry_plts_ls(spine_of_results_ls$output_data_dir_1L_chr,
outp_smry_ls = spine_of_results_ls$outp_smry_ls),
predr_var_nms_chr = spine_of_results_ls$outp_smry_ls$predr_vars_nms_ls[[1]] %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x)),
r_version_1L_chr = paste0(spine_of_results_ls$outp_smry_ls$session_ls$R.version$major,
".",
spine_of_results_ls$outp_smry_ls$session_ls$R.version$minor),
study_descs_ls = spine_of_results_ls$study_descs_ls,
tables_ls = make_ms_smry_tbls_ls(spine_of_results_ls$outp_smry_ls,
mdls_smry_tbls_ls = mdls_smry_tbls_ls,
covars_mdls_ls = covars_mdls_ls,
descv_tbls_ls = descv_tbls_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int),
ttu_cs_ls = ttu_cs_ls,
ttu_lngl_ls = ttu_lngl_ls,
ttu_version_1L_chr = spine_of_results_ls$outp_smry_ls$session_ls$otherPkgs$TTU$Version,
var_nm_change_lup = spine_of_results_ls$var_nm_change_lup,
version_1L_chr = version_1L_chr)
results_ls <- transform_tbls_for_covar_nms(results_ls) %>% transform_tbls_for_csnl_mdls()
return(results_ls)
}
make_results_ls_spine <- function(output_format_ls = NULL,
params_ls_ls = NULL,
path_params_ls = NULL,
study_descs_ls,
fn_ls = NULL,
include_idx_int = NULL,
outp_smry_ls = NULL,
var_nm_change_lup = NULL){
output_data_dir_1L_chr <- path_params_ls$paths_ls$output_data_dir_1L_chr
nbr_of_digits_1L_int <- output_format_ls$manuscript_digits_1L_int
if(is.null(var_nm_change_lup)){
var_nm_change_lup <- list(old_nms_chr = NULL,
new_nms_chr = NULL)
}
if(is.null(outp_smry_ls))
outp_smry_ls <- readRDS(paste0(output_data_dir_1L_chr,"/I_ALL_OUTPUT_.RDS"))
mdl_ingredients_ls <- readRDS(paste0(output_data_dir_1L_chr,
"/G_Shareable/Ingredients/mdl_ingredients.RDS"))
if(!is.null(params_ls_ls)){
if(is.null(params_ls_ls$params_ls$candidate_covar_nms_chr) | is.na(params_ls_ls$params_ls$candidate_covar_nms_chr[1])){
candidate_covars_ls <- NULL
}else{
covar_ctgs_chr <- params_ls_ls$params_ls$candidate_covar_nms_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_ctg_chr",
evaluate_1L_lgl = F)) %>%
unique()
candidate_covars_ls <- covar_ctgs_chr %>%
purrr::map(~{
var_desc_chr <- ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_ctg_chr",
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F)
class(var_desc_chr) <- setdiff(class(var_desc_chr), "labelled")
attr(var_desc_chr, "label") <- NULL
var_nm_chr <- ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_ctg_chr",
target_var_nm_1L_chr = "var_nm_chr",
evaluate_1L_lgl = F)
var_desc_chr[var_nm_chr %in% params_ls_ls$params_ls$candidate_covar_nms_chr]
}
) %>%
stats::setNames(covar_ctgs_chr)
}
}else{
candidate_covars_ls <- NULL
}
study_descs_ls$predr_ctgs_ls <- make_predr_ctgs_ls(outp_smry_ls,
include_idx_int = include_idx_int)
mdl_coef_ratios_ls <- make_mdl_coef_ratio_ls(mdl_ingredients_ls,
predr_ctgs_ls = study_descs_ls$predr_ctgs_ls)
mdls_smry_tbls_ls <- make_mdls_smry_tbls_ls(outp_smry_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)
covars_mdls_ls <- make_mdls_ls(outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb)
cs_ts_ratios_tb <- make_cs_ts_ratios_tb(predr_ctgs_ls = study_descs_ls$predr_ctgs_ls,
mdl_coef_ratios_ls = mdl_coef_ratios_ls,
candidate_predrs_chr = params_ls_ls$params_ls$ds_descvs_ls$candidate_predrs_chr,
fn_ls = fn_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)
spine_of_results_ls <- list(candidate_covars_ls = candidate_covars_ls,
candidate_predrs_chr = params_ls_ls$params_ls$ds_descvs_ls$candidate_predrs_chr,
cs_ts_ratios_tb = cs_ts_ratios_tb,
mdls_with_signft_covars_ls = get_mdls_with_signft_covars(outp_smry_ls,
params_ls_ls = params_ls_ls),
outp_smry_ls = outp_smry_ls,
output_data_dir_1L_chr = output_data_dir_1L_chr,
mdl_coef_ratios_ls = mdl_coef_ratios_ls,
mdl_ingredients_ls = mdl_ingredients_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int,
study_descs_ls = study_descs_ls,
var_nm_change_lup = var_nm_change_lup)
return(spine_of_results_ls)
}
make_scaling_fctr_dbl <- function(outp_smry_ls){
scaling_fctr_dbl <- outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>%
unique() %>%
purrr::map_dbl(~ ifelse(.x %in% outp_smry_ls$predictors_lup$short_name_chr,
ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
target_var_nm_1L_chr = "mdl_scaling_dbl",
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F),
1))
return(scaling_fctr_dbl)
}
make_scaling_text <- function(results_ls,
table_1L_chr = "cfscl"){
if(startsWith(table_1L_chr,"cfscl")){
table_df <- results_ls$tables_ls$ind_preds_coefs_tbl
}else{
if(startsWith(table_1L_chr,"coefscovarstype")){
table_df <- results_ls$tables_ls %>%
purrr::pluck(paste0("mdl_type_",
table_1L_chr %>% stringr::str_remove("coefscovarstype"),
"_covar_mdls_tb"))
}
}
predrs_chr <- table_df$Parameter %>% setdiff(c("SD (Intercept)","Intercept")) %>% stringr::str_replace_all(" model","") %>%
stringr::str_replace_all(" baseline","") %>% stringr::str_replace_all(" change","") %>%
stringr::str_replace_all(" scaled","") %>% stringr::str_replace_all(" unscaled","") %>% unique()
predrs_lup <- results_ls$mdl_ingredients_ls$predictors_lup %>%
dplyr::filter(short_name_chr %in% predrs_chr)
scaling_dbl <- predrs_lup$mdl_scaling_dbl %>% unique()
text_1L_chr <- ifelse(all(scaling_dbl==1),
"",
paste0("Note: ",
scaling_dbl %>%
purrr::map_chr(~ {
scaled_predrs_chr <- predrs_lup %>%
dplyr::filter(mdl_scaling_dbl == .x) %>%
dplyr::pull(short_name_chr) %>%
sort() %>%
transform_names(rename_lup = results_ls$var_nm_change_lup)
ifelse(.x ==1,
"",
paste0("The ",
scaled_predrs_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" parameter",
ifelse(length(scaled_predrs_chr) == 1,
" was",
"s were"),
" first multiplied by ",
.x,
"."))
}
) %>%
paste0(collapse = " ")))
return(text_1L_chr)
}
make_scndry_anlys_params <- function(scndry_anlys_params_ls = NULL,
candidate_covar_nms_chr = NULL,
candidate_predrs_chr = NULL,
predictors_lup = NULL,
prefd_covars_chr = NA_character_
){
new_params_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
candidate_predrs_chr = candidate_predrs_chr,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr)
if(!is.null(scndry_anlys_params_ls)){
new_params_ls <- append(scndry_anlys_params_ls, list(new_params_ls)) %>%
stats::setNames(paste0("secondary_",1:(length(scndry_anlys_params_ls) + 1)))
}else{
new_params_ls <- list(secondary_1 = new_params_ls)
}
return(new_params_ls)
}
make_scndry_anlys_text <- function(results_ls){
text_1L_chr <- ifelse(get_nbr_of_scndry_analyses(results_ls,
as_words_1L_lgl = F) == 0,
"",
paste0(get_nbr_of_scndry_analyses(results_ls),
" secondary analys",
ifelse(get_nbr_of_scndry_analyses(results_ls, as_words_1L_lgl = F) == 1,
"is was ",
"es were "),
"undertaken. ",
get_scndry_anlys_descs(results_ls)))
return(text_1L_chr)
}
make_selected_mdl_text <- function(results_ls,
for_abstract_1L_lgl = F){
length_1L_int <- length(results_ls$ttu_cs_ls$selected_mdls_chr)
text_1L_chr <- paste0(ifelse((length_1L_int == 2 & !for_abstract_1L_lgl),"Both ",""),
results_ls$ttu_cs_ls$selected_mdls_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
ifelse(length_1L_int >1," were"," was"),
ifelse(for_abstract_1L_lgl,
paste0(" the best peforming model",ifelse(length_1L_int >1,"s.",".")),
" selected for further evaluation."))
return(text_1L_chr)
}
make_shareable_mdl <- function (fake_ds_tb,
mdl_smry_tb,
x_ready4use_dictionary,
#x_Ready4useDyad,
control_1L_chr = NA_character_,
depnt_var_nm_1L_chr = "utl_total_w",
id_var_nm_1L_chr = "fkClientID",
mdl_type_1L_chr = "OLS_CLL",
mdl_types_lup = NULL,
seed_1L_int = 12345L,
start_1L_chr = NA_character_,
tfmn_1L_chr = "CLL")
{
if (is.null(mdl_types_lup))
utils::data(mdl_types_lup, envir = environment())
if (is.na(tfmn_1L_chr))
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "tfmn_chr", evaluate_1L_lgl = F)
predr_var_nms_chr <- mdl_smry_tb$Parameter[!mdl_smry_tb$Parameter %in%
c("SD (Intercept)", "Intercept", "R2", "RMSE", "Sigma")] %>%
stringi::stri_replace_last_fixed(" baseline", "_baseline") %>%
stringi::stri_replace_last_fixed(" change", "_change") %>%
stringi::stri_replace_last_fixed(" scaled", "_scaled") %>%
stringi::stri_replace_last_fixed(" unscaled", "_unscaled")
X <- ready4use::Ready4useDyad(ds_tb = fake_ds_tb %>% dplyr::select(intersect(names(fake_ds_tb), x_ready4use_dictionary$var_nm_chr)),
dictionary_r3 = x_ready4use_dictionary)
dummys_chr <- manufacture(X, flatten_1L_lgl = T)
predr_var_nms_chr <- predr_var_nms_chr %>% purrr::map_chr(~ifelse(.x %in% dummys_chr,
manufacture(X, flatten_1L_lgl = T, what_1L_chr = "factors-d", match_1L_chr = .x),
.x)) %>% unique()
tfd_depnt_var_nm_1L_chr <- transform_depnt_var_nm(depnt_var_nm_1L_chr, tfmn_1L_chr = tfmn_1L_chr)
if (length(predr_var_nms_chr) > 1) {
covar_var_nms_chr <- predr_var_nms_chr[2:length(predr_var_nms_chr)]
} else {
covar_var_nms_chr <- NA_character_
}
model_mdl <- make_mdl(fake_ds_tb %>% dplyr::select(tidyselect::all_of(c(id_var_nm_1L_chr, tfd_depnt_var_nm_1L_chr, predr_var_nms_chr))),
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_var_nm_1L_chr = predr_var_nms_chr[1],
covar_var_nms_chr = covar_var_nms_chr,
tfmn_1L_chr = tfmn_1L_chr,
mdl_type_1L_chr = mdl_type_1L_chr,
mdl_types_lup = mdl_types_lup,
control_1L_chr = control_1L_chr,
start_1L_chr = start_1L_chr)
if (ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "fn_chr",
evaluate_1L_lgl = F) == "betareg::betareg") {
model_coeffs_dbl <- model_mdl$coefficients$mean
} else {
model_coeffs_dbl <- model_mdl$coefficients
}
param_nms_chr <- model_coeffs_dbl %>% names()
mdl_smry_tb <- mdl_smry_tb %>% dplyr::mutate(Parameter = dplyr::case_when(Parameter == "Intercept" ~ "(Intercept)",
TRUE ~ purrr::map_chr(Parameter,
~stringr::str_replace_all(.x, " ", "_")))) %>%
dplyr::filter(Parameter %in% param_nms_chr) %>% dplyr::slice(match(param_nms_chr, Parameter))
assertthat::assert_that(all(param_nms_chr == mdl_smry_tb$Parameter),
msg = "Parameter names mismatch between data and model summary table")
model_coeffs_dbl <- mdl_smry_tb$Estimate
names(model_coeffs_dbl) <- param_nms_chr
if (ready4::get_from_lup_obj(mdl_types_lup, match_value_xx = mdl_type_1L_chr, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "fn_chr", evaluate_1L_lgl = F) == "betareg::betareg") {
model_mdl$coefficients$mean <- model_coeffs_dbl
} else {
model_mdl$coefficients <- model_coeffs_dbl
}
return(model_mdl)
}
make_smry_of_brm_mdl <- function (mdl_ls,
data_tb,
depnt_var_nm_1L_chr = "utl_total_w",
predr_vars_nms_chr,
mdl_nm_1L_chr = NA_character_,
seed_1L_dbl = 23456,
tfmn_1L_chr) {
if (is.na(mdl_nm_1L_chr))
mdl_nm_1L_chr <- predr_vars_nms_chr[1]
set.seed(seed_1L_dbl)
predictions <- stats::predict(mdl_ls, summary = F) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr, tfmn_is_outp_1L_lgl = T)
sd_intcpt_df <- summary(mdl_ls, digits = 4)$random[[1]]
sd_intcpt_df <- sd_intcpt_df[1:nrow(sd_intcpt_df), 1:4] %>%
dplyr::mutate(dplyr::across(dplyr::everything(), as.numeric))
coef <- summary(mdl_ls, digits = 4)$fixed
coef <- coef[1:nrow(coef), 1:4] %>% dplyr::mutate(dplyr::across(dplyr::everything(), as.numeric))
R2 <- brms::bayes_R2(mdl_ls) %>% as.vector()
RMSE <- psych::describe(apply(predictions, 1, calculate_rmse,
y_dbl = data_tb %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
quant = c(0.25, 0.75), skew = F, ranges = F)
RMSE <- cbind(RMSE$mean, RMSE$sd, RMSE$Q0.25, RMSE$Q0.75) %>% as.vector()
Sigma <- summary(mdl_ls, digits = 4)$spec_par[1:4]
smry_of_brm_mdl_tb <- data.frame(round(rbind(sd_intcpt_df, coef, R2, RMSE, Sigma), 3)) %>%
dplyr::mutate(Parameter = c("SD (Intercept)", "Intercept",
purrr::map(predr_vars_nms_chr,
~{
possibilities_chr <- paste0(.x, c("", " baseline", " change", " scaled", " unscaled"))
if(possibilities_chr[1] %in% names(mdl_ls$data)){
values_xx <- mdl_ls$data %>% dplyr::pull(.x)
if(is.factor(values_xx)){
possibilities_chr <- c(possibilities_chr[1], paste0(.x,levels(values_xx)[2:length(levels(values_xx))]))
}
}
possibilities_chr
}) %>%
purrr::flatten_chr() %>% intersect(purrr::map(names(mdl_ls$data),
~{
values_xx <- mdl_ls$data %>% dplyr::pull(.x)
if(is.factor(values_xx)){
paste0(.x,levels(values_xx)[2:length(levels(values_xx))])
}else{
stringi::stri_replace_last_fixed(.x, "_baseline", " baseline") %>%
stringi::stri_replace_last_fixed("_change", " change") %>%
stringi::stri_replace_last_fixed("_scaled"," scaled") %>%
stringi::stri_replace_last_fixed("_unscaled"," unscaled")
}
}) %>%
purrr::flatten_chr()),
"R2", "RMSE", "Sigma"), Model = mdl_nm_1L_chr) %>%
dplyr::mutate(`95% CI` = paste(l.95..CI, ",", u.95..CI)) %>%
dplyr::rename(SE = Est.Error) %>% dplyr::select(Model, Parameter, Estimate, SE, `95% CI`)
rownames(smry_of_brm_mdl_tb) <- NULL
return(smry_of_brm_mdl_tb)
}
make_smry_of_mdl_outp <- function (data_tb,
folds_1L_int = 10,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
start_1L_chr = NULL,
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr,
covar_var_nms_chr = NA_character_,
mdl_type_1L_chr = "OLS_NTF",
mdl_types_lup = NULL,
predn_type_1L_chr = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment())
data_tb <- data_tb %>% dplyr::filter(!is.na(!!rlang::sym(predr_var_nm_1L_chr)))
data_tb <- transform_ds_for_mdlng(data_tb, depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr)
mdl_desc_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "long_name_chr", evaluate_1L_lgl = F)
folds_ls <- make_folds_ls(data_tb, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
folds_1L_int = folds_1L_int)
control_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "control_chr",
evaluate_1L_lgl = F)
smry_of_one_predr_mdl_tb <- purrr::map_dfr(folds_ls, ~{
model_mdl <- make_mdl(data_tb[-.x,], depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl, # Unnecessary
start_1L_chr = start_1L_chr, tfmn_1L_chr = tfmn_1L_chr,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr,
mdl_type_1L_chr = mdl_type_1L_chr, mdl_types_lup = mdl_types_lup, control_1L_chr = control_1L_chr)
predd_old_dbl <- stats::predict(model_mdl, type = predn_type_1L_chr) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr, ## TEST
tfmn_is_outp_1L_lgl = T)
predd_new_dbl <- stats::predict(model_mdl, newdata = data_tb[.x, ],
type = predn_type_1L_chr) %>% calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr,
tfmn_is_outp_1L_lgl = T)
tibble::tibble(Rsquared = caret::R2(predd_old_dbl,
data_tb[-.x,] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
form = "traditional"),
RMSE = caret::RMSE(predd_old_dbl,
data_tb[-.x, ] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
MAE = caret::MAE(predd_old_dbl, data_tb[-.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
RsquaredP = caret::R2(predd_new_dbl, data_tb[.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
form = "traditional"), RMSEP = caret::RMSE(predd_new_dbl,
data_tb[.x, ] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
MAEP = caret::MAE(predd_new_dbl, data_tb[.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))))
}) %>% dplyr::summarise_all(mean) %>% dplyr::mutate(Model = mdl_desc_1L_chr) %>%
dplyr::select(Model, dplyr::everything())
return(smry_of_one_predr_mdl_tb)
}
make_smry_of_ts_mdl_outp <- function (data_tb, # rename ts to lngl
mdl_nm_1L_chr,
mdl_types_lup,
predr_vars_nms_chr,
predictors_lup,
backend_1L_chr = getOption("brms.backend", "rstan"),
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove Default
id_var_nm_1L_chr = "fkClientID",
iters_1L_int = 4000L,
options_chr = c("Y", "N"),
path_to_write_to_1L_chr = NA_character_,
prior_ls = NULL,
round_bl_val_1L_chr = "Baseline",
round_var_nm_1L_chr = "round",
seed_1L_int = 1000L,
utl_min_val_1L_dbl = -1)
{
scaling_fctr_dbl <- predr_vars_nms_chr %>% purrr::map_dbl(~
ifelse(.x %in% predictors_lup$short_name_chr,
ready4::get_from_lup_obj(predictors_lup,
target_var_nm_1L_chr = "mdl_scaling_dbl",
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F),
1))
mdl_type_1L_chr <- mdl_nm_1L_chr %>%
stringr::str_remove(paste0(predr_vars_nms_chr[1], "_", ifelse(is.na(predr_vars_nms_chr[2]), "", paste0(predr_vars_nms_chr[2],
"_"))))
mdl_type_1L_chr <- stringr::str_sub(mdl_type_1L_chr, start = 1 + (mdl_type_1L_chr %>% stringi::stri_locate_first_fixed("_"))[1,2] %>% as.vector())
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
target_var_nm_1L_chr = "tfmn_chr",
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F)
tfd_data_tb <- transform_tb_to_mdl_inp(data_tb,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr, id_var_nm_1L_chr = id_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr, round_bl_val_1L_chr = round_bl_val_1L_chr,
scaling_fctr_dbl = scaling_fctr_dbl,
tfmn_1L_chr = tfmn_1L_chr)
tfd_depnt_var_nm_1L_chr <- transform_depnt_var_nm(depnt_var_nm_1L_chr,
tfmn_1L_chr = tfmn_1L_chr)
family_fn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr",
evaluate_1L_lgl = F)
family_fn_1L_chr <- ifelse(is.na(family_fn_1L_chr),
ifelse(startsWith(mdl_type_1L_chr,"BET"),
paste0("brms::Beta(link = \"",
get_link_from_tfmn(stringr::str_sub(mdl_type_1L_chr,
start = -3)),
"\")"),
"gaussian(identity)"),
family_fn_1L_chr)
args_ls <- list(data_tb = tfd_data_tb, depnt_var_nm_1L_chr = tfd_depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr, id_var_nm_1L_chr = id_var_nm_1L_chr,
is_csnl_1L_lgl = !(!identical(round_var_nm_1L_chr, character(0)) && ifelse(identical(round_var_nm_1L_chr, character(0)),T,!is.na(round_var_nm_1L_chr))),
iters_1L_int = iters_1L_int,
backend_1L_chr = backend_1L_chr,
family_fn_1L_chr = family_fn_1L_chr,
seed_1L_int = seed_1L_int,
prior_ls = prior_ls, control_ls = control_ls)
mdl_ls <- rlang::exec(fit_ts_model_with_brm, !!!args_ls)
smry_of_ts_mdl_ls <- list(smry_of_ts_mdl_tb = make_smry_of_brm_mdl(mdl_ls,
data_tb = tfd_data_tb,
depnt_var_nm_1L_chr = tfd_depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr,
mdl_nm_1L_chr = mdl_nm_1L_chr,
tfmn_1L_chr = tfmn_1L_chr))
if (!is.na(path_to_write_to_1L_chr)) {
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr <- paste0(path_to_write_to_1L_chr,
"/", mdl_nm_1L_chr, ".RDS")
# if (file.exists(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr))
# file.remove(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr)
capture_xx <- ready4::write_to_delete_fls(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
options_chr = options_chr)
ready4::write_with_consent(consented_fn = saveRDS,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
consented_args_ls = list(object = mdl_ls,
file = smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr),
consented_msg_1L_chr = paste0("File ",
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
" has been written"),
declined_msg_1L_chr = "Write request cancelled - no new files have been written.",
options_chr = options_chr,
prompt_1L_chr = paste0("Do you confirm that you want to write the file ",
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
"?"))
smry_of_ts_mdl_ls$paths_to_mdl_plts_chr <- write_ts_mdl_plts(mdl_ls,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
mdl_nm_1L_chr = mdl_nm_1L_chr,
options_chr = options_chr,
path_to_write_to_1L_chr = path_to_write_to_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
tfd_data_tb = tfd_data_tb,
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
}
return(smry_of_ts_mdl_ls)
}
make_sngl_mdl_smry_tb <- function(mdls_tb,
mdl_nm_1L_chr,
mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = T){
new_tb <- mdls_tb %>%
dplyr::filter(Model == mdl_nm_1L_chr) %>%
tibble::add_case(Parameter = mdl_nm_1L_chr, .before = 1) %>%
dplyr::select(-Model)
mdl_nm_sfx_1L_chr <- ifelse(add_mdl_nm_sfx_1L_lgl,
paste0("_",mdl_type_1L_chr),
"")
new_tb <- new_tb %>%
dplyr::mutate(!!rlang::sym(paste0("R2",mdl_nm_sfx_1L_chr)) := dplyr::case_when(Parameter == mdl_nm_1L_chr ~ ready4::get_from_lup_obj(new_tb,
match_value_xx = "R2",
match_var_nm_1L_chr = "Parameter",
target_var_nm_1L_chr = "Estimate",
evaluate_1L_lgl = F),
T ~ NA_character_),
!!rlang::sym(paste0("Sigma",mdl_nm_sfx_1L_chr)) := dplyr::case_when(Parameter == mdl_nm_1L_chr ~ ready4::get_from_lup_obj(new_tb,
match_value_xx = "Sigma",
match_var_nm_1L_chr = "Parameter",
target_var_nm_1L_chr = "Estimate",
evaluate_1L_lgl = F),
T ~ NA_character_)) %>%
dplyr::filter(!Parameter %in% c("R2","RMSE","Sigma")) %>%
dplyr::rename_with(~paste0(.x,mdl_nm_sfx_1L_chr),.cols = c("Parameter","Estimate","SE")) %>%
dplyr::rename_with(~paste0("CI",mdl_nm_sfx_1L_chr),.cols = c("95% CI")) %>%
dplyr::mutate(!!rlang::sym(paste0("Parameter",mdl_nm_sfx_1L_chr)) := !!rlang::sym(paste0("Parameter",mdl_nm_sfx_1L_chr)) %>% purrr::map_chr(~stringr::str_replace(.x,
paste0("_1_",mdl_type_1L_chr), " model")))
rownames(new_tb) <- NULL
return(new_tb)
}
make_study_descs_ls <- function(input_params_ls = NULL, # Generalise utility to short and long name
time_btwn_bl_and_fup_1L_chr,
background_1L_chr = "",
coi_1L_chr = "None declared.",
conclusion_1L_chr = "",
ethics_1L_chr = NULL,
funding_1L_chr = NULL,
predr_ctgs_ls = NULL,
sample_desc_1L_chr = NULL,
var_nm_change_lup = NULL){
health_utl_nm_1L_chr <- input_params_ls$short_and_long_nm[1]
params_ls_ls <- input_params_ls
health_utl_long_nm_1L_chr <- ifelse(!is.null(params_ls_ls$short_and_long_nm),
params_ls_ls$short_and_long_nm[2],
NA_character_)
study_descs_ls <- list(background_1L_chr = background_1L_chr,
coi_1L_chr = coi_1L_chr,
conclusion_1L_chr = conclusion_1L_chr,
ethics_1L_chr = ethics_1L_chr,
funding_1L_chr = funding_1L_chr,
health_utl_nm_1L_chr = health_utl_nm_1L_chr,
health_utl_long_nm_1L_chr = health_utl_long_nm_1L_chr,
time_btwn_bl_and_fup_1L_chr = time_btwn_bl_and_fup_1L_chr,
predr_ctgs_ls = predr_ctgs_ls,
sample_desc_1L_chr = sample_desc_1L_chr,
var_nm_change_lup = var_nm_change_lup)
if(!is.null(input_params_ls)){
input_params_ls$study_descs_ls <- study_descs_ls
}else{
input_params_ls <- study_descs_ls
}
return(input_params_ls)
}
make_ten_fold_text <- function(results_ls,
for_abstract_1L_lgl = F){
mdls_chr <- get_ordered_sngl_csnl_mdls(results_ls)
if(for_abstract_1L_lgl){
text_1L_chr <- ifelse(length(mdls_chr)>1,
paste0(mdls_chr[1],
" had the highest predictive ability in ten fold cross validation"),
"")
}else{
text_1L_chr <- ifelse(length(mdls_chr)>1,
paste0(mdls_chr[1],
" had the highest predictive ability followed by ",
get_ordered_sngl_csnl_mdls(results_ls,
select_int = -1,
collapse_1L_lgl = T),
". ",
ifelse(length(mdls_chr)>2,
paste0(mdls_chr[length(mdls_chr)],
" had the least predictive capability."),
"")),
paste0("the predictive ability of ", mdls_chr[1]))
}
return(text_1L_chr)
}
make_ten_folds_tbl_title <- function(results_ls,
ref_1L_int = 1){
title_1L_chr <- ifelse(ref_1L_int == 1,
paste0('10-fold cross-validated model fitting index for different ',
results_ls$ttu_cs_ls$best_mdl_types_ls %>%
names() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
' models using ',
results_ls$ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr[1],
' as predictor with the baseline data'),
paste0('10-fold cross-validated model fitting index for different candidate predictors estimated using ',
results_ls$ttu_cs_ls$selected_mdls_chr[1],
' with the baseline data'))
return(title_1L_chr)
}
make_tfd_sngl_predr_mdls_tb <- function(outp_smry_ls,
nbr_of_digits_1L_int = 2L,
mdl_pfx_ls = list(OLS = "Ordinary Least Squares ",
GLM = c("Generalised Linear Model with ",
"Beta Regression Model with Binomial "))){
tfd_sngl_predr_mdls_tb <- mdl_pfx_ls %>%
purrr::map2(names(mdl_pfx_ls),
~{
pfx_chr <- .x
mdls_tb <- outp_smry_ls$smry_of_sngl_predr_mdls_tb %>%
dplyr::filter(Model %>%
purrr::map_lgl(~{
term_1L_chr <- .x
pfx_chr %>%
purrr::map_lgl(~startsWith(term_1L_chr,.x)) %>%
any()
}))
pfx_chr %>%
purrr::map_dfr(~ {
pfx_1L_chr <- .x
mdls_tb %>%
dplyr::filter(startsWith(Model, pfx_1L_chr)) %>%
dplyr::mutate(Model = dplyr::case_when(Model %>% startsWith(mdl_pfx_ls[[2]][2]) ~ stringr::str_replace_all(Model,pfx_1L_chr,"Beta "),
T ~ stringr::str_remove_all(Model,pfx_1L_chr))
) %>%
dplyr::mutate(Model = Model %>% stringr::str_remove_all("\\(|\\)"))
}) %>%
tibble::add_case(Model = .y, .before = 1)
}) %>%
purrr::map_dfr(~.x) %>%
transform_tbl_to_rnd_vars(nbr_of_digits_1L_int = nbr_of_digits_1L_int)
return(tfd_sngl_predr_mdls_tb)
}
make_tfmn_cmprsn_plt <- function(data_tb,
depnt_var_nm_1L_chr,
dictionary_tb){
tfmn_cmprsn_plt <- tidyr::gather(data_tb %>%
dplyr::mutate(!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_log")) := log(!!rlang::sym(depnt_var_nm_1L_chr)),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_logit")) := psych::logit(!!rlang::sym(depnt_var_nm_1L_chr)),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_loglog")) := -log(-log(!!rlang::sym(depnt_var_nm_1L_chr))),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_cloglog")) := log(-log(1-!!rlang::sym(depnt_var_nm_1L_chr)))),
variable,
value,
!!rlang::sym(depnt_var_nm_1L_chr),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_log")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_logit")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_loglog")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_cloglog"))) %>%
dplyr::mutate(variable = factor(variable, levels = paste0(depnt_var_nm_1L_chr,c("",
"_log", "_logit", "_loglog", "_cloglog")),
labels= c("No transformation",
"Log", "Logit","Log-log", "Complementary log-log"))) %>%
ggplot2::ggplot(ggplot2::aes(x = value, fill = variable)) +
ggalt::geom_bkde() +
ggplot2::geom_rug() +
viridis::scale_fill_viridis(guide = "none", discrete = TRUE) +
ggplot2::facet_wrap(~variable, scales = "free") +
ggplot2::theme_bw() + ggplot2::labs(x = paste0("Transformed ",
dictionary_tb %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "var_nm_chr",
match_value_xx = depnt_var_nm_1L_chr,
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F)))
return(tfmn_cmprsn_plt)
}
make_ttu_cs_ls <- function(outp_smry_ls, # Rename / Generalise from TTU
sig_covars_some_predrs_mdls_tb,
sig_thresh_covars_1L_chr){
# mdl_type_descs_chr <- outp_smry_ls$prefd_mdl_types_chr %>%
# purrr::map_chr(~ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
# match_var_nm_1L_chr = "short_name_chr",
# match_value_xx = .x,
# target_var_nm_1L_chr = "long_name_chr",
# evaluate_1L_lgl = F))
ttu_cs_ls <- list(best_mdl_types_ls = list(GLM = c("Gaussian distribution and log link"), # LEGACY ISSUE FROM MANUSCRIPT - OTHERWISE UNUSED
OLS = c("no transformation","log transformation", "clog-log transformation")),
selected_mdls_chr = outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map_chr(~paste0(ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "fixed_acronym_chr",
evaluate_1L_lgl = F),
" with ",
ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F))),
cs_mdls_predrs_seq_dscdng_chr = outp_smry_ls$smry_of_mdl_sngl_predrs_tb$Predictor,
sig_covars_all_predrs_mdls_chr = outp_smry_ls$signt_covars_chr,
sig_thresh_covars_1L_chr = sig_thresh_covars_1L_chr,
sig_covars_some_predrs_mdls_tb = sig_covars_some_predrs_mdls_tb,
rf_seq_dscdng_chr = outp_smry_ls$predr_cmprsn_tb$predr_chr,
mdl_predrs_and_rf_seqs_cmprsn_1L_chr = ifelse(outp_smry_ls$smry_of_mdl_sngl_predrs_tb$Predictor[1] == outp_smry_ls$predr_cmprsn_tb$predr_chr[1],"is consistent","contrasts") # COMPUTE
)
return(ttu_cs_ls)
}
make_uid_rename_lup <- function(data_tb,
id_var_nm_1L_chr = "UID"){
uid_rename_lup_tb <- tibble::tibble(old_id_xx = data_tb %>%
dplyr::pull(id_var_nm_1L_chr) %>%
unique(),
new_id_int = 1:length(data_tb %>%
dplyr::pull(id_var_nm_1L_chr) %>%
unique()))
return(uid_rename_lup_tb)
}
make_unique_ls_elmt_idx_int <- function (data_ls)
{
combos_tb <- tibble::tibble(names_chr = data_ls %>% purrr::map_chr(~paste0(.x[1],ifelse(length(.x)>1,.x[2],""))),
indices_int = NA_integer_)
combos_tb <- combos_tb %>% dplyr::group_by(names_chr) %>%
dplyr::mutate(indices_int = dplyr::row_number())
unique_ls_elmt_idx_int <- combos_tb$indices_int
return(unique_ls_elmt_idx_int)
}
make_valid_params_ls_ls <- function(analysis_core_params_ls, # Generalise utility component
ds_tb,
path_params_ls,
maui_params_ls,
candidate_covar_nms_chr = NA_character_,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
raw_ds_tfmn_fn = NULL,
scndry_analysis_extra_vars_chr = NA_character_,
subtitle_1L_chr = "Methods Report 1: Analysis Program (Primary Analysis)",
utl_class_fn_1L_chr = "as.numeric"){
valid_params_ls_ls <- make_prmry_analysis_params_ls(analysis_core_params_ls = analysis_core_params_ls,
candidate_covar_nms_chr = candidate_covar_nms_chr,
ds_tb = ds_tb,
path_params_ls = path_params_ls,
maui_params_ls = maui_params_ls,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
raw_ds_tfmn_fn = raw_ds_tfmn_fn,
subtitle_1L_chr = subtitle_1L_chr,
utl_class_fn_1L_chr = utl_class_fn_1L_chr) %>%
transform_params_ls_to_valid(scndry_analysis_extra_vars_chr = scndry_analysis_extra_vars_chr)
valid_params_ls_ls$params_ls$short_and_long_nm <- NULL
valid_params_ls_ls$short_and_long_nm <- maui_params_ls$short_and_long_nm
valid_params_ls_ls$path_params_ls <- path_params_ls
return(valid_params_ls_ls)
}
make_within_between_ratios_text <- function(results_ls,
exclude_covars_1L_lgl = F){
tb <- results_ls$ttu_lngl_ls$cs_ts_ratios_tb %>%
dplyr::distinct()
if(exclude_covars_1L_lgl)
tb <- tb %>%
dplyr::filter(contains_cndt_predr_lgl)
text_1L_chr <- tb %>%
purrr::pmap_chr(~paste0(..2, " for ", ..1)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
return(text_1L_chr)
}
ready4-dev/specific documentation built on Oct. 13, 2023, 7:54 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
make_abstract_args_ls <- function(results_ls, # Duplicate name from ready4show - Is This Deliberate?
fl_nm_1L_chr = "abstract.txt"){
mdl_cmprsns_ls <- get_mdl_cmprsns(results_ls, as_list_1L_lgl = T)
abstract_args_ls <- list(abstract_ls = list(Background = get_background_text(results_ls),
Objectives = paste0("We aimed to identify the best regression models to predict ",
get_hlth_utl_nm(results_ls, short_nm_1L_lgl = F),
" (",
get_hlth_utl_nm(results_ls),
") utility and evaluate the predictive ability of ",
get_nbr_of_predrs(results_ls),
" candidate measure",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1,"s",""),
" of ",
get_predr_ctgs(results_ls),
"."),
Methods = paste0(results_ls$study_descs_ls$sample_desc_1L_chr,
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
"",
paste0(" Follow-up measurements were ",
results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr,
" after baseline. ")),
paste0(length(mdl_cmprsns_ls$OLS) %>%
xfun::numbers_to_words() %>%
Hmisc::capitalize()),
" ordinary least squares (OLS) and ",
length(mdl_cmprsns_ls$GLM) %>%
xfun::numbers_to_words(),
" generalised linear models (GLMs) were explored to identify the best algorithm. ",
" Predictive ability of ",
get_nbr_of_predrs(results_ls),
" candidate measure",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1,"s",""),
" of ",
get_predr_ctgs(results_ls),
" were assessed using ten fold cross validation",
ifelse(get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)>1," and forest models",""),
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
". ",
paste0(". Linear / generalised linear mixed effect models were then used to construct longitudinal predictive models for ",
get_hlth_utl_nm(results_ls),
" change."))),
Results = paste0(make_ten_fold_text(results_ls, for_abstract_1L_lgl = T),
". ",
make_selected_mdl_text(results_ls, for_abstract_1L_lgl = T),
ifelse(is.na(results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr),
"",
paste0(" The mean ratio between the within-person and between-person associated coefficients was ",
make_within_between_ratios_text(results_ls,
exclude_covars_1L_lgl = T),
"."))
),
Conclusions = get_conclusion_text(results_ls),
Data = make_data_availability_text(results_ls)),
fl_nm_1L_chr = fl_nm_1L_chr)
return(abstract_args_ls)
}
make_all_mdl_types_smry_tbl <- function(outp_smry_ls,
mdls_tb){
mdls_ls <- make_mdls_ls(outp_smry_ls,
mdls_tb = mdls_tb)
all_mdl_types_smry_tbl_tb <- 1:length(mdls_ls) %>% # Modified from 1:2 - need to test.
purrr::map_dfc(
~ {
make_mdl_type_smry_tbl(mdls_tb = mdls_tb,
mdl_nms_chr = mdls_ls[[.x]],
mdl_type_1L_chr = outp_smry_ls$prefd_mdl_types_chr[.x],
add_mdl_nm_sfx_1L_lgl = T)
}
) %>%
dplyr::select(-paste0("Parameter_",outp_smry_ls$prefd_mdl_types_chr[-1])) %>%
dplyr::rename_with(~"Parameter",.cols = paste0("Parameter_",outp_smry_ls$prefd_mdl_types_chr[1]))
return(all_mdl_types_smry_tbl_tb)
}
make_analysis_core_params_ls <- function(ds_descvs_ls,
mdl_smry_ls = make_mdl_smry_ls(),
output_format_ls = make_output_format_ls(),
predictors_lup,
control_ls = NULL,
iters_1L_int = 4000L,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
prior_ls = NULL,
seed_1L_int = 12345
){
candidate_covar_nms_chr <- ds_descvs_ls$candidate_covar_nms_chr
use_fake_data_1L_lgl <- ds_descvs_ls$is_fake_1L_lgl
analysis_core_params_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
ds_descvs_ls = ds_descvs_ls,
iters_1L_int = iters_1L_int,
mdl_smry_ls = mdl_smry_ls,
nbr_of_digits_1L_int = output_format_ls$supplementary_digits_1L_int,
output_type_1L_chr = output_format_ls$supplementary_outp_1L_chr,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
seed_1L_int = seed_1L_int,
use_fake_data_1L_lgl = use_fake_data_1L_lgl,
prior_ls = prior_ls,
control_ls = control_ls)
return(analysis_core_params_ls)
}
make_analysis_ds_smry_ls <- function(ds_descvs_ls,
candidate_covar_nms_chr,
predictors_lup){
analysis_ds_smry_ls <- list(candidate_predrs_chr = ds_descvs_ls$candidate_predrs_chr,
candidate_covar_nms_chr = candidate_covar_nms_chr,
depnt_var_nm_1L_chr = ds_descvs_ls$utl_wtd_var_nm_1L_chr,
id_var_nm_1L_chr = ds_descvs_ls$id_var_nm_1L_chr,
predictors_lup = predictors_lup,
round_var_nm_1L_chr = ds_descvs_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = ds_descvs_ls$round_vals_chr[1],
dictionary_tb = ds_descvs_ls$dictionary_tb)
return(analysis_ds_smry_ls)
}
make_bl_fup_add_to_row_ls <- function(df,
n_at_bl_1L_int,
n_at_fup_1L_int){
if(is.na(n_at_fup_1L_int)){
fup_1L_chr <- character(0)
}else{
fup_1L_chr <- paste0(" & \\multicolumn{2}{c}{\\textbf{Follow-up (N=",n_at_fup_1L_int,")}}")
}
add_to_row_ls <- list(pos = list(-1, nrow(df)),
command = c(paste("\\toprule \n",
paste0("\\multicolumn{2}{c}{} & \\multicolumn{2}{c}{\\textbf{Baseline (N=",n_at_bl_1L_int,")}}",fup_1L_chr," \\\\\n")),
paste("\\bottomrule \n"
)
)
)
return(add_to_row_ls)
}
make_brms_mdl_plt <- function(outp_smry_ls,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_desc_1L_chr,
mdl_nm_1L_chr,
type_1L_chr,
base_size_1L_dbl = 8,
brms_mdl = NULL,
correspondences_lup = NULL,
new_var_nm_1L_chr = "Predicted",
predn_type_1L_chr = NULL,
x_lbl_1L_chr = NA_character_,
y_lbl_1L_chr = NA_character_){
sfx_1L_chr <- " from brmsfit"
mdl_types_lup <- outp_smry_ls$mdl_types_lup
if(is.null(brms_mdl)){
incld_mdl_paths_chr <- make_incld_mdl_paths(outp_smry_ls)
brms_mdl <- readRDS(paste0(outp_smry_ls$path_to_write_to_1L_chr,"/",
incld_mdl_paths_chr[incld_mdl_paths_chr %>% endsWith(paste0(mdl_nm_1L_chr,".RDS"))]))
}
mdl_type_1L_chr <- get_mdl_type_from_nm(mdl_nm_1L_chr,
mdl_types_lup = mdl_types_lup)
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "tfmn_chr",
evaluate_1L_lgl = F)
plot_fn_and_args_ls <- make_plot_fn_and_args_ls(brms_mdl = brms_mdl,
tfd_data_tb = outp_smry_ls$scored_data_tb %>%
transform_tb_to_mdl_inp(depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,##
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
predr_vars_nms_chr = outp_smry_ls$predr_vars_nms_ls %>% purrr::flatten_chr() %>% unique(),
id_var_nm_1L_chr = outp_smry_ls$id_var_nm_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr,
scaling_fctr_dbl = make_scaling_fctr_dbl(outp_smry_ls)),
base_size_1L_dbl = base_size_1L_dbl,
correspondences_lup = correspondences_lup,
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
new_var_nm_1L_chr = new_var_nm_1L_chr,
predn_type_1L_chr = predn_type_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
sd_dbl = NA_real_,
sfx_1L_chr = sfx_1L_chr,
tfmn_1L_chr = tfmn_1L_chr,
type_1L_chr = type_1L_chr,
utl_min_val_1L_dbl = ifelse(!is.null(outp_smry_ls$utl_min_val_1L_dbl),
outp_smry_ls$utl_min_val_1L_dbl,
-1),
x_lbl_1L_chr = x_lbl_1L_chr,
y_lbl_1L_chr = y_lbl_1L_chr)
plt <- rlang::exec(plot_fn_and_args_ls$plt_fn, !!!plot_fn_and_args_ls$fn_args_ls)
return(plt)
}
make_brms_mdl_print_ls <- function (mdl_ls, label_stub_1L_chr, caption_1L_chr, output_type_1L_chr = "PDF",
digits_1L_dbl = 2, big_mark_1L_chr = " ")
{
smry_mdl_ls <- summary(mdl_ls, digits = 4)
mdl_smry_chr <- smry_mdl_ls %>% utils::capture.output()
idx_dbl <- c("Formula: ",
" Draws:",#"Samples: ",
"Group-Level Effects: ",
"Population-Level Effects: ",
"Family Specific Parameters: ",
"Draws were sampled using "#"Samples were drawn using "
) %>%
purrr::map_dbl(~mdl_smry_chr %>%
startsWith(.x) %>% which())
data_tb <- make_brms_mdl_smry_tbl(smry_mdl_ls, grp_1L_chr = mdl_smry_chr[idx_dbl[3]],
popl_1L_chr = mdl_smry_chr[idx_dbl[4]], fam_1L_chr = mdl_smry_chr[idx_dbl[5]])
bold_lgl <- data_tb$Parameter %in% c(mdl_smry_chr[idx_dbl[3]],
mdl_smry_chr[idx_dbl[4]], mdl_smry_chr[idx_dbl[5]])
if (output_type_1L_chr == "PDF") {
data_tb <- data_tb %>% dplyr::mutate(Parameter = purrr::map_chr(Parameter,
~.x %>% Hmisc::latexTranslate()))
}
data_tb <- data_tb %>% dplyr::mutate(Parameter = Parameter %>%
purrr::map2_chr(dplyr::all_of(bold_lgl), ~ifelse(.y &
output_type_1L_chr == "PDF", paste0("\\textbf{",
.x, "}"), .x)))
if (output_type_1L_chr != "PDF") {
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(c(Bulk_ESS,
Tail_ESS), ~format(., big.mark = big_mark_1L_chr)))
}
if (output_type_1L_chr == "HTML") {
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(where(is.numeric),
~format(round(., digits = digits_1L_dbl), digits = digits_1L_dbl,
nsmall = digits_1L_dbl)))
}
data_tb <- data_tb %>% dplyr::mutate(dplyr::across(where(is.character),
~dplyr::case_when(is.na(.) ~ "", . == "NA" ~ "", endsWith(.,
" NA") ~ "", TRUE ~ .)))
end_matter_1L_chr <- trimws(mdl_smry_chr[idx_dbl[6]:length(mdl_smry_chr)]) %>%
paste0(collapse = " ")
brms_mdl_print_ls <- list(part_1 = mdl_smry_chr[idx_dbl[1]],
part_2 = "\n\n", part_3 = c(trimws(mdl_smry_chr[1:(idx_dbl[2] -
1)][-idx_dbl[1]]), paste0(trimws(mdl_smry_chr[idx_dbl[2]]),
" ", trimws(mdl_smry_chr[idx_dbl[2] + 1]), collapse = " ")) %>%
paste0(collapse = ifelse(output_type_1L_chr == "PDF",
"\n\n", "\n")), part_4 = "\n\n", part_5 = list(data_tb = data_tb,
output_type_1L_chr = output_type_1L_chr, caption_1L_chr = caption_1L_chr,
mkdn_tbl_ref_1L_chr = paste0("tab:", label_stub_1L_chr), merge_row_idx_int = as.integer(which(bold_lgl)),
digits_dbl = c(ifelse(output_type_1L_chr == "PDF",
0, NA_real_) %>% purrr::discard(is.na), names(data_tb) %>%
purrr::map_dbl(~ifelse(.x %in% c("Bulk_ESS",
"Tail_ESS"), 0, digits_1L_dbl))), big_mark_1L_chr = big_mark_1L_chr,
hline_after_ls = c(-1, 0), sanitize_fn = force, footnotes_chr = NA_character_),
part_6 = end_matter_1L_chr)
if (output_type_1L_chr != "PDF") {
brms_mdl_print_ls$part_5$footnotes_chr <- c(paste0(brms_mdl_print_ls$part_1,
ifelse(output_type_1L_chr == "Word", "", "\n")),
brms_mdl_print_ls$part_3, brms_mdl_print_ls$part_6)
brms_mdl_print_ls$part_6 <- NULL
}
else {
footnotes_chr <- c(mdl_smry_chr[idx_dbl[1]], trimws(mdl_smry_chr[1:(idx_dbl[2] -
1)][-idx_dbl[1]]), trimws(mdl_smry_chr[idx_dbl[2]]),
trimws(mdl_smry_chr[idx_dbl[2] + 1]), trimws(mdl_smry_chr[idx_dbl[6]:length(mdl_smry_chr)])) %>%
Hmisc::latexTranslate()
footnotes_chr[1] <- footnotes_chr[1] %>% stringr::str_replace("~",
"\\\\textasciitilde")
brms_mdl_print_ls$part_5$add_to_row_ls <- list(pos = purrr::map(c(0,
rep(nrow(data_tb), length(footnotes_chr) + 1)), ~.x),
command = c(names(data_tb) %>% Hmisc::latexTranslate() %>%
paste0(collapse = " & ") %>% paste0("\\\\\n"),
c("\\toprule\n"), footnotes_chr %>% purrr::map_chr(~paste0("\\multicolumn{",
ncol(data_tb), "}{l}{", paste0("{\\footnotesize ",
.x, "}\n", collapse = ","), "}\\\\\n"))))
}
return(brms_mdl_print_ls)
}
make_brms_mdl_smry_tbl <- function (smry_mdl_ls, grp_1L_chr, popl_1L_chr, fam_1L_chr)
{
brms_mdl_smry_tb <- purrr::map(1:length(smry_mdl_ls$random),
~make_mdl_smry_elmt_tbl(ctg_chr = c(ifelse(.x == 1, grp_1L_chr,
character(0)),
paste0(names(smry_mdl_ls$ngrps)[.x],
" (Number of levels: ",
smry_mdl_ls$ngrps[.x][[1]],
")")),
mat = smry_mdl_ls$random[.x][[1]])) %>%
dplyr::bind_rows(make_mdl_smry_elmt_tbl(mat = smry_mdl_ls$fixed,
ctg_chr = popl_1L_chr),
make_mdl_smry_elmt_tbl(mat = smry_mdl_ls$spec_pars,
ctg_chr = fam_1L_chr))
return(brms_mdl_smry_tb)
}
make_cmpst_sctr_and_dnst_plt <- function(outp_smry_ls,
output_data_dir_1L_chr = NA_character_,
predr_var_nms_chr = NA_character_,
base_size_1L_dbl = 16,
correspondences_lup = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_desc_1L_chr = NA_character_,
labels_chr = c("A","B","C","D"),
label_x_1L_dbl = 0.1,
label_y_1L_dbl = 0.9,
label_size_1L_dbl = 22,
mdl_indcs_int = 1:2,
use_png_fls_1L_lgl = T){
if(use_png_fls_1L_lgl){
filtered_paths_chr <- outp_smry_ls$file_paths_chr %>% purrr::discard(~endsWith(.x,"_sim_sctr.png")|endsWith(.x,"_sim_dnst.png")|endsWith(.x,"_cnstrd_sctr_plt.png")|endsWith(.x,"_cnstrd_dnst.png"))
filtered_paths_chr <- paste0(output_data_dir_1L_chr,"/",filtered_paths_chr[filtered_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,paste0(predr_var_nms_chr,"_1")) & (stringr::str_detect(.x,"_dnst.png") | stringr::str_detect(.x,"_sctr_plt.png")))])
mdl_types_chr <- filtered_paths_chr %>% purrr::map_chr(~DescTools::SplitPath(.x)$filename %>%
stringr::str_remove("_dnst") %>%
stringr::str_remove("_sctr_plt") %>%
get_mdl_type_from_nm())
ordered_paths_chr <- outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map(~filtered_paths_chr[which(mdl_types_chr==.x)]) %>%
purrr::flatten_chr()
plot_ls <- ordered_paths_chr %>% purrr::map(~cowplot::ggdraw() + cowplot::draw_image(.x))
}else{
plots_chr <- outp_smry_ls$mdl_nms_ls %>%
purrr::flatten_chr()
plots_chr <- plots_chr[mdl_indcs_int]
plot_ls <- plots_chr %>%
purrr::map(~{
mdl_nm_1L_chr <- .x
brms_mdl <- get_brms_mdl(outp_smry_ls,
mdl_nm_1L_chr = mdl_nm_1L_chr)
if(is.na(depnt_var_desc_1L_chr)){
depnt_var_desc_1L_chr <- get_hlth_utl_nm(outp_smry_ls$results_ls,
short_nm_1L_lgl = T)
}
purrr::map(c("dnst", "sctr_plt"),
~ {
make_brms_mdl_plt(outp_smry_ls,
base_size_1L_dbl = base_size_1L_dbl,
brms_mdl = brms_mdl,
correspondences_lup = correspondences_lup,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,#
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
mdl_nm_1L_chr = mdl_nm_1L_chr,
type_1L_chr = .x,
predn_type_1L_chr = NULL,
x_lbl_1L_chr = paste0("Observed ", depnt_var_desc_1L_chr),
y_lbl_1L_chr = paste0("Predicted ", depnt_var_desc_1L_chr))
})
}) %>%
purrr::flatten()
}
composite_plt <- cowplot::plot_grid(plot_ls[[1]],plot_ls[[2]],plot_ls[[3]],plot_ls[[4]],
nrow = 2,
labels = labels_chr,
label_x = label_x_1L_dbl,
label_y = label_y_1L_dbl,
label_size = label_size_1L_dbl)
return(composite_plt)
}
make_cndt_predr_text <- function(results_ls,
type_1L_chr = "description"){
nbr_of_predrs_1L_int <- get_nbr_of_predrs(results_ls,
as_words_1L_lgl = F)
if(type_1L_chr == "description"){
text_1L_chr <- paste0(get_nbr_of_predrs(results_ls) %>% Hmisc::capitalize(),
" measure",
ifelse(nbr_of_predrs_1L_int>1,
"s",
""),
" of ",
get_nbr_of_predrs_by_ctg(results_ls),
ifelse(nbr_of_predrs_1L_int>1," were"," was"),
" used as ",
ifelse(nbr_of_predrs_1L_int>1,
"",
"a "),
"candidate predictor",
ifelse(nbr_of_predrs_1L_int>1,
"s",
""),
" to construct models.")
}
if(type_1L_chr == "comparison"){
text_1L_chr <- paste0(ifelse(nbr_of_predrs_1L_int > 1,
paste0("We ",
"evaluated",
" the independent predictive ability of different candidate predictors using 10-fold cross-validation."),
""))
}
return(text_1L_chr)
}
make_cohort_ls <- function(descv_tbls_ls,
ctgl_vars_regrouping_ls = NULL,
nbr_of_digits_1L_int = 2L){
numeric_vars_chr <- descv_tbls_ls$cohort_desc_tb %>% dplyr::filter(label ==
"Median (Q1, Q3)") %>% dplyr::pull(variable)
ctgl_vars_chr <- unique(descv_tbls_ls$cohort_desc_tb$variable[!descv_tbls_ls$cohort_desc_tb$variable %in% numeric_vars_chr])
nbr_by_round_dbl <- paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr,"_val_1_dbl") %>%
purrr::map_dbl(~descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == ctgl_vars_chr[1]) %>%
dplyr::pull(.x) %>%
purrr::discard(~.x=="") %>%
as.numeric() %>% purrr::map_dbl(~.x[[1]]) %>% sum())
numeric_vars_smry_ls <- numeric_vars_chr %>%
purrr::map(~{
var_smry_tb <- descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == .x)
list(bl_min_1L_dbl = var_smry_tb %>%
dplyr::filter(label == "Min - Max") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_1_dbl"))) %>%
as.numeric(),
bl_max_1L_dbl = var_smry_tb %>%
dplyr::filter(label == "Min - Max") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_2_ls"))) %>%
as.numeric(),
bl_mean_1L_dbl = round(var_smry_tb %>% dplyr::filter(label == "Mean (SD)") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_1_dbl"))) %>%
as.numeric(),
nbr_of_digits_1L_int),
bl_sd_1L_dbl = round(var_smry_tb %>% dplyr::filter(label == "Mean (SD)") %>%
dplyr::pull(!!rlang::sym(paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],"_val_2_ls"))) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric(),
nbr_of_digits_1L_int))
}) %>% stats::setNames(numeric_vars_chr)
cohort_ls <- list(n_all_1l_dbl = descv_tbls_ls$ds_descvs_ls$nbr_participants_1L_int,
n_inc_1L_dbl = nbr_by_round_dbl[1],
n_fup_1L_dbl = nbr_by_round_dbl[2],
numeric_vars_smry_ls = numeric_vars_smry_ls)
if(!is.null(ctgl_vars_regrouping_ls)){
append_ls <- ctgl_vars_regrouping_ls %>%
purrr::map2(names(ctgl_vars_regrouping_ls),
~{
var_nm_1L_chr <- .y
.x %>%
purrr::map(~{
list(name_1L_chr = .x$name_1L_chr,
n_in_group_1L_dbl = descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == var_nm_1L_chr) %>%
dplyr::filter(label %in% .x$ctgs_chr) %>%
dplyr::pull(Baseline_val_1_dbl) %>%
as.numeric() %>% purrr::map_dbl(~.x) %>% sum(),
n_msng_1L_dbl = descv_tbls_ls$cohort_desc_tb %>%
dplyr::filter(variable == var_nm_1L_chr) %>%
dplyr::filter(label == "Missing") %>%
dplyr::pull(Baseline_val_1_dbl) %>%
as.numeric())
}
)
})
cohort_ls <- append(cohort_ls,append_ls)
}
return(cohort_ls)
}
make_coi_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$coi_1L_chr),
"",
results_ls$study_descs_ls$coi_1L_chr)
return(text_1L_chr)
}
make_correlation_text <- function(results_ls){
correlation_text_1L_chr <- ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<2,
"",
paste0(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[1],
" was found to have the highest correlation with utility score both at baseline and follow-up followed by ",
results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[2],
ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<3,"",paste0(" and ", results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[3])),
ifelse(length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)<4,"",paste0("; baseline and follow-up ",results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr[length(results_ls$hlth_utl_and_predrs_ls$cor_seq_dscdng_chr)]," was found to have the lowest correlation coefficients with utility score")),
"."))
return(correlation_text_1L_chr)
}
make_covar_ttu_tbl_refs <- function(params_ls){
results_ls <- params_ls$results_ls
n_mdls_1L_int <- length(results_ls$ttu_lngl_ls$best_mdls_tb$model_type)
n_covars_1L_int <- length(results_ls$ttu_lngl_ls$incld_covars_chr %>% purrr::discard(is.na))
text_1L_chr <- paste0(ifelse(n_covars_1L_int < 1,
"",
paste0(" (see ",
ifelse(params_ls$output_type_1L_chr == "Word","","Table"),
"s ",
paste0("\\@ref(tab:coefscovarstype",1:n_mdls_1L_int,")", collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
")."
))
)
return(text_1L_chr)
}
make_covar_ttu_tbl_title <- function(results_ls, # Generalise from TTU
ref_1L_int = 1){
title_1L_chr <- paste0('Estimated coefficients from utility mapping models based on individual candidate predictors with ',
results_ls$ttu_lngl_ls$incld_covars_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(results_ls$mdl_ingredients_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_desc_chr")) %>%
ready4::make_list_phrase() %>%
paste0(collapse = ", ") %>% stringi::stri_replace_last(fixed = ",", " and"),
' using ', results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,"model_type"]], ' (', results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,"link_and_tfmn_chr"]],')')
return(title_1L_chr)
}
make_covariates_text <- function(results_ls){ # Generalise from utility
if(!is.null(results_ls$candidate_covars_ls)){
if(length(results_ls$candidate_covars_ls)<1){
text_1L_chr <- ""
}else{
n_predrs_1L_int <- get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)
tfmn_fn <- function(x, results_ls){ifelse(is.na(results_ls$cohort_ls$n_fup_1L_dbl),Hmisc::capitalize(x),x)}
text_1L_chr <- paste0("The confounding effect of other participant characteristics when using the candidate predictors in predicting utility score were also evaluated. ",
ifelse(is.na(results_ls$cohort_ls$n_fup_1L_dbl),"","Using the baseline data, "),
ifelse(is.na(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr[1]),
"no confounding factor",
results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(data_lookup_tb =results_ls$mdl_ingredients_ls$dictionary_tb,match_var_nm_1L_chr = "var_nm_chr", match_value_xx = .x, target_var_nm_1L_chr = "var_desc_chr")) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
tfmn_fn(results_ls)),
" ",
ifelse(is.na(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr[1]),"was",ifelse(length(results_ls$ttu_cs_ls$sig_covars_all_predrs_mdls_chr)==1,"was","were")),
" found to independently predict utility scores in models for ",
ifelse(n_predrs_1L_int == 1,
"the ",
ifelse(n_predrs_1L_int == 2,
"both ",
paste0("all ", get_nbr_of_predrs(results_ls)," "))),
"candidate predictor",
ifelse(n_predrs_1L_int == 1," ","s "),
"*(p<0.01)*.")
mdls_with_signft_covars_ls <- results_ls$mdls_with_signft_covars_ls
duplicates_int <- which(duplicated(mdls_with_signft_covars_ls))
if(!identical(integer(0), duplicates_int)){
unduplicated_ls <- mdls_with_signft_covars_ls[!duplicated(mdls_with_signft_covars_ls)]
duplicated_ls <- mdls_with_signft_covars_ls[duplicates_int]
add_to_chr <- duplicates_int %>%
purrr::map(~{
match_chr <- mdls_with_signft_covars_ls[[.x]]
mdls_with_signft_covars_ls[1:(.x-1)] %>%
purrr::map_lgl(~identical(.x,match_chr)) %>%
names()
}) %>%
purrr::flatten_chr() %>% unique()
signft_covars_chr <- names(unduplicated_ls) %>%
purrr::map(~{
vars_chr <- c(.x,names(duplicated_ls)[which(.x == add_to_chr)])
paste0(vars_chr %>%
purrr::map_chr(~ transform_names(.x,
rename_lup = results_ls$var_nm_change_lup)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
ifelse(length(vars_chr)>1," were significant covariates *(p<0.01)*"," was a significant covariate *(p<0.01)*"),
" in the ")
}) %>%
purrr::flatten_chr()
mdls_ls <- unduplicated_ls
}else{
if(!is.na(names(mdls_with_signft_covars_ls)[1])){
signft_covars_chr <- names(mdls_with_signft_covars_ls) %>%
purrr::map_chr(~paste0(transform_names(.x,
rename_lup = results_ls$var_nm_change_lup),
" was a significant covariate *(p<0.01)* in the "))
mdls_ls <- mdls_with_signft_covars_ls
}else{
signft_covars_chr <- ""
mdls_ls <- NULL
}
}
if(!is.null(mdls_ls)){
nbr_predrs_1L_int <- get_nbr_of_predrs(results_ls, as_words_1L_lgl = F)
sig_for_some_int <- which(mdls_ls %>% purrr::map_lgl(~length(.x) != nbr_predrs_1L_int)) %>% unname()
if(!identical(sig_for_some_int, integer(0))){
mdls_ls <- mdls_ls[sig_for_some_int]
signft_covars_chr <- signft_covars_chr[sig_for_some_int]
text_1L_chr <- paste0(text_1L_chr,
" ",
mdls_ls %>% purrr::map_chr(~ .x %>%
purrr::map_chr(~ transform_names(.x,
rename_lup = results_ls$var_nm_change_lup)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")) %>%
purrr::map2_chr(signft_covars_chr,
~ paste0(.y,
.x,
" model",
ifelse(stringr::str_detect(.x," and "),"s. ",". "))) %>%
paste0(collapse = ""))
}
}
}
}else{
text_1L_chr <- ""
}
return(text_1L_chr)
}
make_cs_ts_ratios_tb <- function(predr_ctgs_ls,
mdl_coef_ratios_ls,
candidate_predrs_chr = NULL,
nbr_of_digits_1L_int = 2L,
fn_ls = NULL){
if(is.null(fn_ls))
fn_ls <- purrr::map(1:length(predr_ctgs_ls),
~ make_mdl_coef_range_text)
if(is.null(candidate_predrs_chr)){
candidate_predrs_chr <- predr_ctgs_ls %>% purrr::flatten_chr()
}
cs_ts_ratios_tb <- 1:length(predr_ctgs_ls) %>%
purrr::map_dfr(
~ {
if(length(predr_ctgs_ls %>% purrr::pluck(.x))>1){
predr_nm_1L_chr <- paste0(names(predr_ctgs_ls)[.x] %>% tolower(),
" measurements")
}else{
predr_nm_1L_chr <- predr_ctgs_ls %>% purrr::pluck(.x)
}
tibble::tibble(predr_nm_chr = predr_nm_1L_chr,
ratios_chr = ifelse(identical(make_mdl_coef_range_text,fn_ls %>% purrr::pluck(.x)),
make_mdl_coef_range_text(mdl_coef_ratios_ls %>%
purrr::pluck(names(predr_ctgs_ls)[.x]),
nbr_of_digits_1L_int = nbr_of_digits_1L_int),
paste0(round(rlang::exec(fn_ls %>%
purrr::pluck(.x),
mdl_coef_ratios_ls %>%
purrr::pluck(names(predr_ctgs_ls)[.x])),
nbr_of_digits_1L_int),
ifelse(identical(min,fn_ls %>% purrr::pluck(.x)),
" or over",
ifelse(identical(max,fn_ls %>% purrr::pluck(.x)),
" or under",
"")))),
contains_cndt_predr_lgl = predr_ctgs_ls[[.x]] %>%
purrr::map_lgl(~!identical(intersect(.x, candidate_predrs_chr), character(0))) %>% unname()
)
})
cs_ts_ratios_tb <- dplyr::distinct(cs_ts_ratios_tb)
return(cs_ts_ratios_tb)
}
make_csnl_example_predrs <- function(){ # New to specific
predictors_r3 <- Ready4useRepos(dv_nm_1L_chr = "TTU",
dv_ds_nm_1L_chr = "https://doi.org/10.7910/DVN/DKDIB0",
dv_server_1L_chr = "dataverse.harvard.edu") %>%
ingest(fls_to_ingest_chr = c("predictors_r3"),
metadata_1L_lgl = F)
predictors_r3 <- renew.specific_predictors(predictors_r3,
filter_cdn_1L_chr = "short_name_chr == 'SOFAS'") %>%
renew.specific_predictors(short_name_chr = c("K10", "MLT", "CHU9D", "AQOL6D"),
long_name_chr = c("K10 total score", "MLT total score", "CHU9D health utility", "AQOL6D health utility"),
min_val_dbl = c(10,0,-0.1059,0.03),
max_val_dbl = c(50,100,1,1),
class_chr = c("integer","numeric","numeric","numeric"),
increment_dbl = 1,
class_fn_chr = c("youthvars::youthvars_k10_aus","as.double","youthvars::youthvars_chu9d_adolaus","youthvars::youthvars_aqol6d_adol"),
mdl_scaling_dbl = c(0.01,0.01,1,1),
covariate_lgl = F) %>%
dplyr::mutate(covariate_lgl = dplyr::case_when(short_name_chr == "SOFAS" ~ F,
T ~ covariate_lgl))
return(predictors_r3)
}
make_data_availability_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$dv_ds_nm_and_url_chr),
"None available",
paste0("Detailed results in the form of catalogues of the models produced by this study and other supporting information are available in the online repository: ",results_ls$dv_ds_nm_and_url_chr[2]))
return(text_1L_chr)
}
make_dnst_and_sctr_plt_title <- function(results_ls){ # Generalise from utility
title_1L_chr <- paste0("Comparison of observed and predicted ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" score from longitudinal model using ",
results_ls$predr_var_nms_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",",
" and"),
" (A) Density plots of observed and predicted utility scores (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(1),
") (B) Scatter plots of observed and predicted utility scores by timepoint (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(1),
") (C) Density plots of observed and predicted results (",
ifelse(nrow(results_ls$ttu_lngl_ls$best_mdls_tb)>1,
paste0(results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(2),
") (D) Scatter plots of observed and predicted results by timepoint (",
results_ls$ttu_lngl_ls$best_mdls_tb %>%
purrr::pmap_chr(~paste0(..1,
" (",
..2,
")")) %>%
purrr::pluck(2),")"),
""))
return(title_1L_chr)
}
make_ds_descvs_ls <- function(candidate_predrs_chr,# Generalise from utility
cohort_descv_var_nms_chr,
dictionary_tb,
id_var_nm_1L_chr,
msrmnt_date_var_nm_1L_chr,
round_var_nm_1L_chr,
round_vals_chr,
maui_item_pfx_1L_chr,
utl_wtd_var_nm_1L_chr = "wtd_utl_dbl",
utl_unwtd_var_nm_1L_chr = "unwtd_utl_dbl",
candidate_covar_nms_chr = NULL,
is_fake_1L_lgl = NULL){
ds_descvs_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
candidate_predrs_chr = candidate_predrs_chr,
cohort_descv_var_nms_chr = cohort_descv_var_nms_chr,
dictionary_tb = dictionary_tb,
id_var_nm_1L_chr = id_var_nm_1L_chr,
is_fake_1L_lgl = is_fake_1L_lgl,
msrmnt_date_var_nm_1L_chr = msrmnt_date_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
round_vals_chr = round_vals_chr,
maui_item_pfx_1L_chr = maui_item_pfx_1L_chr,
utl_wtd_var_nm_1L_chr = utl_wtd_var_nm_1L_chr,
utl_unwtd_var_nm_1L_chr = utl_unwtd_var_nm_1L_chr)
return(ds_descvs_ls)
}
make_ds_smry_ls <- function(candidate_predrs_chr,
candidate_covar_nms_chr,
depnt_var_nm_1L_chr,
dictionary_tb,
id_var_nm_1L_chr,
round_var_nm_1L_chr,
round_bl_val_1L_chr,
predictors_lup){
ds_smry_ls <- list(candidate_predrs_chr = candidate_predrs_chr,
candidate_covar_nms_chr = candidate_covar_nms_chr,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
dictionary_tb = dictionary_tb,
id_var_nm_1L_chr = id_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
round_bl_val_1L_chr = round_bl_val_1L_chr,
predictors_lup = predictors_lup)
return(ds_smry_ls)
}
# make_eq5d_ds_dict <- function(data_tb = make_fake_eq5d_ds(),
# predictors_lup = make_psych_predrs_lup()){
# dictionary_tb <- youthvars::make_tfd_repln_ds_dict_r3() %>%
# dplyr::filter(var_nm_chr %in% names(data_tb)) %>%
# youthvars::make_final_repln_ds_dict(additions_tb = ready4use::make_pt_ready4use_dictionary(var_nm_chr = c("uid",
# "Timepoint", "data_collection_dtm",
# paste0("eq5dq_",c("MO", "SC", "UA", "PD", "AD")),
# "EQ5D_total_dbl",
# "EQ5d_cumulative_dbl",
# predictors_lup$short_name_chr),
# var_ctg_chr = c("Identifier",
# rep("Temporal",2),
# rep("Multi-Attribute Utility Instrument Question",5),
# rep("Multi-Attribute Utility Instrument Score",2),
# c("Psychological distress", "Psychological wellbeing")),
# var_desc_chr = c("Unique identifier",
# "Data collection round",
# "Date of data collection",
# "EQ5D - Mobility domain score",
# "EQ5D - Self-Care domain score",
# "EQ5D - Usual Activities domain score",
# "EQ5D - Pain / Discomfort domain score",
# "EQ5D - Anxiety / Depression domain score",
# "EQ5D",
# "EQ5D - total unweighted score",
# predictors_lup$long_name_chr),
# var_type_chr = c("integer",
# "character","date",
# rep("integer",5),
# "double",
# "integer",
# predictors_lup$class_chr
# ))) %>%
# dplyr::arrange(var_ctg_chr)
# return(dictionary_tb)
# }
make_ethics_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$ethics_1L_chr),
"",
results_ls$study_descs_ls$ethics_1L_chr)
return(text_1L_chr)
}
# make_fake_eq5d_ds <- function(country_1L_chr = "UK",
# version_1L_chr = "5L",
# type_1L_chr = "CW",
# force_attach_1L_lgl = T,
# prop_with_fup_data_1L_dbl = 0.65,
# seed_1L_int = 1234,
# sample_from_1L_int = 10000){
# set.seed(seed_1L_int)
# # requireNamespace("eq5d")
# # if(force_attach_1L_lgl)
# # attachNamespace("eq5d")
# data_tb <- purrr::map(c("MO","SC","UA","PD","AD"),
# ~list(1:5) %>% stats::setNames(.x)) %>%
# purrr::flatten_dfr() %>%
# tidyr::expand(MO,SC,UA,PD,AD) %>%
# dplyr::mutate(total_eq5d = eq5d::eq5d(., country = country_1L_chr, version = version_1L_chr, type = type_1L_chr))
# k10_lup_tb <- tibble::tibble(K10_int = (9.5 + rexp(sample_from_1L_int,rate=0.18)) %>% purrr::map_int(~as.integer(min(max(.x,10),50))),
# predd_eq5d_dbl = purrr::map2_dbl(K10_int,rnorm(sample_from_1L_int,0,0.075), ~ predict_utl_from_k10(.x,
# eq5d_error_1L_dbl = .y)[2]),
# match_idx_int = purrr::map_int(predd_eq5d_dbl, ~which.min(abs(data_tb$total_eq5d-.x))))
# data_tb <- dplyr::left_join(k10_lup_tb,
# data_tb %>% dplyr::mutate(match_idx_int = 1:dplyr::n()))
# data_tb <- data_tb %>%
# dplyr::mutate(Timepoint = total_eq5d %>%
# purrr::map2_chr(runif(sample_from_1L_int),
# ~{
# p_1L_dbl <- ifelse(.x>median(data_tb$total_eq5d),0.55,0.45)
# ifelse(.y>p_1L_dbl,"FUP","BL")
# })) %>%
# dplyr::group_by(Timepoint) %>%
# dplyr::mutate(uid = 1:dplyr::n()) %>%
# dplyr::ungroup() %>%
# dplyr::arrange(uid, Timepoint)
# bl_uids_chr <- data_tb %>% dplyr::filter(Timepoint == "BL") %>% dplyr::pull(uid)
# fup_uids_chr <- sample(bl_uids_chr,round((prop_with_fup_data_1L_dbl * length(bl_uids_chr)),0))
# data_tb <- data_tb %>%
# dplyr::filter(uid %in% bl_uids_chr) %>%
# dplyr::filter(Timepoint == "BL" | uid %in% fup_uids_chr)
# data_tb <- data_tb %>%
# dplyr::mutate(Psych_well_int = faux::rnorm_pre(K10_int, mu = 69.9, sd = 9.9, r = -0.56) %>%
# round(0) %>% purrr::map_int(~min(.x,90) %>% max(18) %>%
# as.integer()))
# data_tb <- data_tb %>% dplyr::select(uid,Timepoint,MO,SC,UA,PD,AD,K10_int,Psych_well_int)
# data("replication_popl_tb", package = "youthvars", envir = environment())
# demog_data_tb <- replication_popl_tb %>%
# youthvars::transform_raw_ds_for_analysis() %>%
# dplyr::filter(round == "Baseline") %>%
# dplyr::mutate(uid = 1:dplyr::n()) %>%
# dplyr::select(uid,
# d_interview_date,
# d_age,
# Gender,
# d_sex_birth_s,
# d_sexual_ori_s,
# d_relation_s,
# d_ATSI,
# CALD,
# Region,
# d_studying_working) %>%
# dplyr::rename(data_collection_dtm =
# d_interview_date)
# data_tb <- dplyr::left_join(data_tb %>%
# dplyr::filter(uid %in% demog_data_tb$uid),
# demog_data_tb) %>%
# dplyr::select(uid,
# Timepoint,
# data_collection_dtm,
# d_age,
# Gender,
# d_sex_birth_s,
# d_sexual_ori_s,
# d_relation_s,
# d_ATSI,
# CALD,
# Region,
# d_studying_working,
# dplyr::everything()) %>%
# dplyr::rename_with(~stringr::str_c("eq5dq_", .), .cols = c("MO", "SC", "UA", "PD", "AD")) %>%
# dplyr::mutate(data_collection_dtm = dplyr::case_when(Timepoint == "FUP" ~ data_collection_dtm + lubridate::days(120),
# T ~ data_collection_dtm))
# data_tb <- data_tb %>%
# dplyr::mutate(d_age = dplyr::case_when(Timepoint == "FUP" ~ d_age %>% purrr::map2_int(runif(nrow(data_tb)), ~ ifelse((.y + 120/365.25)>=1,.x+1L,.x)),
# T ~ d_age))
# return(data_tb)
# }
make_fake_ts_data <- function (outp_smry_ls, depnt_var_min_val_1L_dbl = numeric(0),
depnt_vars_are_NA_1L_lgl = T) {
data_tb <- outp_smry_ls$scored_data_tb %>% transform_tb_to_mdl_inp(depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr,
predr_vars_nms_chr = outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>% unique(),
id_var_nm_1L_chr = outp_smry_ls$id_var_nm_1L_chr,
round_var_nm_1L_chr = outp_smry_ls$round_var_nm_1L_chr,
round_bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr,
scaling_fctr_dbl = outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>% unique() %>%
purrr::map_dbl(~ifelse(.x %in% outp_smry_ls$predictors_lup$short_name_chr,
ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "mdl_scaling_dbl"),
1)),
tidy_1L_lgl = T)
fk_data_ls <- synthpop::syn(data_tb, visit.sequence = names(data_tb)[names(data_tb) !=
outp_smry_ls$id_var_nm_1L_chr], seed = outp_smry_ls$seed_1L_int)
fk_data_tb <- fk_data_ls$syn
if (identical(outp_smry_ls$round_var_nm_1L_chr, character(0)) |
ifelse(identical(outp_smry_ls$round_var_nm_1L_chr, character(0)),
T, is.na(outp_smry_ls$round_var_nm_1L_chr))) {
fk_data_tb <- fk_data_tb %>% dplyr::ungroup()
}
else {
fk_data_tb <- fk_data_tb %>% dplyr::mutate(`:=`(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr),
as.character(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr)))) %>%
dplyr::group_by(!!rlang::sym(outp_smry_ls$id_var_nm_1L_chr)) %>%
dplyr::mutate(`:=`(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr),
!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr) %>%
transform_timepoint_vals(timepoint_levels_chr = outp_smry_ls$scored_data_tb %>%
dplyr::pull(!!rlang::sym(outp_smry_ls$round_var_nm_1L_chr)) %>%
unique(), bl_val_1L_chr = outp_smry_ls$round_bl_val_1L_chr))) %>%
dplyr::ungroup()
}
if (depnt_vars_are_NA_1L_lgl) {
depnt_vars_chr <- names(fk_data_tb)[names(fk_data_tb) %>%
purrr::map_lgl(~startsWith(.x, outp_smry_ls$depnt_var_nm_1L_chr))]
fk_data_tb <- fk_data_tb %>% dplyr::mutate(dplyr::across(dplyr::all_of(depnt_vars_chr),
~NA_real_))
}
return(fk_data_tb)
}
make_folds_ls <- function (data_tb, # Generalise for use by heterodox
depnt_var_nm_1L_chr = "utl_total_w",
folds_1L_int = 10L)
{
folds_ls <- caret::createFolds(data_tb %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
k = folds_1L_int, list = TRUE, returnTrain = FALSE)
return(folds_ls)
}
make_funding_text <- function(results_ls){
text_1L_chr <- ifelse(is.null(results_ls$study_descs_ls$funding_1L_chr),
"",
results_ls$study_descs_ls$funding_1L_chr)
return(text_1L_chr)
}
make_hlth_utl_and_predrs_ls <- function(outp_smry_ls, # Generalise from HU
descv_tbls_ls,
nbr_of_digits_1L_int = 2L,
old_nms_chr = NULL,
new_nms_chr = NULL){
ranked_predrs_ls <- make_ranked_predrs_ls(descv_tbls_ls,
old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
var_nm_1L_chr <- descv_tbls_ls$ds_descvs_ls$dictionary_tb %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "var_nm_chr",
match_value_xx = outp_smry_ls$depnt_var_nm_1L_chr,
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F) %>% as.vector()
hlth_utl_and_predrs_ls = list(bl_hu_mean_1L_dbl = descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],
"_val_1_dbl"),
evaluate_1L_lgl = F) %>%
as.numeric() %>%
round(nbr_of_digits_1L_int),
bl_hu_sd_1L_dbl = descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[1],
"_val_2_ls"),
evaluate_1L_lgl = F) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric() %>%
round(nbr_of_digits_1L_int),
fup_hu_mean_1L_dbl = ifelse(length(descv_tbls_ls$ds_descvs_ls$round_vals_chr)<2,
NA_real_,
descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[2],
"_val_1_dbl"),
evaluate_1L_lgl = F) %>%
as.numeric() %>%
round(nbr_of_digits_1L_int)),
fup_hu_sd_1L_dbl = ifelse(length(descv_tbls_ls$ds_descvs_ls$round_vals_chr)<2,
NA_real_,
descv_tbls_ls$main_outc_tbl_tb %>%
dplyr::filter(label == "Mean (SD)") %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "variable",
match_value_xx = var_nm_1L_chr,
target_var_nm_1L_chr = paste0(descv_tbls_ls$ds_descvs_ls$round_vals_chr[2],
"_val_2_ls"),
evaluate_1L_lgl = F) %>%
stringr::str_remove("\\(") %>%
stringr::str_remove("\\)") %>%
as.numeric() %>%
round(nbr_of_digits_1L_int)),
predrs_nartv_seq_chr = ranked_predrs_ls$unranked_predrs_chr,
cor_seq_dscdng_chr = ranked_predrs_ls$ranked_predrs_chr)
return(hlth_utl_and_predrs_ls)
}
make_incld_mdl_paths <- function(outp_smry_ls){
incld_mdl_paths_chr <- outp_smry_ls$file_paths_chr %>%
purrr::map_chr(~{
file_path_1L_chr <- .x
mdl_fl_nms_chr <- paste0(outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr(),".RDS")
mdl_fl_nms_locn_ls <- mdl_fl_nms_chr %>% purrr::map(~stringr::str_locate(file_path_1L_chr,.x))
match_lgl <- mdl_fl_nms_locn_ls %>% purrr::map_lgl(~!(is.na(.x[[1,1]]) | is.na(.x[[1,2]])))
if(any(match_lgl)){
file_path_1L_chr
}else{
NA_character_
}
})
incld_mdl_paths_chr <- incld_mdl_paths_chr[!is.na(incld_mdl_paths_chr)]
ranked_mdl_nms_chr <- outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr()
sorted_mdl_nms_chr <- sort(ranked_mdl_nms_chr)
rank_indcs_int <- purrr::map_int(sorted_mdl_nms_chr,~which(ranked_mdl_nms_chr==.x))
incld_mdl_paths_chr <- incld_mdl_paths_chr[order(rank_indcs_int)]
return(incld_mdl_paths_chr)
}
make_indpnt_predrs_lngl_tbls_ref <- function(params_ls){
results_ls <- params_ls$results_ls
n_mdls_1L_int <- length(results_ls$ttu_lngl_ls$best_mdls_tb$model_type)
text_1L_chr <- paste0(ifelse(params_ls$output_type_1L_chr=="Word","","Table"),
ifelse(n_mdls_1L_int < 3,
" \\@ref(tab:cfscl)",
paste0("s ",
paste0("\\@ref(tab:cfscl",1:n_mdls_1L_int,")", collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
))
)
return(text_1L_chr)
}
make_indpnt_predrs_lngl_tbl_title <- function (results_ls, ref_1L_int = 1)# Generalise from HU
{
title_1L_chr <- paste0("Estimated coefficients for single predictor longitudinal models using ",
results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,
"model_type"]], " (", results_ls$ttu_lngl_ls$best_mdls_tb[[ref_1L_int,
"link_and_tfmn_chr"]], ")")
return(title_1L_chr)
}
make_inner_loop_mdl_smry <- function(idx_1L_int,
data_tb,
mdl_nms_ls,
mdl_smry_dir_1L_chr,
mdl_types_lup,
predictors_lup,
predr_vars_nms_ls,
backend_1L_chr = getOption("brms.backend", "rstan"),
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w",
id_var_nm_1L_chr = "fkClientID",
iters_1L_int = 4000L,
options_chr = c("Y", "N"),
prior_ls = NULL,
round_var_nm_1L_chr = "round",
round_bl_val_1L_chr = "Baseline",
seed_1L_int = 1000L,
utl_min_val_1L_dbl = -1){
mdls_smry_tb <- purrr::map_dfr(mdl_nms_ls[[idx_1L_int]], ~{
smry_ls <- make_smry_of_ts_mdl_outp(backend_1L_chr = backend_1L_chr,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
control_ls = control_ls,
data_tb = data_tb,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
id_var_nm_1L_chr = id_var_nm_1L_chr,
iters_1L_int = iters_1L_int,
predr_vars_nms_chr = predr_vars_nms_ls[[idx_1L_int]],
mdl_nm_1L_chr = .x,
mdl_types_lup = mdl_types_lup,
options_chr = options_chr,
path_to_write_to_1L_chr = mdl_smry_dir_1L_chr,
predictors_lup = predictors_lup,
prior_ls = prior_ls,
round_bl_val_1L_chr = round_bl_val_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl,
seed_1L_int = seed_1L_int)
Sys.sleep(5)
smry_ls$smry_of_ts_mdl_tb
})
return(mdls_smry_tb)
}
make_input_params <- function(ds_tb, # Generalise MAUI
ds_descvs_ls,
header_yaml_args_ls,
maui_params_ls,
predictors_lup,
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
dv_ds_nm_and_url_chr = NULL,
iters_1L_int = 4000L,
mdl_smry_ls = make_mdl_smry_ls(),
options_chr = c("Y", "N"),
output_format_ls = make_output_format_ls(),
path_params_ls = NULL,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
prior_ls = NULL,
seed_1L_int = 12345,
scndry_anlys_params_ls = NULL,
write_new_dir_1L_lgl = T){
path_params_ls <- ready4show::make_path_params_ls(use_fake_data_1L_lgl = ds_descvs_ls$is_fake_1L_lgl,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
dv_ds_nm_and_url_chr = dv_ds_nm_and_url_chr,
options_chr = options_chr,
write_new_dir_1L_lgl = write_new_dir_1L_lgl)
params_ls_ls <- make_analysis_core_params_ls(ds_descvs_ls = ds_descvs_ls,
output_format_ls = output_format_ls,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
mdl_smry_ls = mdl_smry_ls,
control_ls = control_ls,
iters_1L_int = iters_1L_int,
prior_ls = prior_ls,
seed_1L_int = seed_1L_int) %>%
make_valid_params_ls_ls(ds_tb = ds_tb,
maui_params_ls = maui_params_ls,
path_params_ls = path_params_ls)
params_ls_ls$header_yaml_args_ls <- header_yaml_args_ls
params_ls_ls$output_format_ls <- output_format_ls
params_ls_ls$scndry_anlys_params_ls <- scndry_anlys_params_ls
return(params_ls_ls)
}
make_knit_pars_ls <- function (rltv_path_to_data_dir_1L_chr, mdl_types_chr, predr_vars_nms_ls,
output_type_1L_chr = "HTML", mdl_types_lup = NULL, plt_types_lup = NULL,
plt_types_chr = NA_character_, section_type_1L_chr = "#")
{
if (is.null(mdl_types_lup))
utils::data(mdl_types_lup, envir = environment())
if (is.null(plt_types_lup))
utils::data(plt_types_lup, envir = environment())
if(is.na(plt_types_chr)){
plt_types_chr <- plt_types_lup$short_name_chr
}
paths_to_all_data_fls_chr <- list.files(rltv_path_to_data_dir_1L_chr,full.names = T)
lab_idx_dbl <- 1:(length(mdl_types_chr) * length(predr_vars_nms_ls))
knit_pars_ls <- purrr::pmap(list(predr_vars_nms_ls,
split(lab_idx_dbl,
ceiling(seq_along(lab_idx_dbl)/length(mdl_types_chr))),
make_mdl_nms_ls(predr_vars_nms_ls,
mdl_types_chr = mdl_types_chr)),
~{
mdl_nms_chr <- ..3
mdl_data_paths_ls <- mdl_nms_chr %>%
purrr::map(~paths_to_all_data_fls_chr[stringr::str_detect(paths_to_all_data_fls_chr,.x)]) %>%
stats::setNames(mdl_nms_chr)
paths_to_mdls_chr <- mdl_data_paths_ls %>%
purrr::map_chr(~ifelse(identical(.x[endsWith(.x,".RDS")],character(0)),
NA_character_,
.x[endsWith(.x,".RDS")]
)) %>% unname()
paths_to_mdl_plts_ls <- mdl_data_paths_ls %>%
purrr::map(~{
paths_to_all_plots_chr <- .x[endsWith(.x,".png")]
plt_types_chr %>%
purrr::map(~ {
sfx_1L_chr <- paste0(.x,".png")
paths_to_all_plots_chr[paths_to_all_plots_chr %>%
purrr::map_lgl(~endsWith(.x,sfx_1L_chr))][paths_to_all_plots_chr[paths_to_all_plots_chr %>%
purrr::map_lgl(~endsWith(.x,sfx_1L_chr))] %>%
nchar() %>%
which.min()]
}) %>%
purrr::flatten_chr() %>% unique()
})
mdl_tots_chr <- paste0(..1[1], ifelse(is.na(..1[2]),
"",
paste(" with ", ..1[2])),
" ",
mdl_types_chr %>% purrr::map_chr(~paste0(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "mixed_type_chr",
evaluate_1L_lgl = F),
" with ",
ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F))))
section_tots_chr <- paste0(section_type_1L_chr, " ", mdl_tots_chr)
plt_nms_ls <- paths_to_mdl_plts_ls %>% purrr::map2(mdl_tots_chr,~{
paths_to_mdl_plts_chr <- .x
mdl_tot_1L_chr <- .y
transform_1L_lgl <- paths_to_mdl_plts_chr %>% endsWith("_coefs.png") %>% any()
if(paths_to_mdl_plts_chr %>% endsWith("_hetg.png") %>% any())
transform_1L_lgl <- F # ALL OF THIS TFMN LOGIC CAN BE BINNED WHEN NEW CATEGORY OF PLOT TYPE IS ADDED.
plt_types_chr %>% purrr::map(~{
if(endsWith(paths_to_mdl_plts_chr,paste0("_",.x,".png")) %>% any()){
paste0(mdl_tot_1L_chr,
" ",
ifelse(transform_1L_lgl & .x == "coefs",
"population and group level effects",
ready4::get_from_lup_obj(plt_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "long_name_chr",
evaluate_1L_lgl = F)))
}else{
character(0)
}}) %>% purrr::flatten_chr()
})
list(plt_nms_ls = plt_nms_ls,
paths_to_mdls_chr = paths_to_mdls_chr,
tbl_captions_chr = mdl_tots_chr,
label_stubs_chr = paste0("lab", ..2),
output_type_1L_chr = output_type_1L_chr,
section_tots_chr = section_tots_chr,
paths_to_mdl_plts_ls = paths_to_mdl_plts_ls)
}) %>%
stats::setNames(predr_vars_nms_ls %>% purrr::map_chr(~paste(.x,collapse="_")))
return(knit_pars_ls)
}
make_lngl_ttu_r2_text <- function(results_ls, # rename / generalise TTU
part_int = 1){
if(1 %in% part_int){
text_1L_chr <- ifelse(length(results_ls$candidate_predrs_chr) == 1,
"",
paste0("In ",
ifelse(length(results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique())>1,
"",
ifelse(nrow(results_ls$ttu_lngl_ls$best_mdls_tb)==2,
"both ",
"all ")),
results_ls$ttu_lngl_ls$best_mdls_tb$model_type %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" models, the prediction models using ",
ifelse(length(results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique())==1,
results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>% unique(),
results_ls$ttu_lngl_ls$best_mdls_tb$name_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" respectively")),
" had the highest R^2^ (",
results_ls$ttu_lngl_ls$best_mdls_tb$r2_dbl %>%
stringr::str_squish() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
")"))
}else{
text_1L_chr <- ""
}
if(2 %in% part_int){
mdl_types_chr <- results_ls$ttu_lngl_ls$best_mdls_tb$model_type
mdl_r2_var_nms_chr <- intersect(results_ls$tables_ls$ind_preds_coefs_tbl %>% names(),
c("R2_OLS_CLL","R2_GLM_GSN_LOG"))
mdl_r2_mins_dbl <- mdl_r2_var_nms_chr %>%
purrr::map_dbl(~results_ls$tables_ls$ind_preds_coefs_tbl %>%
dplyr::filter(!is.na(!!rlang::sym(.x))) %>%
dplyr::pull(!!rlang::sym(.x)) %>%
as.numeric() %>%
min())
mdl_r2_maxs_dbl <- mdl_r2_var_nms_chr %>%
purrr::map_dbl(~results_ls$tables_ls$ind_preds_coefs_tbl %>%
dplyr::filter(!is.na(!!rlang::sym(.x))) %>%
dplyr::pull(!!rlang::sym(.x)) %>%
as.numeric() %>%
max())
part_2_main_1L_chr <- list(mdl_types_chr,
mdl_r2_mins_dbl,
mdl_r2_maxs_dbl,
1:length(mdl_types_chr)) %>%
purrr::pmap_chr(~ paste0(ifelse(..4 == 1,"R^2^ was ",""),
ifelse(length(results_ls$candidate_predrs_chr) == 1,
paste0(,..2, " for the "),
paste0(ifelse(..2==..3,
paste0("",..2),
paste0("between ",..2," and ",..3," for all ")))),
..1,
ifelse(length(results_ls$candidate_predrs_chr) == 1,
paste0(""),
paste0("s"))
)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
text_1L_chr <- paste0(text_1L_chr,
ifelse(1 %in% part_int,". ",""),
part_2_main_1L_chr ,
ifelse(part_2_main_1L_chr=="","","."))
}
return(text_1L_chr)
}
make_lngl_ttu_with_covars_text <- function(results_ls){ # rename / generalise TTU
text_1L_chr <- ifelse((is.na(results_ls$ttu_lngl_ls$incld_covars_chr[1]) | length(results_ls$ttu_lngl_ls$incld_covars_chr) == 0),
"",
paste0("We also evaluated models with ",
results_ls$ttu_lngl_ls$incld_covars_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" at baseline"),
" and ",
results_ls$ttu_lngl_ls$incld_covars_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and") %>%
paste0(" change from baseline"),
" added to ",
names(results_ls$study_descs_ls$predr_ctgs_ls) %>%
tolower() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" predictors"))
return(text_1L_chr )
}
make_maui_params_ls <- function(maui_itm_short_nms_chr, # Leave in TTU?
maui_domains_pfxs_1L_chr = NULL,
maui_scoring_fn = NULL,
short_and_long_nm = NULL,
utl_min_val_1L_dbl = -1){
if(is.null(maui_scoring_fn)){
maui_scoring_fn <- function(data_tb,
maui_item_pfx_1L_chr,
id_var_nm_1L_chr,
utl_wtd_var_nm_1L_chr,
utl_unwtd_var_nm_1L_chr){
data_tb %>%
dplyr::mutate(`:=`(!!rlang::sym(utl_unwtd_var_nm_1L_chr),
rowSums(dplyr::across(dplyr::starts_with(maui_item_pfx_1L_chr))))) %>%
dplyr::filter(!is.na(!!rlang::sym(utl_unwtd_var_nm_1L_chr)))
}
}
maui_params_ls <- list(maui_domains_pfxs_1L_chr = maui_domains_pfxs_1L_chr,
maui_itm_short_nms_chr = maui_itm_short_nms_chr,
maui_scoring_fn = maui_scoring_fn,
short_and_long_nm = short_and_long_nm,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
return(maui_params_ls)
}
make_mdl <- function (data_tb,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr, covar_var_nms_chr = NA_character_, mdl_type_1L_chr = "OLS_NTF",
mdl_types_lup = NULL, control_1L_chr = NA_character_, start_1L_chr = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment())
data_tb <- transform_ds_for_mdlng(data_tb, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr, depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr)
if (is.null(start_1L_chr)) {
start_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "start_chr", evaluate_1L_lgl = F)
}
if (!is.na(control_1L_chr)) {
idx_1L_int <- 1 + stringi::stri_locate_last_fixed(mdl_type_1L_chr,
"_")[1, 1] %>% as.vector()
link_1L_chr <- get_link_from_tfmn(stringr::str_sub(mdl_type_1L_chr, start = idx_1L_int))
}
mdl_1L_chr <- paste0(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "fn_chr", evaluate_1L_lgl = F), "(",
transform_depnt_var_nm(depnt_var_nm_1L_chr, tfmn_1L_chr = tfmn_1L_chr),
" ~ ", predr_var_nm_1L_chr, ifelse(is.na(covar_var_nms_chr[1]),
"", paste0(" + ", paste0(covar_var_nms_chr, collapse = " + "))),
", data = data_tb", ifelse(!is.na(ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr", evaluate_1L_lgl = F)),
paste0(", family = ", ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr", evaluate_1L_lgl = F)),
""), ifelse((!is.na(start_1L_chr)|(is.na(start_1L_chr) & !is.na(control_1L_chr))), ", ", ""), ifelse(!is.na(control_1L_chr),
paste0("link=\"", link_1L_chr, "\",control=", control_1L_chr,
"("), ""), ifelse(!is.na(start_1L_chr), paste0("start=c(",
start_1L_chr, ")"), ""), ifelse(!is.na(control_1L_chr),
")", ""), ")")
model_mdl <- eval(parse(text = mdl_1L_chr))
return(model_mdl)
}
make_mdl_coef_range_text <- function(coef_ratios_dbl,
nbr_of_digits_1L_int = 2L){
if(length(coef_ratios_dbl) == 1){
coef_range_text_chr <- as.character(round(coef_ratios_dbl, nbr_of_digits_1L_int))
}else{
min_1L_dbl <- round(min(coef_ratios_dbl), nbr_of_digits_1L_int)
max_1L_dbl <- round(max(coef_ratios_dbl), nbr_of_digits_1L_int)
coef_range_text_chr <- paste0("between ", min_1L_dbl," and ", max_1L_dbl)
}
return(coef_range_text_chr)
}
make_mdl_coef_ratio_ls <- function(mdl_ingredients_ls,
predr_ctgs_ls = NULL){
predrs_chr <- mdl_ingredients_ls$predictors_lup$short_name_chr
mdl_type_chr <- mdl_ingredients_ls$mdls_smry_tb$Model %>%
unique() %>%
purrr::map_chr(~get_mdl_type_from_nm(.x,
mdl_types_lup = mdl_ingredients_ls$mdl_types_lup)) %>%
unique()
main_mdls_ls <- predrs_chr %>% purrr::map(~paste0(paste0(.x,"_1_"),
mdl_type_chr))
ratios_ls <- main_mdls_ls %>%
purrr::map2(predrs_chr, ~{
mdls_chr <- .x
predr_1L_chr <- .y
mdls_chr %>% purrr::map_dbl(~{
coefs_dbl <- mdl_ingredients_ls$mdls_smry_tb %>% dplyr::filter(Model %in% .x) %>%
dplyr::filter(Parameter %in% paste0(predr_1L_chr,(c(" baseline", " scaled", " unscaled",
" change")))) %>%
dplyr::pull(Estimate)
coefs_dbl[2]/coefs_dbl[1]
})
}
) %>% stats::setNames(predrs_chr)
mdl_coef_ratios_ls = list(mean_ratios_dbl = ratios_ls %>% purrr::map_dbl(~mean(.x)))
if(!is.null(predr_ctgs_ls)){
append_ls <- purrr::map(predr_ctgs_ls,
~ mdl_coef_ratios_ls$mean_ratios_dbl[predrs_chr %in% .x]) %>%
stats::setNames(names(predr_ctgs_ls))
mdl_coef_ratios_ls <- append(mdl_coef_ratios_ls, append_ls)
}
return(mdl_coef_ratios_ls)
}
make_mdl_desc_lines <- function (outp_smry_ls,
mdl_nm_1L_chr,
output_type_1L_chr = "PDF"){
mdl_smry_tb <- outp_smry_ls$mdls_smry_tb %>% dplyr::filter(Model ==
mdl_nm_1L_chr)
predictors_chr <- mdl_smry_tb$Parameter[!mdl_smry_tb$Parameter %in%
c("SD (Intercept)", "Intercept", "R2", "RMSE", "Sigma")] %>%
purrr::map_chr(~stringr::str_remove(.x, " baseline") %>%
stringr::str_remove(" change") %>% stringr::str_remove(" scaled") %>% stringr::str_remove(" unscaled")) %>%
unique()
predictors_desc_chr <- predictors_chr %>% purrr::map_chr(~{
scaling_1L_dbl <- ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
match_value_xx = .x, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "mdl_scaling_dbl", evaluate_1L_lgl = F)
paste0(.x, " (", ready4::get_from_lup_obj(outp_smry_ls$dictionary_tb,
match_value_xx = .x, match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_desc_chr", evaluate_1L_lgl = F),
ifelse(scaling_1L_dbl == 1, "", paste0(" (multiplied by ",
scaling_1L_dbl, ")")), ")")
})
if (length(predictors_desc_chr) > 1)
predictors_desc_chr <- paste0(c(paste0("\n - ", predictors_desc_chr[-length(predictors_desc_chr)],
collapse = ";"), paste0("\n - ", predictors_desc_chr[length(predictors_desc_chr)])),
collapse = "; and")
mdl_desc_lines_chr <- paste0(paste0("This model predicts values at two timepoints for ",
ready4::get_from_lup_obj(outp_smry_ls$dictionary_tb,
match_value_xx = outp_smry_ls$depnt_var_nm_1L_chr,
match_var_nm_1L_chr = "var_nm_chr", target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F),
". The predictor variables are ",
"baseline values and subsequent changes in ", collapse = ""),
predictors_desc_chr,
". ",
"The catalogue reference for this model is ",
ifelse(output_type_1L_chr == "PDF",
paste0("\\texttt{\\detokenize{",
mdl_nm_1L_chr, "}}"),
mdl_nm_1L_chr),
".")
return(mdl_desc_lines_chr)
}
make_mdl_nms_ls <- function (predr_vars_nms_ls, mdl_types_chr)
{
mdl_nms_ls <- purrr::map2(predr_vars_nms_ls, make_unique_ls_elmt_idx_int(predr_vars_nms_ls),
~paste0(.x[1], "_", ifelse(is.na(.x[2]), "", paste0(.x[2],
"_")), .y, "_", mdl_types_chr))
return(mdl_nms_ls)
}
make_mdl_smry_elmt_tbl <- function (mat, ctg_chr)
{
tb <- mat %>% tibble::as_tibble() %>% dplyr::mutate(Parameter = rownames(mat)) %>%
dplyr::select(Parameter, dplyr::everything())
mdl_elmt_sum_tb <- tb %>% dplyr::filter(F) %>% tibble::add_case(Parameter = ctg_chr) %>%
dplyr::bind_rows(tb)
return(mdl_elmt_sum_tb)
}
make_mdl_smry_ls <- function(mdl_types_lup = get_cndts_for_mxd_mdls(),
mdl_types_chr = NULL,
choose_from_pfx_chr = NULL,
folds_1L_int = 10L,
max_nbr_of_boruta_mdl_runs_int = 300L){
if(is.null(mdl_types_lup))
data("mdl_types_lup",
package = "specific", #
envir = environment())
if(is.null(mdl_types_chr))
mdl_types_chr <- mdl_types_lup$short_name_chr
if(is.null(choose_from_pfx_chr))
choose_from_pfx_chr <- stringr::word(mdl_types_lup$short_name_chr,1,sep="\\_") %>% unique()
mdl_smry_ls <- list(mdl_types_lup = mdl_types_lup,
mdl_types_chr = mdl_types_chr,
choose_from_pfx_chr = choose_from_pfx_chr,
folds_1L_int = folds_1L_int,
max_nbr_of_boruta_mdl_runs_int = max_nbr_of_boruta_mdl_runs_int)
return(mdl_smry_ls)
}
make_mdl_type_smry_tbl <- function(mdls_tb,
mdl_nms_chr,
mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = T){
mdl_type_smry_tbl_tb <- mdl_nms_chr %>%
purrr::map_dfr(~make_sngl_mdl_smry_tb(mdls_tb,
mdl_nm_1L_chr = .x,
mdl_type_1L_chr = mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = add_mdl_nm_sfx_1L_lgl))
return(mdl_type_smry_tbl_tb)
}
make_mdls_ls <- function(outp_smry_ls,
mdls_tb){
mdls_chr <- mdls_tb$Model %>% unique()
mdls_ls <- outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map(~mdls_chr[mdls_chr %>% endsWith(.x)])
return(mdls_ls)
}
make_mdls_smry_tbls_ls <- function(outp_smry_ls,
nbr_of_digits_1L_int = 2L){
mdls_smry_tb <- outp_smry_ls$mdls_smry_tb %>%
dplyr::mutate(dplyr::across(c("Estimate","SE"),
~ round(.x,nbr_of_digits_1L_int) %>%
format(nsmall = nbr_of_digits_1L_int))) %>%
dplyr::mutate(`95% CI` = `95% CI` %>% transform_chr_digit_pairs(nbr_of_digits_1L_int = nbr_of_digits_1L_int)) # Fix
rownames(mdls_smry_tb) <- NULL
indpt_predrs_mdls_tb <- mdls_smry_tb %>% dplyr::filter(Model %in% (paste0(outp_smry_ls$predr_cmprsn_tb$predr_chr,"_1_") %>% purrr::map(~paste0(.x,
outp_smry_ls$prefd_mdl_types_chr)) %>% purrr::flatten_chr()))
covar_mdls_tb <- mdls_smry_tb %>% dplyr::filter(!Model %in% indpt_predrs_mdls_tb$Model)
mdl_types_chr <- indpt_predrs_mdls_tb$Model %>% purrr::map_chr(~get_mdl_type_from_nm(.x,
mdl_types_lup = outp_smry_ls$mdl_types_lup)) %>%
unique()
prefd_predr_mdl_smry_tb <- mdl_types_chr %>%
purrr::map_dfr(~{
mdl_type_1L_chr <- .x
mdl_type_smry_tb <- indpt_predrs_mdls_tb %>%
dplyr::filter(Model %>% purrr::map_lgl(~endsWith(.x, mdl_type_1L_chr)))
max_r2_dbl <- mdl_type_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::pull(Estimate) %>%
as.numeric() %>%
abs() %>%
max()
prefd_mdl_1L_chr <- mdl_type_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::filter(as.numeric(Estimate) == max_r2_dbl) %>%
dplyr::pull(Model) %>%
purrr::pluck(1)
mdl_type_smry_tb %>%
dplyr::filter(Model == prefd_mdl_1L_chr)
})
mdls_smry_tbls_ls <- list(indpt_predrs_mdls_tb = indpt_predrs_mdls_tb,
covar_mdls_tb = covar_mdls_tb,
prefd_predr_mdl_smry_tb = prefd_predr_mdl_smry_tb)
return(mdls_smry_tbls_ls)
}
make_ms_smry_tbls_ls <- function(outp_smry_ls,
mdls_smry_tbls_ls,
covars_mdls_ls,
descv_tbls_ls,
nbr_of_digits_1L_int = 2L){
mdl_types_tables_ls <- purrr::map(1:length(outp_smry_ls$prefd_mdl_types_chr),
~ make_mdl_type_smry_tbl(mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb,
mdl_nms_chr = covars_mdls_ls[[.x]],
mdl_type_1L_chr = outp_smry_ls$prefd_mdl_types_chr[.x],
add_mdl_nm_sfx_1L_lgl = F)) %>%
stats::setNames(1:length(outp_smry_ls$prefd_mdl_types_chr) %>%
purrr::map_chr(~paste0("mdl_type_",.x,"_covar_mdls_tb")))
ms_smry_tbls_ls <- append(mdl_types_tables_ls,
list(ind_preds_coefs_tbl = make_all_mdl_types_smry_tbl(outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$indpt_predrs_mdls_tb),
participant_descs = descv_tbls_ls$cohort_desc_tb,
predd_dist_and_cors = descv_tbls_ls$predr_pars_and_cors_tb,
tenf_prefd_mdl_tb = outp_smry_ls[["smry_of_mdl_sngl_predrs_tb"]] %>%
tibble::as_tibble() %>%
dplyr::mutate(dplyr::across(where(is.numeric), ~ .x %>% purrr::map_dbl(~min(max(.x,-1.1),1.1)))) %>%
transform_tbl_to_rnd_vars(nbr_of_digits_1L_int = nbr_of_digits_1L_int) %>%
dplyr::mutate(dplyr::across(.cols = dplyr::everything(), ~ .x %>%
stringr::str_replace_all("-1.10","< -1.00") %>%
stringr::str_replace_all("1.10","> 1.00"))),
tenf_sngl_predr_tb = make_tfd_sngl_predr_mdls_tb(outp_smry_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)))
return(ms_smry_tbls_ls)
}
make_nbr_included_text <- function(results_ls){
paste0(ifelse(results_ls$cohort_ls$n_inc_1L_dbl == results_ls$cohort_ls$n_all_1l_dbl,
"all ",
paste0(results_ls$cohort_ls$n_inc_1L_dbl,
" out of the ")),
results_ls$cohort_ls$n_all_1l_dbl,
" participants with complete ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" data")
}
make_nbr_at_fup_text <- function(results_ls){
nbr_at_fup_1L_chr <- paste0("There were ",
results_ls$cohort_ls$n_fup_1L_dbl,
" participants (",
(results_ls$cohort_ls$n_fup_1L_dbl / results_ls$cohort_ls$n_inc_1L_dbl * 100) %>% round(1),
"%) who completed ",
results_ls$study_descs_ls$health_utl_nm_1L_chr,
" questions at the follow-up survey ",
results_ls$study_descs_ls$time_btwn_bl_and_fup_1L_chr,
" after baseline assessment."
)
return(nbr_at_fup_1L_chr)
}
make_paths_to_ms_smry_plts_ls <- function(output_data_dir_1L_chr,
outp_smry_ls,
additional_paths_chr = "/dens_and_sctr.png"){
paths_to_ms_smry_plts_ls = list(combined_utl = paste0(output_data_dir_1L_chr,"/_Descriptives/combined_utl.png"),
composite = paste0(output_data_dir_1L_chr,additional_paths_chr[1]),
items = paste0(output_data_dir_1L_chr,"/_Descriptives/qstn_rspns.png"),
density = paste0(output_data_dir_1L_chr,"/",outp_smry_ls$file_paths_chr[outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"A_TFMN_CMPRSN_DNSTY"))]),#paste0(output_data_dir_1L_chr,"/A_TFMN_CMPRSN_DNSTY.png"), #Update
importance = paste0(output_data_dir_1L_chr,"/",outp_smry_ls$file_paths_chr[outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"B_PRED_CMPRSN_BORUTA_VAR_IMP"))]))
return(paths_to_ms_smry_plts_ls)
}
make_plot_fn_and_args_ls <- function(type_1L_chr,
depnt_var_desc_1L_chr,
args_ls = NULL,
base_size_1L_dbl = 11,
brms_mdl = NULL,
correspondences_lup = NULL,
depnt_var_nm_1L_chr = NULL,
new_var_nm_1L_chr = NA_character_,
predn_type_1L_chr = NULL,
round_var_nm_1L_chr = NULL,
sd_dbl = NA_real_,
seed_1L_dbl = 23456,
sfx_1L_chr = " from table",
table_predn_mdl = NULL,
tfmn_1L_chr = "NTF",
tfd_data_tb = NULL,
utl_min_val_1L_dbl = -1,
x_lbl_1L_chr = NA_character_,
y_lbl_1L_chr = NA_character_){
if(!is.null(brms_mdl)){
set.seed(seed_1L_dbl)
tfd_data_tb <- transform_ds_for_all_cmprsn_plts(tfd_data_tb = tfd_data_tb,
model_mdl = brms_mdl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
is_brms_mdl_1L_lgl = inherits(brms_mdl,"brmsfit"),
predn_type_1L_chr = predn_type_1L_chr,
sd_dbl = NA_real_,
sfx_1L_chr = ifelse(is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
if(!is.null(table_predn_mdl)){
tfd_data_tb <- transform_ds_for_all_cmprsn_plts(tfd_data_tb = tfd_data_tb,
model_mdl = table_predn_mdl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
is_brms_mdl_1L_lgl = F,
predn_type_1L_chr = predn_type_1L_chr,
sd_dbl = sd_dbl,
sfx_1L_chr = ifelse(!is.null(brms_mdl),
" from table",
sfx_1L_chr),
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
}
}
ref_idx_1L_int <- which(type_1L_chr == c("coefs", "hetg",
"dnst", "sctr_plt",
"sim_dnst", "sim_sctr",
"cnstrd_dnst", "cnstrd_sctr_plt",
"cnstrd_sim_dnst", "cnstrd_sim_sctr"))
if (ref_idx_1L_int %in% c(3,5,7,9)) {
plt_fn <- plot_obsd_predd_dnst
fn_args_ls <- list(tfd_data_tb = tfd_data_tb,
base_size_1L_dbl = base_size_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
new_var_nm_1L_chr = new_var_nm_1L_chr,
predd_val_var_nm_1L_chr = ifelse(ref_idx_1L_int %in% c(3,7),
transform_predd_var_nm("Predicted",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 3, ####
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 5,
NA_real_,
utl_min_val_1L_dbl))),
cmprsn_predd_var_nm_1L_chr = ifelse(is.null(table_predn_mdl),
NA_character_,
ifelse(ref_idx_1L_int %in% c(3,7), ##
transform_predd_var_nm("Predicted",
sfx_1L_chr = " from table",
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 3, ##
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr =" from table",
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 5, ##
NA_real_,
utl_min_val_1L_dbl)))))
}else{
plt_fn <- plot_obsd_predd_sctr_cmprsn
fn_args_ls <- list(tfd_data_tb = tfd_data_tb,
base_size_1L_dbl = base_size_1L_dbl,
correspondences_lup = correspondences_lup,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_desc_1L_chr = depnt_var_desc_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
predd_val_var_nm_1L_chr = ifelse(ref_idx_1L_int %in% c(4,8),
transform_predd_var_nm("Predicted",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 4,
NA_real_,
utl_min_val_1L_dbl)),
transform_predd_var_nm("Simulated",
sfx_1L_chr = ifelse(!is.null(table_predn_mdl),
" from brmsfit",
sfx_1L_chr),
utl_min_val_1L_dbl = ifelse(ref_idx_1L_int == 6,
NA_real_,
utl_min_val_1L_dbl))),
args_ls = args_ls,
x_lbl_1L_chr = x_lbl_1L_chr,
y_lbl_1L_chr = y_lbl_1L_chr)
}
plot_fn_and_args_ls <- list(plt_fn = plt_fn,
fn_args_ls = fn_args_ls)
return(plot_fn_and_args_ls)
}
make_predn_ds_with_one_predr <- function(model_mdl,
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr, predr_vals_dbl, predn_type_1L_chr = NULL)
{
predn_ds_tb <- tibble::tibble(`:=`(!!rlang::sym(predr_var_nm_1L_chr),
predr_vals_dbl))
predn_ds_tb <- predn_ds_tb %>% dplyr::mutate(`:=`(!!rlang::sym(depnt_var_nm_1L_chr),
stats::predict(model_mdl, newdata = predn_ds_tb, type = predn_type_1L_chr) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr,
tfmn_is_outp_1L_lgl = T)))
return(predn_ds_tb)
}
make_predr_ctgs_ls <- function(outp_smry_ls,
include_idx_int = NULL){
predictors_chr <- outp_smry_ls$predr_vars_nms_ls %>% purrr::flatten_chr() %>% unique()
categories_chr <- predictors_chr %>%
purrr::map_chr(~outp_smry_ls$dictionary_tb %>%
ready4::get_from_lup_obj(match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_ctg_chr",
evaluate_1L_lgl = F)) %>% unique()
predr_ctgs_ls <- categories_chr %>% purrr::map(~outp_smry_ls$dictionary_tb %>%
ready4use::remove_labels_from_ds() %>%
dplyr::filter(var_ctg_chr == .x) %>%
dplyr::pull(var_nm_chr) %>%
intersect(predictors_chr)) %>%
stats::setNames(categories_chr)
if(!is.null(include_idx_int)){
predr_ctgs_ls <- include_idx_int %>%
purrr::map(~predr_ctgs_ls %>% purrr::pluck(.x)) %>%
stats::setNames(categories_chr[include_idx_int])
}
return(predr_ctgs_ls)
}
make_predr_vals <- function (predr_var_nm_1L_chr, candidate_predrs_lup = NULL)
{
if (is.null(candidate_predrs_lup)) {
utils::data("candidate_predrs_lup", envir = environment())
}
args_ls <- purrr::map_dbl(names(candidate_predrs_lup)[3:4],
~candidate_predrs_lup %>% ready4::get_from_lup_obj(match_value_xx = predr_var_nm_1L_chr,
match_var_nm_1L_chr = "short_name_chr", target_var_nm_1L_chr = .x,
evaluate_1L_lgl = F)) %>% as.list()
predr_vals_dbl <- rlang::exec(.fn = seq, !!!args_ls)
return(predr_vals_dbl)
}
make_predr_vars_nms_ls <- function (main_predrs_chr, covars_ls, combinations_1L_lgl = F, existing_predrs_ls = NULL, max_nbr_of_covars_1L_int = integer(0))
{
predr_vars_nms_ls <- covars_ls %>% purrr::map(~{
covars_chr <- .x
purrr::map(main_predrs_chr, ~list(c(.x), c(.x, covars_chr) %>% purrr::discard(is.na))) %>%
purrr::flatten()
}) %>% purrr::flatten() %>% unique()
predr_vars_nms_ls <- predr_vars_nms_ls[order(sapply(predr_vars_nms_ls,
length))]
if(combinations_1L_lgl){
main_predrs_ls <- predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~length(.x)==1)]
combinations_from_chr <- setdiff(predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~length(.x)>1)] %>% purrr::flatten_chr(), main_predrs_chr)
combinations_ls <- 1:(ifelse(identical(max_nbr_of_covars_1L_int,integer(0)),length(combinations_from_chr),min(max_nbr_of_covars_1L_int,length(combinations_from_chr)))) %>%
purrr::map(~gtools::combinations(length(combinations_from_chr),.x,combinations_from_chr) %>% t() %>% as.data.frame() %>% as.list() %>% unname()) %>% purrr::flatten()
combinations_ls <- main_predrs_ls %>%
purrr::map(~
{
main_1L_chr <- .x
combinations_ls %>%
purrr::map(~c(main_1L_chr,.x))
}) %>% purrr::flatten()
predr_vars_nms_ls <- append(main_predrs_ls,combinations_ls)
}
if(!is.null(existing_predrs_ls)){
predr_vars_nms_ls <- predr_vars_nms_ls[predr_vars_nms_ls %>% purrr::map_lgl(~{
test_chr <- .x
!any(existing_predrs_ls %>% purrr::map_lgl(~identical(.x,test_chr))
)})]
}
return(predr_vars_nms_ls)
}
make_predrs_for_best_mdls <- function(outp_smry_ls,
old_nms_chr = NULL,
new_nms_chr = NULL){
ordered_mdl_nms_chr <- outp_smry_ls$mdls_smry_tb %>% dplyr::filter(Parameter=="R2") %>% dplyr::arrange(dplyr::desc(Estimate)) %>% dplyr::pull(Model)
ind_predr_mdls_by_mdl_type_ls <- outp_smry_ls$prefd_mdl_types_chr %>% purrr::map(~{
mdl_type_1L_chr <- .x
paste0(outp_smry_ls$predr_cmprsn_tb$predr_chr,"_1_") %>% purrr::map(~paste0(.x,
mdl_type_1L_chr)) %>% purrr::flatten_chr()
})
ordered_mdls_by_type_ls <- ind_predr_mdls_by_mdl_type_ls %>%
purrr::map(~{
ind_predr_mdls_chr <- .x
ordered_mdl_nms_chr[ordered_mdl_nms_chr %>% purrr::map_lgl(~.x %in% ind_predr_mdls_chr)]
})
predrs_for_best_mdls_chr <- ordered_mdls_by_type_ls %>% purrr::map2_chr(outp_smry_ls$prefd_mdl_types_chr,
~{
.x[1] %>% stringr::str_remove(paste0("_1_",.y))
})
if(!is.null(old_nms_chr)){
predrs_for_best_mdls_chr <- transform_predr_nm_part_of_phrases(predrs_for_best_mdls_chr,
old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
}
return(predrs_for_best_mdls_chr)
}
make_prefd_mdls_vec <- function (smry_of_sngl_predr_mdls_tb,
choose_from_pfx_chr = c("BET","GLM", "OLS"),
mdl_types_lup = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment(),
package = "specific") #
ordered_mdl_types_chr <- dplyr::inner_join(smry_of_sngl_predr_mdls_tb %>%
dplyr::select(Model) %>%
dplyr::rename(long_name_chr = Model),
mdl_types_lup,
by = "long_name_chr") %>%
dplyr::pull(short_name_chr)
prefd_mdls_chr <- purrr::map_chr(choose_from_pfx_chr,
~ordered_mdl_types_chr[startsWith(ordered_mdl_types_chr,
.x)][1])
prefd_mdls_chr <- prefd_mdls_chr[order(prefd_mdls_chr %>% purrr::map_int(~which(ordered_mdl_types_chr==.x)))]
#prefd_mdls_chr <- prefd_mdls_chr[-max((1:length(prefd_mdls_chr))[prefd_mdls_chr %>% purrr::map_lgl(~(startsWith(.x,"BET") | startsWith(.x,"GLM")))])]
return(prefd_mdls_chr)
}
make_prmry_analysis_params_ls <- function(analysis_core_params_ls,
candidate_covar_nms_chr = NA_character_,
ds_tb,
path_params_ls,
maui_params_ls,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
raw_ds_tfmn_fn = NULL,
subtitle_1L_chr = "Methods Report 1: Analysis Program (Primary Analysis)",
utl_class_fn_1L_chr = "as.numeric"){
if(is.na(analysis_core_params_ls$candidate_covar_nms_chr[1]) & !is.na(candidate_covar_nms_chr[1])){
analysis_core_params_ls$candidate_covar_nms_chr <- candidate_covar_nms_chr
} # This logic is required to ensure soft deprecated arguments used in manuscript continue to work.
if(is.null(analysis_core_params_ls$prefd_covars_chr) & !is.null(prefd_covars_chr)){
analysis_core_params_ls$prefd_covars_chr <- prefd_covars_chr
}
if(is.null(analysis_core_params_ls$prefd_mdl_types_chr) & !is.null(prefd_mdl_types_chr)){
analysis_core_params_ls$prefd_mdl_types_chr <- prefd_mdl_types_chr
}
prmry_analysis_params_ls <- list(ds_tb = ds_tb,
raw_ds_tfmn_fn = raw_ds_tfmn_fn,
subtitle_1L_chr = subtitle_1L_chr,
utl_class_fn_1L_chr = utl_class_fn_1L_chr) %>%
append(analysis_core_params_ls) %>%
append(path_params_ls[1:2]) %>%
append(maui_params_ls)
return(prmry_analysis_params_ls)
}
make_psych_predrs_lup <- function(){ # Rename - example
predictors_lup <- TTU_predictors_lup(make_pt_TTU_predictors_lup(short_name_chr = c("K10_int","Psych_well_int"),
long_name_chr = c("Kessler Psychological Distress - 10 Item Total Score",
"Overall Wellbeing Measure (Winefield et al. 2012)"),
min_val_dbl = c(10,18),
max_val_dbl = c(50,90),
class_chr = "integer",
increment_dbl = 1,
class_fn_chr = "integer",
mdl_scaling_dbl = 0.01,
covariate_lgl = F))
return(predictors_lup)
}
make_random_forest_text <- function(results_ls,
for_abstract_1L_lgl = F){
if(for_abstract_1L_lgl){
text_1L_chr <- ifelse(length(results_ls$ttu_cs_ls$rf_seq_dscdng_chr) > 1,
paste0(ifelse(results_ls$ttu_cs_ls$mdl_predrs_and_rf_seqs_cmprsn_1L_chr == "is consistent",
" and the random forest model",
paste0(", while ",
results_ls$ttu_cs_ls$rf_seq_dscdng_chr[1],
" was the most \'important\' predictor in the random forest model"))),
"")
}else{
text_1L_chr <- ifelse(length(results_ls$ttu_cs_ls$rf_seq_dscdng_chr) > 1,
paste0("This ",
results_ls$ttu_cs_ls$mdl_predrs_and_rf_seqs_cmprsn_1L_chr,
" with the random forest model in which ",
results_ls$ttu_cs_ls$rf_seq_dscdng_chr[1],
" was found to be the most \'important\' predictor"),
"")
}
return(text_1L_chr)
}
make_ranked_predrs_ls <- function(descv_tbls_ls,
old_nms_chr = NULL,
new_nms_chr = NULL){
unranked_predrs_chr <- rownames(descv_tbls_ls[["bl_cors_tb"]])[-1]
if(!is.null(old_nms_chr))
unranked_predrs_chr <- unranked_predrs_chr %>%
transform_predr_nm_part_of_phrases(old_nms_chr = old_nms_chr,
new_nms_chr = new_nms_chr)
ranks_dbl <- descv_tbls_ls[["bl_cors_tb"]][2:nrow(descv_tbls_ls[["bl_cors_tb"]]),1] %>%
purrr::map_dbl(~{
vec_dbl <- regmatches(.x, gregexpr("[[:digit:]]+", .x)) %>% unlist() %>% as.numeric()
vec_dbl[1]+vec_dbl[2]/100
}) %>% rank()
unique_ranks_dbl <- unique(ranks_dbl) %>% sort(decreasing = T)
ranked_predrs_chr <- purrr::map(unique_ranks_dbl, ~ unranked_predrs_chr[ranks_dbl == .x]) %>% purrr::flatten_chr()
ranked_predrs_ls <- list(unranked_predrs_chr = unranked_predrs_chr,
ranked_predrs_chr = ranked_predrs_chr)
return(ranked_predrs_ls)
}
make_results_ls <- function(spine_of_results_ls = NULL, # CORE OF S4 Classes - rename ts to lngl # and metamorphose methods
abstract_args_ls = NULL,
consent_1L_chr = "",
consent_indcs_int = 1L,
depnt_var_min_val_1L_dbl = numeric(0),
dv_ds_nm_and_url_chr = NULL,
options_chr = c("Y", "N"),
output_format_ls = NULL,
params_ls_ls = NULL,
path_params_ls = NULL,
study_descs_ls = NULL,
fn_ls = NULL,
include_idx_int = NULL,
var_nm_change_lup = NULL,
ctgl_vars_regrouping_ls = NULL,
make_cmpst_plt_1L_lgl = T,
outp_smry_ls = NULL,
sig_covars_some_predrs_mdls_tb = NULL,
sig_thresh_covars_1L_chr = NULL,
version_1L_chr = NULL){
if(is.null(spine_of_results_ls)){
spine_of_results_ls <- make_results_ls_spine(output_format_ls = output_format_ls,
params_ls_ls = params_ls_ls,
path_params_ls = path_params_ls,
study_descs_ls = study_descs_ls,
fn_ls = fn_ls,
include_idx_int = include_idx_int,
outp_smry_ls = outp_smry_ls,
var_nm_change_lup = var_nm_change_lup)
}
mdls_smry_tbls_ls <- make_mdls_smry_tbls_ls(spine_of_results_ls$outp_smry_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int)
covars_mdls_ls <- make_mdls_ls(spine_of_results_ls$outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb)
descv_tbls_ls <- paste0(spine_of_results_ls$output_data_dir_1L_chr,"/",spine_of_results_ls$outp_smry_ls$file_paths_chr[spine_of_results_ls$outp_smry_ls$file_paths_chr %>% purrr::map_lgl(~stringr::str_detect(.x,"descv_tbls_ls.RDS"))]) %>% readRDS()
if(make_cmpst_plt_1L_lgl){
composite_plt <- make_cmpst_sctr_and_dnst_plt(spine_of_results_ls$outp_smry_ls,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
output_data_dir_1L_chr = spine_of_results_ls$output_data_dir_1L_chr,
predr_var_nms_chr = spine_of_results_ls$outp_smry_ls$predr_vars_nms_ls[[1]])
ready4::write_with_consent(consented_fn = cowplot::save_plot,
prompt_1L_chr = paste0("Do you confirm that you want to write the file ",
paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
"?"),
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
consented_args_ls = list(filename = paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
plot = composite_plt,
base_height = 20),
consented_msg_1L_chr = paste0("File ",
paste0(spine_of_results_ls$output_data_dir_1L_chr,"/dens_and_sctr.png"),
" has been written."),
declined_msg_1L_chr = "Write request cancelled - no new files have been written.",
options_chr = options_chr)
}
ttu_cs_ls <- make_ttu_cs_ls(spine_of_results_ls$outp_smry_ls,
sig_covars_some_predrs_mdls_tb = sig_covars_some_predrs_mdls_tb,
sig_thresh_covars_1L_chr = sig_thresh_covars_1L_chr)
mdl_types_chr <- mdls_smry_tbls_ls$prefd_predr_mdl_smry_tb$Model %>%
purrr::map_chr(~get_mdl_type_from_nm(.x)) %>%
unique()
ttu_cs_ls$rf_seq_dscdng_chr <- ttu_cs_ls$rf_seq_dscdng_chr %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x))
ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr <- ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x))
ttu_lngl_ls = list(best_mdls_tb = tibble::tibble(model_type = mdl_types_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(spine_of_results_ls$outp_smry_ls$mdl_types_lup,
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "mixed_acronym_chr",
evaluate_1L_lgl = F)),
link_and_tfmn_chr = mdl_types_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(spine_of_results_ls$outp_smry_ls$mdl_types_lup,
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F)),
name_chr = make_predrs_for_best_mdls(spine_of_results_ls$outp_smry_ls,
old_nms_chr = spine_of_results_ls$var_nm_change_lup$old_nms_chr,
new_nms_chr = spine_of_results_ls$var_nm_change_lup$new_nms_chr),
r2_dbl = mdls_smry_tbls_ls$prefd_predr_mdl_smry_tb %>%
dplyr::filter(Parameter == "R2") %>%
dplyr::pull(Estimate)),
cs_ts_ratios_tb = spine_of_results_ls$cs_ts_ratios_tb,
incld_covars_chr = spine_of_results_ls$outp_smry_ls$prefd_covars_chr)
results_ls <- list(abstract_args_ls = abstract_args_ls,
candidate_covars_ls = spine_of_results_ls$candidate_covars_ls,
candidate_predrs_chr = spine_of_results_ls$candidate_predrs_chr,
cohort_ls = make_cohort_ls(descv_tbls_ls,
ctgl_vars_regrouping_ls = ctgl_vars_regrouping_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int),
dv_ds_nm_and_url_chr = dv_ds_nm_and_url_chr,
header_yaml_args_ls = params_ls_ls$header_yaml_args_ls,
hlth_utl_and_predrs_ls = make_hlth_utl_and_predrs_ls(spine_of_results_ls$outp_smry_ls,
descv_tbls_ls = descv_tbls_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int,
old_nms_chr = spine_of_results_ls$var_nm_change_lup$old_nms_chr,
new_nms_chr = spine_of_results_ls$var_nm_change_lup$new_nms_chr),
mdl_coef_ratios_ls = spine_of_results_ls$mdl_coef_ratios_ls,
mdl_ingredients_ls = spine_of_results_ls$mdl_ingredients_ls,
mdls_with_signft_covars_ls = spine_of_results_ls$mdls_with_signft_covars_ls,
output_format_ls = params_ls_ls$output_format_ls,
path_params_ls = params_ls_ls$path_params_ls,
paths_to_figs_ls = make_paths_to_ms_smry_plts_ls(spine_of_results_ls$output_data_dir_1L_chr,
outp_smry_ls = spine_of_results_ls$outp_smry_ls),
predr_var_nms_chr = spine_of_results_ls$outp_smry_ls$predr_vars_nms_ls[[1]] %>%
purrr::map_chr(~ifelse(.x %in% spine_of_results_ls$var_nm_change_lup$old_nms_chr,
.x %>%
ready4::get_from_lup_obj(data_lookup_tb = spine_of_results_ls$var_nm_change_lup,
match_var_nm_1L_chr = "old_nms_chr",
target_var_nm_1L_chr = "new_nms_chr",
evaluate_1L_lgl = F),
.x)),
r_version_1L_chr = paste0(spine_of_results_ls$outp_smry_ls$session_ls$R.version$major,
".",
spine_of_results_ls$outp_smry_ls$session_ls$R.version$minor),
study_descs_ls = spine_of_results_ls$study_descs_ls,
tables_ls = make_ms_smry_tbls_ls(spine_of_results_ls$outp_smry_ls,
mdls_smry_tbls_ls = mdls_smry_tbls_ls,
covars_mdls_ls = covars_mdls_ls,
descv_tbls_ls = descv_tbls_ls,
nbr_of_digits_1L_int = spine_of_results_ls$nbr_of_digits_1L_int),
ttu_cs_ls = ttu_cs_ls,
ttu_lngl_ls = ttu_lngl_ls,
ttu_version_1L_chr = spine_of_results_ls$outp_smry_ls$session_ls$otherPkgs$TTU$Version,
var_nm_change_lup = spine_of_results_ls$var_nm_change_lup,
version_1L_chr = version_1L_chr)
results_ls <- transform_tbls_for_covar_nms(results_ls) %>% transform_tbls_for_csnl_mdls()
return(results_ls)
}
make_results_ls_spine <- function(output_format_ls = NULL,
params_ls_ls = NULL,
path_params_ls = NULL,
study_descs_ls,
fn_ls = NULL,
include_idx_int = NULL,
outp_smry_ls = NULL,
var_nm_change_lup = NULL){
output_data_dir_1L_chr <- path_params_ls$paths_ls$output_data_dir_1L_chr
nbr_of_digits_1L_int <- output_format_ls$manuscript_digits_1L_int
if(is.null(var_nm_change_lup)){
var_nm_change_lup <- list(old_nms_chr = NULL,
new_nms_chr = NULL)
}
if(is.null(outp_smry_ls))
outp_smry_ls <- readRDS(paste0(output_data_dir_1L_chr,"/I_ALL_OUTPUT_.RDS"))
mdl_ingredients_ls <- readRDS(paste0(output_data_dir_1L_chr,
"/G_Shareable/Ingredients/mdl_ingredients.RDS"))
if(!is.null(params_ls_ls)){
if(is.null(params_ls_ls$params_ls$candidate_covar_nms_chr) | is.na(params_ls_ls$params_ls$candidate_covar_nms_chr[1])){
candidate_covars_ls <- NULL
}else{
covar_ctgs_chr <- params_ls_ls$params_ls$candidate_covar_nms_chr %>%
purrr::map_chr(~ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_nm_chr",
target_var_nm_1L_chr = "var_ctg_chr",
evaluate_1L_lgl = F)) %>%
unique()
candidate_covars_ls <- covar_ctgs_chr %>%
purrr::map(~{
var_desc_chr <- ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_ctg_chr",
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F)
class(var_desc_chr) <- setdiff(class(var_desc_chr), "labelled")
attr(var_desc_chr, "label") <- NULL
var_nm_chr <- ready4::get_from_lup_obj(params_ls_ls$params_ls$ds_descvs_ls$dictionary_tb,
match_value_xx = .x,
match_var_nm_1L_chr = "var_ctg_chr",
target_var_nm_1L_chr = "var_nm_chr",
evaluate_1L_lgl = F)
var_desc_chr[var_nm_chr %in% params_ls_ls$params_ls$candidate_covar_nms_chr]
}
) %>%
stats::setNames(covar_ctgs_chr)
}
}else{
candidate_covars_ls <- NULL
}
study_descs_ls$predr_ctgs_ls <- make_predr_ctgs_ls(outp_smry_ls,
include_idx_int = include_idx_int)
mdl_coef_ratios_ls <- make_mdl_coef_ratio_ls(mdl_ingredients_ls,
predr_ctgs_ls = study_descs_ls$predr_ctgs_ls)
mdls_smry_tbls_ls <- make_mdls_smry_tbls_ls(outp_smry_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)
covars_mdls_ls <- make_mdls_ls(outp_smry_ls,
mdls_tb = mdls_smry_tbls_ls$covar_mdls_tb)
cs_ts_ratios_tb <- make_cs_ts_ratios_tb(predr_ctgs_ls = study_descs_ls$predr_ctgs_ls,
mdl_coef_ratios_ls = mdl_coef_ratios_ls,
candidate_predrs_chr = params_ls_ls$params_ls$ds_descvs_ls$candidate_predrs_chr,
fn_ls = fn_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int)
spine_of_results_ls <- list(candidate_covars_ls = candidate_covars_ls,
candidate_predrs_chr = params_ls_ls$params_ls$ds_descvs_ls$candidate_predrs_chr,
cs_ts_ratios_tb = cs_ts_ratios_tb,
mdls_with_signft_covars_ls = get_mdls_with_signft_covars(outp_smry_ls,
params_ls_ls = params_ls_ls),
outp_smry_ls = outp_smry_ls,
output_data_dir_1L_chr = output_data_dir_1L_chr,
mdl_coef_ratios_ls = mdl_coef_ratios_ls,
mdl_ingredients_ls = mdl_ingredients_ls,
nbr_of_digits_1L_int = nbr_of_digits_1L_int,
study_descs_ls = study_descs_ls,
var_nm_change_lup = var_nm_change_lup)
return(spine_of_results_ls)
}
make_scaling_fctr_dbl <- function(outp_smry_ls){
scaling_fctr_dbl <- outp_smry_ls$predr_vars_nms_ls %>%
purrr::flatten_chr() %>%
unique() %>%
purrr::map_dbl(~ ifelse(.x %in% outp_smry_ls$predictors_lup$short_name_chr,
ready4::get_from_lup_obj(outp_smry_ls$predictors_lup,
target_var_nm_1L_chr = "mdl_scaling_dbl",
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F),
1))
return(scaling_fctr_dbl)
}
make_scaling_text <- function(results_ls,
table_1L_chr = "cfscl"){
if(startsWith(table_1L_chr,"cfscl")){
table_df <- results_ls$tables_ls$ind_preds_coefs_tbl
}else{
if(startsWith(table_1L_chr,"coefscovarstype")){
table_df <- results_ls$tables_ls %>%
purrr::pluck(paste0("mdl_type_",
table_1L_chr %>% stringr::str_remove("coefscovarstype"),
"_covar_mdls_tb"))
}
}
predrs_chr <- table_df$Parameter %>% setdiff(c("SD (Intercept)","Intercept")) %>% stringr::str_replace_all(" model","") %>%
stringr::str_replace_all(" baseline","") %>% stringr::str_replace_all(" change","") %>%
stringr::str_replace_all(" scaled","") %>% stringr::str_replace_all(" unscaled","") %>% unique()
predrs_lup <- results_ls$mdl_ingredients_ls$predictors_lup %>%
dplyr::filter(short_name_chr %in% predrs_chr)
scaling_dbl <- predrs_lup$mdl_scaling_dbl %>% unique()
text_1L_chr <- ifelse(all(scaling_dbl==1),
"",
paste0("Note: ",
scaling_dbl %>%
purrr::map_chr(~ {
scaled_predrs_chr <- predrs_lup %>%
dplyr::filter(mdl_scaling_dbl == .x) %>%
dplyr::pull(short_name_chr) %>%
sort() %>%
transform_names(rename_lup = results_ls$var_nm_change_lup)
ifelse(.x ==1,
"",
paste0("The ",
scaled_predrs_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
" parameter",
ifelse(length(scaled_predrs_chr) == 1,
" was",
"s were"),
" first multiplied by ",
.x,
"."))
}
) %>%
paste0(collapse = " ")))
return(text_1L_chr)
}
make_scndry_anlys_params <- function(scndry_anlys_params_ls = NULL,
candidate_covar_nms_chr = NULL,
candidate_predrs_chr = NULL,
predictors_lup = NULL,
prefd_covars_chr = NA_character_
){
new_params_ls <- list(candidate_covar_nms_chr = candidate_covar_nms_chr,
candidate_predrs_chr = candidate_predrs_chr,
predictors_lup = predictors_lup,
prefd_covars_chr = prefd_covars_chr)
if(!is.null(scndry_anlys_params_ls)){
new_params_ls <- append(scndry_anlys_params_ls, list(new_params_ls)) %>%
stats::setNames(paste0("secondary_",1:(length(scndry_anlys_params_ls) + 1)))
}else{
new_params_ls <- list(secondary_1 = new_params_ls)
}
return(new_params_ls)
}
make_scndry_anlys_text <- function(results_ls){
text_1L_chr <- ifelse(get_nbr_of_scndry_analyses(results_ls,
as_words_1L_lgl = F) == 0,
"",
paste0(get_nbr_of_scndry_analyses(results_ls),
" secondary analys",
ifelse(get_nbr_of_scndry_analyses(results_ls, as_words_1L_lgl = F) == 1,
"is was ",
"es were "),
"undertaken. ",
get_scndry_anlys_descs(results_ls)))
return(text_1L_chr)
}
make_selected_mdl_text <- function(results_ls,
for_abstract_1L_lgl = F){
length_1L_int <- length(results_ls$ttu_cs_ls$selected_mdls_chr)
text_1L_chr <- paste0(ifelse((length_1L_int == 2 & !for_abstract_1L_lgl),"Both ",""),
results_ls$ttu_cs_ls$selected_mdls_chr %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
ifelse(length_1L_int >1," were"," was"),
ifelse(for_abstract_1L_lgl,
paste0(" the best peforming model",ifelse(length_1L_int >1,"s.",".")),
" selected for further evaluation."))
return(text_1L_chr)
}
make_shareable_mdl <- function (fake_ds_tb,
mdl_smry_tb,
x_ready4use_dictionary,
#x_Ready4useDyad,
control_1L_chr = NA_character_,
depnt_var_nm_1L_chr = "utl_total_w",
id_var_nm_1L_chr = "fkClientID",
mdl_type_1L_chr = "OLS_CLL",
mdl_types_lup = NULL,
seed_1L_int = 12345L,
start_1L_chr = NA_character_,
tfmn_1L_chr = "CLL")
{
if (is.null(mdl_types_lup))
utils::data(mdl_types_lup, envir = environment())
if (is.na(tfmn_1L_chr))
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "tfmn_chr", evaluate_1L_lgl = F)
predr_var_nms_chr <- mdl_smry_tb$Parameter[!mdl_smry_tb$Parameter %in%
c("SD (Intercept)", "Intercept", "R2", "RMSE", "Sigma")] %>%
stringi::stri_replace_last_fixed(" baseline", "_baseline") %>%
stringi::stri_replace_last_fixed(" change", "_change") %>%
stringi::stri_replace_last_fixed(" scaled", "_scaled") %>%
stringi::stri_replace_last_fixed(" unscaled", "_unscaled")
X <- ready4use::Ready4useDyad(ds_tb = fake_ds_tb %>% dplyr::select(intersect(names(fake_ds_tb), x_ready4use_dictionary$var_nm_chr)),
dictionary_r3 = x_ready4use_dictionary)
dummys_chr <- manufacture(X, flatten_1L_lgl = T)
predr_var_nms_chr <- predr_var_nms_chr %>% purrr::map_chr(~ifelse(.x %in% dummys_chr,
manufacture(X, flatten_1L_lgl = T, what_1L_chr = "factors-d", match_1L_chr = .x),
.x)) %>% unique()
tfd_depnt_var_nm_1L_chr <- transform_depnt_var_nm(depnt_var_nm_1L_chr, tfmn_1L_chr = tfmn_1L_chr)
if (length(predr_var_nms_chr) > 1) {
covar_var_nms_chr <- predr_var_nms_chr[2:length(predr_var_nms_chr)]
} else {
covar_var_nms_chr <- NA_character_
}
model_mdl <- make_mdl(fake_ds_tb %>% dplyr::select(tidyselect::all_of(c(id_var_nm_1L_chr, tfd_depnt_var_nm_1L_chr, predr_var_nms_chr))),
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_var_nm_1L_chr = predr_var_nms_chr[1],
covar_var_nms_chr = covar_var_nms_chr,
tfmn_1L_chr = tfmn_1L_chr,
mdl_type_1L_chr = mdl_type_1L_chr,
mdl_types_lup = mdl_types_lup,
control_1L_chr = control_1L_chr,
start_1L_chr = start_1L_chr)
if (ready4::get_from_lup_obj(mdl_types_lup,
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "fn_chr",
evaluate_1L_lgl = F) == "betareg::betareg") {
model_coeffs_dbl <- model_mdl$coefficients$mean
} else {
model_coeffs_dbl <- model_mdl$coefficients
}
param_nms_chr <- model_coeffs_dbl %>% names()
mdl_smry_tb <- mdl_smry_tb %>% dplyr::mutate(Parameter = dplyr::case_when(Parameter == "Intercept" ~ "(Intercept)",
TRUE ~ purrr::map_chr(Parameter,
~stringr::str_replace_all(.x, " ", "_")))) %>%
dplyr::filter(Parameter %in% param_nms_chr) %>% dplyr::slice(match(param_nms_chr, Parameter))
assertthat::assert_that(all(param_nms_chr == mdl_smry_tb$Parameter),
msg = "Parameter names mismatch between data and model summary table")
model_coeffs_dbl <- mdl_smry_tb$Estimate
names(model_coeffs_dbl) <- param_nms_chr
if (ready4::get_from_lup_obj(mdl_types_lup, match_value_xx = mdl_type_1L_chr, match_var_nm_1L_chr = "short_name_chr",
target_var_nm_1L_chr = "fn_chr", evaluate_1L_lgl = F) == "betareg::betareg") {
model_mdl$coefficients$mean <- model_coeffs_dbl
} else {
model_mdl$coefficients <- model_coeffs_dbl
}
return(model_mdl)
}
make_smry_of_brm_mdl <- function (mdl_ls,
data_tb,
depnt_var_nm_1L_chr = "utl_total_w",
predr_vars_nms_chr,
mdl_nm_1L_chr = NA_character_,
seed_1L_dbl = 23456,
tfmn_1L_chr) {
if (is.na(mdl_nm_1L_chr))
mdl_nm_1L_chr <- predr_vars_nms_chr[1]
set.seed(seed_1L_dbl)
predictions <- stats::predict(mdl_ls, summary = F) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr, tfmn_is_outp_1L_lgl = T)
sd_intcpt_df <- summary(mdl_ls, digits = 4)$random[[1]]
sd_intcpt_df <- sd_intcpt_df[1:nrow(sd_intcpt_df), 1:4] %>%
dplyr::mutate(dplyr::across(dplyr::everything(), as.numeric))
coef <- summary(mdl_ls, digits = 4)$fixed
coef <- coef[1:nrow(coef), 1:4] %>% dplyr::mutate(dplyr::across(dplyr::everything(), as.numeric))
R2 <- brms::bayes_R2(mdl_ls) %>% as.vector()
RMSE <- psych::describe(apply(predictions, 1, calculate_rmse,
y_dbl = data_tb %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
quant = c(0.25, 0.75), skew = F, ranges = F)
RMSE <- cbind(RMSE$mean, RMSE$sd, RMSE$Q0.25, RMSE$Q0.75) %>% as.vector()
Sigma <- summary(mdl_ls, digits = 4)$spec_par[1:4]
smry_of_brm_mdl_tb <- data.frame(round(rbind(sd_intcpt_df, coef, R2, RMSE, Sigma), 3)) %>%
dplyr::mutate(Parameter = c("SD (Intercept)", "Intercept",
purrr::map(predr_vars_nms_chr,
~{
possibilities_chr <- paste0(.x, c("", " baseline", " change", " scaled", " unscaled"))
if(possibilities_chr[1] %in% names(mdl_ls$data)){
values_xx <- mdl_ls$data %>% dplyr::pull(.x)
if(is.factor(values_xx)){
possibilities_chr <- c(possibilities_chr[1], paste0(.x,levels(values_xx)[2:length(levels(values_xx))]))
}
}
possibilities_chr
}) %>%
purrr::flatten_chr() %>% intersect(purrr::map(names(mdl_ls$data),
~{
values_xx <- mdl_ls$data %>% dplyr::pull(.x)
if(is.factor(values_xx)){
paste0(.x,levels(values_xx)[2:length(levels(values_xx))])
}else{
stringi::stri_replace_last_fixed(.x, "_baseline", " baseline") %>%
stringi::stri_replace_last_fixed("_change", " change") %>%
stringi::stri_replace_last_fixed("_scaled"," scaled") %>%
stringi::stri_replace_last_fixed("_unscaled"," unscaled")
}
}) %>%
purrr::flatten_chr()),
"R2", "RMSE", "Sigma"), Model = mdl_nm_1L_chr) %>%
dplyr::mutate(`95% CI` = paste(l.95..CI, ",", u.95..CI)) %>%
dplyr::rename(SE = Est.Error) %>% dplyr::select(Model, Parameter, Estimate, SE, `95% CI`)
rownames(smry_of_brm_mdl_tb) <- NULL
return(smry_of_brm_mdl_tb)
}
make_smry_of_mdl_outp <- function (data_tb,
folds_1L_int = 10,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove default
start_1L_chr = NULL,
tfmn_1L_chr = "NTF",
predr_var_nm_1L_chr,
covar_var_nms_chr = NA_character_,
mdl_type_1L_chr = "OLS_NTF",
mdl_types_lup = NULL,
predn_type_1L_chr = NULL)
{
if (is.null(mdl_types_lup))
utils::data("mdl_types_lup", envir = environment())
data_tb <- data_tb %>% dplyr::filter(!is.na(!!rlang::sym(predr_var_nm_1L_chr)))
data_tb <- transform_ds_for_mdlng(data_tb, depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr)
mdl_desc_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr", match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "long_name_chr", evaluate_1L_lgl = F)
folds_ls <- make_folds_ls(data_tb, depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
folds_1L_int = folds_1L_int)
control_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "control_chr",
evaluate_1L_lgl = F)
smry_of_one_predr_mdl_tb <- purrr::map_dfr(folds_ls, ~{
model_mdl <- make_mdl(data_tb[-.x,], depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl, # Unnecessary
start_1L_chr = start_1L_chr, tfmn_1L_chr = tfmn_1L_chr,
predr_var_nm_1L_chr = predr_var_nm_1L_chr, covar_var_nms_chr = covar_var_nms_chr,
mdl_type_1L_chr = mdl_type_1L_chr, mdl_types_lup = mdl_types_lup, control_1L_chr = control_1L_chr)
predd_old_dbl <- stats::predict(model_mdl, type = predn_type_1L_chr) %>%
calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr, ## TEST
tfmn_is_outp_1L_lgl = T)
predd_new_dbl <- stats::predict(model_mdl, newdata = data_tb[.x, ],
type = predn_type_1L_chr) %>% calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr,
tfmn_is_outp_1L_lgl = T)
tibble::tibble(Rsquared = caret::R2(predd_old_dbl,
data_tb[-.x,] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
form = "traditional"),
RMSE = caret::RMSE(predd_old_dbl,
data_tb[-.x, ] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
MAE = caret::MAE(predd_old_dbl, data_tb[-.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
RsquaredP = caret::R2(predd_new_dbl, data_tb[.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr)),
form = "traditional"), RMSEP = caret::RMSE(predd_new_dbl,
data_tb[.x, ] %>% dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))),
MAEP = caret::MAE(predd_new_dbl, data_tb[.x, ] %>%
dplyr::pull(!!rlang::sym(depnt_var_nm_1L_chr))))
}) %>% dplyr::summarise_all(mean) %>% dplyr::mutate(Model = mdl_desc_1L_chr) %>%
dplyr::select(Model, dplyr::everything())
return(smry_of_one_predr_mdl_tb)
}
make_smry_of_ts_mdl_outp <- function (data_tb, # rename ts to lngl
mdl_nm_1L_chr,
mdl_types_lup,
predr_vars_nms_chr,
predictors_lup,
backend_1L_chr = getOption("brms.backend", "rstan"),
consent_1L_chr = "",
consent_indcs_int = 1L,
control_ls = NULL,
depnt_var_min_val_1L_dbl = numeric(0),
depnt_var_nm_1L_chr = "utl_total_w", # Remove Default
id_var_nm_1L_chr = "fkClientID",
iters_1L_int = 4000L,
options_chr = c("Y", "N"),
path_to_write_to_1L_chr = NA_character_,
prior_ls = NULL,
round_bl_val_1L_chr = "Baseline",
round_var_nm_1L_chr = "round",
seed_1L_int = 1000L,
utl_min_val_1L_dbl = -1)
{
scaling_fctr_dbl <- predr_vars_nms_chr %>% purrr::map_dbl(~
ifelse(.x %in% predictors_lup$short_name_chr,
ready4::get_from_lup_obj(predictors_lup,
target_var_nm_1L_chr = "mdl_scaling_dbl",
match_value_xx = .x,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F),
1))
mdl_type_1L_chr <- mdl_nm_1L_chr %>%
stringr::str_remove(paste0(predr_vars_nms_chr[1], "_", ifelse(is.na(predr_vars_nms_chr[2]), "", paste0(predr_vars_nms_chr[2],
"_"))))
mdl_type_1L_chr <- stringr::str_sub(mdl_type_1L_chr, start = 1 + (mdl_type_1L_chr %>% stringi::stri_locate_first_fixed("_"))[1,2] %>% as.vector())
tfmn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
target_var_nm_1L_chr = "tfmn_chr",
match_value_xx = mdl_type_1L_chr,
match_var_nm_1L_chr = "short_name_chr",
evaluate_1L_lgl = F)
tfd_data_tb <- transform_tb_to_mdl_inp(data_tb,
depnt_var_min_val_1L_dbl = depnt_var_min_val_1L_dbl,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr, id_var_nm_1L_chr = id_var_nm_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr, round_bl_val_1L_chr = round_bl_val_1L_chr,
scaling_fctr_dbl = scaling_fctr_dbl,
tfmn_1L_chr = tfmn_1L_chr)
tfd_depnt_var_nm_1L_chr <- transform_depnt_var_nm(depnt_var_nm_1L_chr,
tfmn_1L_chr = tfmn_1L_chr)
family_fn_1L_chr <- ready4::get_from_lup_obj(mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = mdl_type_1L_chr,
target_var_nm_1L_chr = "family_chr",
evaluate_1L_lgl = F)
family_fn_1L_chr <- ifelse(is.na(family_fn_1L_chr),
ifelse(startsWith(mdl_type_1L_chr,"BET"),
paste0("brms::Beta(link = \"",
get_link_from_tfmn(stringr::str_sub(mdl_type_1L_chr,
start = -3)),
"\")"),
"gaussian(identity)"),
family_fn_1L_chr)
args_ls <- list(data_tb = tfd_data_tb, depnt_var_nm_1L_chr = tfd_depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr, id_var_nm_1L_chr = id_var_nm_1L_chr,
is_csnl_1L_lgl = !(!identical(round_var_nm_1L_chr, character(0)) && ifelse(identical(round_var_nm_1L_chr, character(0)),T,!is.na(round_var_nm_1L_chr))),
iters_1L_int = iters_1L_int,
backend_1L_chr = backend_1L_chr,
family_fn_1L_chr = family_fn_1L_chr,
seed_1L_int = seed_1L_int,
prior_ls = prior_ls, control_ls = control_ls)
mdl_ls <- rlang::exec(fit_ts_model_with_brm, !!!args_ls)
smry_of_ts_mdl_ls <- list(smry_of_ts_mdl_tb = make_smry_of_brm_mdl(mdl_ls,
data_tb = tfd_data_tb,
depnt_var_nm_1L_chr = tfd_depnt_var_nm_1L_chr,
predr_vars_nms_chr = predr_vars_nms_chr,
mdl_nm_1L_chr = mdl_nm_1L_chr,
tfmn_1L_chr = tfmn_1L_chr))
if (!is.na(path_to_write_to_1L_chr)) {
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr <- paste0(path_to_write_to_1L_chr,
"/", mdl_nm_1L_chr, ".RDS")
# if (file.exists(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr))
# file.remove(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr)
capture_xx <- ready4::write_to_delete_fls(smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
options_chr = options_chr)
ready4::write_with_consent(consented_fn = saveRDS,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
consented_args_ls = list(object = mdl_ls,
file = smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr),
consented_msg_1L_chr = paste0("File ",
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
" has been written"),
declined_msg_1L_chr = "Write request cancelled - no new files have been written.",
options_chr = options_chr,
prompt_1L_chr = paste0("Do you confirm that you want to write the file ",
smry_of_ts_mdl_ls$path_to_mdl_ls_1L_chr,
"?"))
smry_of_ts_mdl_ls$paths_to_mdl_plts_chr <- write_ts_mdl_plts(mdl_ls,
consent_1L_chr = consent_1L_chr,
consent_indcs_int = consent_indcs_int,
depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
mdl_nm_1L_chr = mdl_nm_1L_chr,
options_chr = options_chr,
path_to_write_to_1L_chr = path_to_write_to_1L_chr,
round_var_nm_1L_chr = round_var_nm_1L_chr,
tfd_data_tb = tfd_data_tb,
tfmn_1L_chr = tfmn_1L_chr,
utl_min_val_1L_dbl = utl_min_val_1L_dbl)
}
return(smry_of_ts_mdl_ls)
}
make_sngl_mdl_smry_tb <- function(mdls_tb,
mdl_nm_1L_chr,
mdl_type_1L_chr,
add_mdl_nm_sfx_1L_lgl = T){
new_tb <- mdls_tb %>%
dplyr::filter(Model == mdl_nm_1L_chr) %>%
tibble::add_case(Parameter = mdl_nm_1L_chr, .before = 1) %>%
dplyr::select(-Model)
mdl_nm_sfx_1L_chr <- ifelse(add_mdl_nm_sfx_1L_lgl,
paste0("_",mdl_type_1L_chr),
"")
new_tb <- new_tb %>%
dplyr::mutate(!!rlang::sym(paste0("R2",mdl_nm_sfx_1L_chr)) := dplyr::case_when(Parameter == mdl_nm_1L_chr ~ ready4::get_from_lup_obj(new_tb,
match_value_xx = "R2",
match_var_nm_1L_chr = "Parameter",
target_var_nm_1L_chr = "Estimate",
evaluate_1L_lgl = F),
T ~ NA_character_),
!!rlang::sym(paste0("Sigma",mdl_nm_sfx_1L_chr)) := dplyr::case_when(Parameter == mdl_nm_1L_chr ~ ready4::get_from_lup_obj(new_tb,
match_value_xx = "Sigma",
match_var_nm_1L_chr = "Parameter",
target_var_nm_1L_chr = "Estimate",
evaluate_1L_lgl = F),
T ~ NA_character_)) %>%
dplyr::filter(!Parameter %in% c("R2","RMSE","Sigma")) %>%
dplyr::rename_with(~paste0(.x,mdl_nm_sfx_1L_chr),.cols = c("Parameter","Estimate","SE")) %>%
dplyr::rename_with(~paste0("CI",mdl_nm_sfx_1L_chr),.cols = c("95% CI")) %>%
dplyr::mutate(!!rlang::sym(paste0("Parameter",mdl_nm_sfx_1L_chr)) := !!rlang::sym(paste0("Parameter",mdl_nm_sfx_1L_chr)) %>% purrr::map_chr(~stringr::str_replace(.x,
paste0("_1_",mdl_type_1L_chr), " model")))
rownames(new_tb) <- NULL
return(new_tb)
}
make_study_descs_ls <- function(input_params_ls = NULL, # Generalise utility to short and long name
time_btwn_bl_and_fup_1L_chr,
background_1L_chr = "",
coi_1L_chr = "None declared.",
conclusion_1L_chr = "",
ethics_1L_chr = NULL,
funding_1L_chr = NULL,
predr_ctgs_ls = NULL,
sample_desc_1L_chr = NULL,
var_nm_change_lup = NULL){
health_utl_nm_1L_chr <- input_params_ls$short_and_long_nm[1]
params_ls_ls <- input_params_ls
health_utl_long_nm_1L_chr <- ifelse(!is.null(params_ls_ls$short_and_long_nm),
params_ls_ls$short_and_long_nm[2],
NA_character_)
study_descs_ls <- list(background_1L_chr = background_1L_chr,
coi_1L_chr = coi_1L_chr,
conclusion_1L_chr = conclusion_1L_chr,
ethics_1L_chr = ethics_1L_chr,
funding_1L_chr = funding_1L_chr,
health_utl_nm_1L_chr = health_utl_nm_1L_chr,
health_utl_long_nm_1L_chr = health_utl_long_nm_1L_chr,
time_btwn_bl_and_fup_1L_chr = time_btwn_bl_and_fup_1L_chr,
predr_ctgs_ls = predr_ctgs_ls,
sample_desc_1L_chr = sample_desc_1L_chr,
var_nm_change_lup = var_nm_change_lup)
if(!is.null(input_params_ls)){
input_params_ls$study_descs_ls <- study_descs_ls
}else{
input_params_ls <- study_descs_ls
}
return(input_params_ls)
}
make_ten_fold_text <- function(results_ls,
for_abstract_1L_lgl = F){
mdls_chr <- get_ordered_sngl_csnl_mdls(results_ls)
if(for_abstract_1L_lgl){
text_1L_chr <- ifelse(length(mdls_chr)>1,
paste0(mdls_chr[1],
" had the highest predictive ability in ten fold cross validation"),
"")
}else{
text_1L_chr <- ifelse(length(mdls_chr)>1,
paste0(mdls_chr[1],
" had the highest predictive ability followed by ",
get_ordered_sngl_csnl_mdls(results_ls,
select_int = -1,
collapse_1L_lgl = T),
". ",
ifelse(length(mdls_chr)>2,
paste0(mdls_chr[length(mdls_chr)],
" had the least predictive capability."),
"")),
paste0("the predictive ability of ", mdls_chr[1]))
}
return(text_1L_chr)
}
make_ten_folds_tbl_title <- function(results_ls,
ref_1L_int = 1){
title_1L_chr <- ifelse(ref_1L_int == 1,
paste0('10-fold cross-validated model fitting index for different ',
results_ls$ttu_cs_ls$best_mdl_types_ls %>%
names() %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and"),
' models using ',
results_ls$ttu_cs_ls$cs_mdls_predrs_seq_dscdng_chr[1],
' as predictor with the baseline data'),
paste0('10-fold cross-validated model fitting index for different candidate predictors estimated using ',
results_ls$ttu_cs_ls$selected_mdls_chr[1],
' with the baseline data'))
return(title_1L_chr)
}
make_tfd_sngl_predr_mdls_tb <- function(outp_smry_ls,
nbr_of_digits_1L_int = 2L,
mdl_pfx_ls = list(OLS = "Ordinary Least Squares ",
GLM = c("Generalised Linear Model with ",
"Beta Regression Model with Binomial "))){
tfd_sngl_predr_mdls_tb <- mdl_pfx_ls %>%
purrr::map2(names(mdl_pfx_ls),
~{
pfx_chr <- .x
mdls_tb <- outp_smry_ls$smry_of_sngl_predr_mdls_tb %>%
dplyr::filter(Model %>%
purrr::map_lgl(~{
term_1L_chr <- .x
pfx_chr %>%
purrr::map_lgl(~startsWith(term_1L_chr,.x)) %>%
any()
}))
pfx_chr %>%
purrr::map_dfr(~ {
pfx_1L_chr <- .x
mdls_tb %>%
dplyr::filter(startsWith(Model, pfx_1L_chr)) %>%
dplyr::mutate(Model = dplyr::case_when(Model %>% startsWith(mdl_pfx_ls[[2]][2]) ~ stringr::str_replace_all(Model,pfx_1L_chr,"Beta "),
T ~ stringr::str_remove_all(Model,pfx_1L_chr))
) %>%
dplyr::mutate(Model = Model %>% stringr::str_remove_all("\\(|\\)"))
}) %>%
tibble::add_case(Model = .y, .before = 1)
}) %>%
purrr::map_dfr(~.x) %>%
transform_tbl_to_rnd_vars(nbr_of_digits_1L_int = nbr_of_digits_1L_int)
return(tfd_sngl_predr_mdls_tb)
}
make_tfmn_cmprsn_plt <- function(data_tb,
depnt_var_nm_1L_chr,
dictionary_tb){
tfmn_cmprsn_plt <- tidyr::gather(data_tb %>%
dplyr::mutate(!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_log")) := log(!!rlang::sym(depnt_var_nm_1L_chr)),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_logit")) := psych::logit(!!rlang::sym(depnt_var_nm_1L_chr)),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_loglog")) := -log(-log(!!rlang::sym(depnt_var_nm_1L_chr))),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_cloglog")) := log(-log(1-!!rlang::sym(depnt_var_nm_1L_chr)))),
variable,
value,
!!rlang::sym(depnt_var_nm_1L_chr),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_log")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_logit")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_loglog")),
!!rlang::sym(paste0(depnt_var_nm_1L_chr,"_cloglog"))) %>%
dplyr::mutate(variable = factor(variable, levels = paste0(depnt_var_nm_1L_chr,c("",
"_log", "_logit", "_loglog", "_cloglog")),
labels= c("No transformation",
"Log", "Logit","Log-log", "Complementary log-log"))) %>%
ggplot2::ggplot(ggplot2::aes(x = value, fill = variable)) +
ggalt::geom_bkde() +
ggplot2::geom_rug() +
viridis::scale_fill_viridis(guide = "none", discrete = TRUE) +
ggplot2::facet_wrap(~variable, scales = "free") +
ggplot2::theme_bw() + ggplot2::labs(x = paste0("Transformed ",
dictionary_tb %>%
ready4::get_from_lup_obj(match_var_nm_1L_chr = "var_nm_chr",
match_value_xx = depnt_var_nm_1L_chr,
target_var_nm_1L_chr = "var_desc_chr",
evaluate_1L_lgl = F)))
return(tfmn_cmprsn_plt)
}
make_ttu_cs_ls <- function(outp_smry_ls, # Rename / Generalise from TTU
sig_covars_some_predrs_mdls_tb,
sig_thresh_covars_1L_chr){
# mdl_type_descs_chr <- outp_smry_ls$prefd_mdl_types_chr %>%
# purrr::map_chr(~ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
# match_var_nm_1L_chr = "short_name_chr",
# match_value_xx = .x,
# target_var_nm_1L_chr = "long_name_chr",
# evaluate_1L_lgl = F))
ttu_cs_ls <- list(best_mdl_types_ls = list(GLM = c("Gaussian distribution and log link"), # LEGACY ISSUE FROM MANUSCRIPT - OTHERWISE UNUSED
OLS = c("no transformation","log transformation", "clog-log transformation")),
selected_mdls_chr = outp_smry_ls$prefd_mdl_types_chr %>%
purrr::map_chr(~paste0(ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "fixed_acronym_chr",
evaluate_1L_lgl = F),
" with ",
ready4::get_from_lup_obj(outp_smry_ls$mdl_types_lup,
match_var_nm_1L_chr = "short_name_chr",
match_value_xx = .x,
target_var_nm_1L_chr = "with_chr",
evaluate_1L_lgl = F))),
cs_mdls_predrs_seq_dscdng_chr = outp_smry_ls$smry_of_mdl_sngl_predrs_tb$Predictor,
sig_covars_all_predrs_mdls_chr = outp_smry_ls$signt_covars_chr,
sig_thresh_covars_1L_chr = sig_thresh_covars_1L_chr,
sig_covars_some_predrs_mdls_tb = sig_covars_some_predrs_mdls_tb,
rf_seq_dscdng_chr = outp_smry_ls$predr_cmprsn_tb$predr_chr,
mdl_predrs_and_rf_seqs_cmprsn_1L_chr = ifelse(outp_smry_ls$smry_of_mdl_sngl_predrs_tb$Predictor[1] == outp_smry_ls$predr_cmprsn_tb$predr_chr[1],"is consistent","contrasts") # COMPUTE
)
return(ttu_cs_ls)
}
make_uid_rename_lup <- function(data_tb,
id_var_nm_1L_chr = "UID"){
uid_rename_lup_tb <- tibble::tibble(old_id_xx = data_tb %>%
dplyr::pull(id_var_nm_1L_chr) %>%
unique(),
new_id_int = 1:length(data_tb %>%
dplyr::pull(id_var_nm_1L_chr) %>%
unique()))
return(uid_rename_lup_tb)
}
make_unique_ls_elmt_idx_int <- function (data_ls)
{
combos_tb <- tibble::tibble(names_chr = data_ls %>% purrr::map_chr(~paste0(.x[1],ifelse(length(.x)>1,.x[2],""))),
indices_int = NA_integer_)
combos_tb <- combos_tb %>% dplyr::group_by(names_chr) %>%
dplyr::mutate(indices_int = dplyr::row_number())
unique_ls_elmt_idx_int <- combos_tb$indices_int
return(unique_ls_elmt_idx_int)
}
make_valid_params_ls_ls <- function(analysis_core_params_ls, # Generalise utility component
ds_tb,
path_params_ls,
maui_params_ls,
candidate_covar_nms_chr = NA_character_,
prefd_covars_chr = NULL,
prefd_mdl_types_chr = NULL,
raw_ds_tfmn_fn = NULL,
scndry_analysis_extra_vars_chr = NA_character_,
subtitle_1L_chr = "Methods Report 1: Analysis Program (Primary Analysis)",
utl_class_fn_1L_chr = "as.numeric"){
valid_params_ls_ls <- make_prmry_analysis_params_ls(analysis_core_params_ls = analysis_core_params_ls,
candidate_covar_nms_chr = candidate_covar_nms_chr,
ds_tb = ds_tb,
path_params_ls = path_params_ls,
maui_params_ls = maui_params_ls,
prefd_covars_chr = prefd_covars_chr,
prefd_mdl_types_chr = prefd_mdl_types_chr,
raw_ds_tfmn_fn = raw_ds_tfmn_fn,
subtitle_1L_chr = subtitle_1L_chr,
utl_class_fn_1L_chr = utl_class_fn_1L_chr) %>%
transform_params_ls_to_valid(scndry_analysis_extra_vars_chr = scndry_analysis_extra_vars_chr)
valid_params_ls_ls$params_ls$short_and_long_nm <- NULL
valid_params_ls_ls$short_and_long_nm <- maui_params_ls$short_and_long_nm
valid_params_ls_ls$path_params_ls <- path_params_ls
return(valid_params_ls_ls)
}
make_within_between_ratios_text <- function(results_ls,
exclude_covars_1L_lgl = F){
tb <- results_ls$ttu_lngl_ls$cs_ts_ratios_tb %>%
dplyr::distinct()
if(exclude_covars_1L_lgl)
tb <- tb %>%
dplyr::filter(contains_cndt_predr_lgl)
text_1L_chr <- tb %>%
purrr::pmap_chr(~paste0(..2, " for ", ..1)) %>%
paste0(collapse = ", ") %>%
stringi::stri_replace_last(fixed = ",", " and")
return(text_1L_chr)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.