data-raw/fns/add.R

In ready4-dev/specific: Specify Models to Solve Inverse Problems

add_prefd_predr_var_to_mdl_smry_ls <- function(mdl_smry_ls,
                                               ds_smry_ls){
  mdl_smry_ls$predr_var_nm_1L_chr <- ds_smry_ls$candidate_predrs_chr[1]
  mdl_smry_ls$predr_var_desc_1L_chr <- ds_smry_ls$predictors_lup %>% ready4::get_from_lup_obj(match_value_xx = mdl_smry_ls$predr_var_nm_1L_chr, match_var_nm_1L_chr = "short_name_chr", target_var_nm_1L_chr = "long_name_chr",
                                                                                                 evaluate_1L_lgl = F)
  mdl_smry_ls$predr_vals_dbl <- make_predr_vals(mdl_smry_ls$predr_var_nm_1L_chr,
                                                candidate_predrs_lup = ds_smry_ls$predictors_lup)
  return(mdl_smry_ls)
}
add_tfd_var_to_ds <- function(data_tb,
                               depnt_var_nm_1L_chr,
                               tfmn_1L_chr,
                               depnt_var_max_val_1L_dbl = NULL){
  data_tb <- data_tb %>% dplyr::mutate(`:=`(!!rlang::sym(transform_depnt_var_nm(depnt_var_nm_1L_chr,
                                                                                tfmn_1L_chr = tfmn_1L_chr)), !!rlang::sym(depnt_var_nm_1L_chr) %>%
                                              calculate_depnt_var_tfmn(tfmn_1L_chr = tfmn_1L_chr,
                                                                      tfmn_is_outp_1L_lgl = F,
                                                                      depnt_var_max_val_1L_dbl = depnt_var_max_val_1L_dbl)))
  return(data_tb)
}
add_utility_predn_to_ds <- function (data_tb,
                                     model_mdl,
                                     tfmn_1L_chr,
                                     depnt_var_nm_1L_chr,
                                     force_min_max_1L_lgl = T,
                                     force_new_data_1L_lgl = F,
                                     impute_1L_lgl = T,
                                     is_brms_mdl_1L_lgl = T,
                                     new_data_is_1L_chr = "Predicted",
                                     predn_type_1L_chr = NULL,
                                     predr_vars_nms_chr = NULL,
                                     rmv_tfd_depnt_var_1L_lgl = F,
                                     sd_dbl = NA_real_,
                                     utl_cls_fn = NULL,
                                     utl_min_val_1L_dbl = -1)
{
  depnt_vars_chr <- c(depnt_var_nm_1L_chr, transform_depnt_var_nm(depnt_var_nm_1L_chr = depnt_var_nm_1L_chr,
                                                                  tfmn_1L_chr = tfmn_1L_chr)) %>% unique()
  data_tb <- purrr::reduce(depnt_vars_chr, .init = data_tb, ~dplyr::mutate(.x,
                                                                           !!rlang::sym(.y):= NA_real_))
  if(force_min_max_1L_lgl){
    min_max_vals_dbl <- c(utl_min_val_1L_dbl,1)
  }else{
    min_max_vals_dbl <- numeric(0)
  }
  predictions_dbl <- predict_vals(data_tb = data_tb, tfmn_1L_chr = tfmn_1L_chr,
                                  model_mdl = model_mdl,
                                  min_max_vals_dbl = min_max_vals_dbl,
                                  impute_1L_lgl = impute_1L_lgl,
                                  new_data_is_1L_chr = new_data_is_1L_chr,
                                  var_cls_fn = utl_cls_fn,
                                  is_brms_mdl_1L_lgl = is_brms_mdl_1L_lgl,
                                  force_new_data_1L_lgl = force_new_data_1L_lgl,
                                  predn_type_1L_chr = predn_type_1L_chr,
                                  sd_dbl = sd_dbl)
  data_tb <- data_tb %>% dplyr::mutate(!!rlang::sym(depnt_var_nm_1L_chr):=predictions_dbl)
  if(!is.null(predr_vars_nms_chr)){
    derived_predrs_chr <- purrr::map(predr_vars_nms_chr, ~ paste0(.x,c("_baseline","_change","_scaled","_unscaled"))) %>%
      purrr::flatten_chr() %>% intersect(names(data_tb))
    data_tb <- data_tb %>% dplyr::select(-tidyselect::all_of(derived_predrs_chr))
  }
  if(rmv_tfd_depnt_var_1L_lgl){
    data_tb <- data_tb %>% dplyr::select(-tidyselect::all_of(depnt_vars_chr[depnt_vars_chr!=depnt_var_nm_1L_chr]))
  }
  return(data_tb)
}
add_utl_predn_to_new_ds <- function(data_tb,
                                    ingredients_ls,
                                    mdl_nm_1L_chr,
                                    analysis_1L_chr = NULL,
                                    deterministic_1L_lgl = T,
                                    force_min_max_1L_lgl = T,
                                    id_var_nm_1L_chr = NULL,
                                    model_mdl = NULL,
                                    new_data_is_1L_chr = "Simulated",
                                    predr_vars_nms_chr = NULL,
                                    round_var_nm_1L_chr = "Timepoint",
                                    round_bl_val_1L_chr = "BL",
                                    utl_cls_fn = NULL,
                                    utl_var_nm_1L_chr = NULL){
  if(is.null(model_mdl))
    model_mdl <- get_table_predn_mdl(mdl_nm_1L_chr,
                                     ingredients_ls = ingredients_ls,
                                     analysis_1L_chr = analysis_1L_chr)
  mdl_type_1L_chr <- get_mdl_type_from_nm(mdl_nm_1L_chr)
  tfmn_1L_chr <- ready4::get_from_lup_obj(ingredients_ls$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)
  predn_type_1L_chr <- ready4::get_from_lup_obj(ingredients_ls$mdl_types_lup,
                                                match_value_xx = mdl_type_1L_chr,
                                                match_var_nm_1L_chr = "short_name_chr",
                                                target_var_nm_1L_chr = "predn_type_chr",
                                                evaluate_1L_lgl = F)
  if(is.na(predn_type_1L_chr))
    predn_type_1L_chr <- NULL
  id_var_nm_1L_chr <- ifelse(is.null(id_var_nm_1L_chr),
                             ingredients_ls$id_var_nm_1L_chr,
                             id_var_nm_1L_chr)
  if(!is.null(predr_vars_nms_chr)){
    data_tb <- rename_from_nmd_vec(data_tb,
                                   nmd_vec_chr = predr_vars_nms_chr,
                                   vec_nms_as_new_1L_lgl = T)
  }
  mdl_predr_terms_chr <- ingredients_ls$mdls_lup %>%
    dplyr::filter(mdl_nms_chr == mdl_nm_1L_chr) %>%
    dplyr::pull(predrs_ls) %>%
    purrr::flatten_chr()
  original_ds_vars_chr <- names(data_tb)[!names(data_tb) %in% c(mdl_predr_terms_chr,
                                                                ifelse(!is.null(utl_var_nm_1L_chr),
                                                                       utl_var_nm_1L_chr,
                                                                       ingredients_ls$depnt_var_nm_1L_chr))]
  updated_tb <- data_tb %>%
    transform_ds_to_predn_ds(predr_vars_nms_chr = mdl_predr_terms_chr,
                             tfmn_1L_chr = tfmn_1L_chr,
                             depnt_var_nm_1L_chr = ingredients_ls$depnt_var_nm_1L_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,
                             predictors_lup = ingredients_ls$predictors_lup) %>%
    add_utility_predn_to_ds(model_mdl = model_mdl,
                            tfmn_1L_chr = tfmn_1L_chr,
                            depnt_var_nm_1L_chr = ingredients_ls$depnt_var_nm_1L_chr,
                            predr_vars_nms_chr = mdl_predr_terms_chr,
                            force_min_max_1L_lgl = force_min_max_1L_lgl,
                            force_new_data_1L_lgl = T,
                            impute_1L_lgl = T, # Redundant?
                            is_brms_mdl_1L_lgl = inherits(model_mdl,"brmsfit"),
                            new_data_is_1L_chr = new_data_is_1L_chr,
                            predn_type_1L_chr = NULL,
                            rmv_tfd_depnt_var_1L_lgl = T,
                            utl_cls_fn = utl_cls_fn,
                            utl_min_val_1L_dbl = ingredients_ls$utl_min_val_1L_dbl,
                            sd_dbl = get_random_intercept(ingredients_ls$mdls_smry_tb,
                                                          mdl_nm_1L_chr = mdl_nm_1L_chr,
                                                          deterministic_1L_lgl = deterministic_1L_lgl))

  if(!is.null(utl_var_nm_1L_chr)){
    updated_tb <- updated_tb %>%
      dplyr::rename(!!rlang::sym(utl_var_nm_1L_chr):=tidyselect::all_of(ingredients_ls$depnt_var_nm_1L_chr))
  }
  if(!is.null(names(predr_vars_nms_chr))){
    updated_tb <- rename_from_nmd_vec(updated_tb,
                                      nmd_vec_chr = predr_vars_nms_chr,
                                      vec_nms_as_new_1L_lgl = F)
  }
  names_to_inc_chr <- c(names(updated_tb),
                        setdiff(names(data_tb),
                                names(updated_tb)))
  rename_tb <- make_uid_rename_lup(data_tb,
                                   id_var_nm_1L_chr = id_var_nm_1L_chr)
  updated_tb <- dplyr::left_join(data_tb %>%
                                   dplyr::select(tidyselect::all_of(original_ds_vars_chr)) %>%
                                   transform_uid_var(id_var_nm_1L_chr = id_var_nm_1L_chr,
                                                     rename_tb = rename_tb),
                                 updated_tb) %>%
    transform_uid_var(id_var_nm_1L_chr = id_var_nm_1L_chr,
                      rename_tb = rename_tb,
                      old_new_chr = c("new_id_int","old_id_xx"))
  return(updated_tb)
}