new depict and other mthds

Author: matthewphamilton

CITATION.cff

@@ -0,0 +1,12 @@
+cff-version: 1.2.0
+message: "Matthew Hamilton and Caroline Gao  (2022). specific: Specify Candidate Models for Representing Mental Health Systems. Version 0.0.0.9073. Zenodo. https://doi.org/10.5281/zenodo.5768689"
+authors:
+  - family-names: "Hamilton"
+    given-names: "Matthew"
+  - family-names: "Gao"
+    given-names: "Caroline"
+title: "specific: Specify Candidate Models for Representing Mental Health Systems"
+version: 0.0.0.9073
+doi: 10.5281/zenodo.5768689
+date-released: 2022-02-15
+url: "https://ready4-dev.github.io/specific/"

DESCRIPTION

@@ -119,10 +119,15 @@ Collate:
     'pkg_specific.R'
     'specific-package.R'
 Suggests: 
-    scorz,
-    rmarkdown
-Remotes: 
+    scorz (>= 0.0.0.9048),
+    rmarkdown,
+    betareg,
+    cmdstanr (>= 0.4.0.9000),
+    rstan
+Remotes:  
     ready4-dev/ready4,
     ready4-dev/ready4show,
     ready4-dev/ready4use,
-    ready4-dev/youthvars
+    ready4-dev/youthvars,
+    stan-dev/cmdstanr,
+    ready4-dev/scorz

NAMESPACE

@@ -263,6 +263,7 @@ importFrom(caret,R2)
 importFrom(caret,RMSE)
 importFrom(caret,createFolds)
 importFrom(cowplot,draw_image)
+importFrom(cowplot,get_legend)
 importFrom(cowplot,ggdraw)
 importFrom(cowplot,plot_grid)
 importFrom(cowplot,save_plot)
@@ -316,8 +317,10 @@ importFrom(hutils,longest_prefix)
 importFrom(kableExtra,add_header_above)
 importFrom(kableExtra,collapse_rows)
 importFrom(kableExtra,column_spec)
+importFrom(kableExtra,footnote)
 importFrom(kableExtra,kable_styling)
 importFrom(kableExtra,kbl)
+importFrom(kableExtra,row_spec)
 importFrom(knitr,include_graphics)
 importFrom(knitr,knit_child)
 importFrom(knitr,knit_expand)
@@ -435,6 +438,8 @@ importFrom(xfun,numbers_to_words)
 importFrom(youthvars,add_interval_var)
 importFrom(youthvars,add_participation_var)
 importFrom(youthvars,make_corstars_tbl_xx)
+importFrom(youthvars,make_sub_tot_plts)
+importFrom(youthvars,make_var_by_round_plt)
 importFrom(youthvars,transform_ds_for_tstng)
 importFrom(youthvars,transform_ds_with_rename_lup)
 importFrom(youthvars,transform_tb_for_merged_col_1)

R/fn_make.R

@@ -343,8 +343,9 @@ make_cmpst_sctr_and_dnst_plt <- function (outp_smry_ls, output_data_dir_1L_chr =
             cowplot::draw_image(.x))
     }
     else {
-        plot_ls <- outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr() %>% 
-            mdl_idxs_int[] %>% purrr::map(~{
+        plots_chr <- outp_smry_ls$mdl_nms_ls %>% purrr::flatten_chr()
+        plots_chr <- plots_chr[mdl_idxs_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)) {

R/fn_print.R

@@ -23,7 +23,7 @@ print_all_plts_for_mdl_set <- function (output_ls, start_from_1L_int = 0L)
 #' @return NULL
 #' @rdname print_cohort_table
 #' @export 
-#' @importFrom dplyr mutate mutate_all
+#' @importFrom dplyr mutate filter mutate_all
 #' @importFrom purrr map_chr
 #' @importFrom Hmisc capitalize
 #' @importFrom stringr str_replace
@@ -37,6 +37,7 @@ print_cohort_table <- function (params_ls, caption_1L_chr, mkdn_tbl_ref_1L_chr)
     df <- results_ls$tables_ls$participant_descs
     df$variable <- gsub("\\s*\\([^\\)]+\\)", "", df$variable)
     df <- df %>% dplyr::mutate(variable = variable %>% purrr::map_chr(~Hmisc::capitalize(.x)))
+    df <- dplyr::filter(df, !df[, 3] == "")
     if (params_ls$output_type_1L_chr == "PDF") {
         df <- df %>% dplyr::mutate_all(~stringr::str_replace(.x, 
             "%", "\\\\%") %>% stringr::str_replace(",", "\\\\,"))
@@ -137,7 +138,9 @@ print_covar_ttu_tbls <- function (params_ls, caption_1L_chr, table_1L_chr, ref_1
 #' @rdname print_indpnt_predrs_coefs_tbl
 #' @export 
 #' @importFrom stringr str_replace_all
-#' @importFrom purrr map_chr
+#' @importFrom dplyr mutate across case_when
+#' @importFrom kableExtra kbl kable_styling column_spec row_spec add_header_above collapse_rows footnote
+#' @importFrom knitr opts_current
 #' @importFrom ready4show print_table
 print_indpnt_predrs_coefs_tbl <- function (params_ls, caption_1L_chr, mkdn_tbl_ref_1L_chr) 
 {
@@ -159,14 +162,31 @@ print_indpnt_predrs_coefs_tbl <- function (params_ls, caption_1L_chr, mkdn_tbl_r
             "\\\\textbf", ""), "\\{", ""), "\\}", "")
     }
     if (params_ls$output_type_1L_chr == "PDF") {
-        tb$Parameter <- tb$Parameter %>% purrr::map_chr(~ifelse(endsWith(.x, 
-            " model"), paste0("\\textbf{", .x, "}"), .x))
+        tb %>% dplyr::mutate(dplyr::across(.cols = everything(), 
+            ~dplyr::case_when(is.na(.x) ~ "", T ~ .x))) %>% kableExtra::kbl(booktabs = T, 
+            caption = knitr::opts_current$get("tab.cap"), escape = F, 
+            longtable = T, col.names = c("Parameter", "Estimate", 
+                "SE", "CI (95\\%)", "R2", "Sigma", "Estimate", 
+                "SE", "CI (95\\%)", "R2", "Sigma")) %>% kableExtra::kable_styling(latex_options = c("repeat_header")) %>% 
+            kableExtra::column_spec(3:6, width = "3em") %>% kableExtra::row_spec(which(!is.na(tb[, 
+            5])), bold = T) %>% kableExtra::add_header_above(parse(text = paste0("c(", 
+            "\" \"", ", ", paste0("\"", results_ls$ttu_lngl_ls$best_mdls_tb[[1, 
+                "model_type"]], " - ", results_ls$ttu_lngl_ls$best_mdls_tb[[1, 
+                "link_and_tfmn_chr"]], "\" = 5"), ", ", paste0("\"", 
+                results_ls$ttu_lngl_ls$best_mdls_tb[[2, "model_type"]], 
+                " - ", results_ls$ttu_lngl_ls$best_mdls_tb[[2, 
+                  "link_and_tfmn_chr"]], "\" = 5"), ")")) %>% 
+            eval()) %>% kableExtra::collapse_rows(columns = 1) %>% 
+            kableExtra::footnote(general = make_scaling_text(results_ls), 
+                general_title = " ")
+    }
+    else {
+        ready4show::print_table(output_type_1L_chr = params_ls$output_type_1L_chr, 
+            caption_1L_chr = caption_1L_chr, mkdn_tbl_ref_1L_chr = mkdn_tbl_ref_1L_chr, 
+            use_rdocx_1L_lgl = ifelse(params_ls$output_type_1L_chr == 
+                "Word", T, F), add_to_row_ls = add_to_row_ls, 
+            footnotes_chr = make_scaling_text(results_ls), sanitize_fn = force)
     }
-    tb %>% ready4show::print_table(output_type_1L_chr = params_ls$output_type_1L_chr, 
-        caption_1L_chr = caption_1L_chr, mkdn_tbl_ref_1L_chr = mkdn_tbl_ref_1L_chr, 
-        use_rdocx_1L_lgl = ifelse(params_ls$output_type_1L_chr == 
-            "Word", T, F), add_to_row_ls = add_to_row_ls, footnotes_chr = make_scaling_text(results_ls), 
-        sanitize_fn = force)
 }
 #' Print independent predictors longitudinal model coefficients
 #' @description print_indpnt_predrs_lngl_mdl_coefs() is a Print function that prints output to console Specifically, this function implements an algorithm to print independent predictors longitudinal model coefficients. The function is called for its side effects and does not return a value.

R/fn_write.R

@@ -1380,16 +1380,22 @@ write_ts_mdls <- function (data_tb, depnt_var_nm_1L_chr = "utl_total_w", predr_v
 #' @param backend_1L_chr Backend (a character vector of length one), Default: getOption("brms.backend", "rstan")
 #' @param iters_1L_int Iterations (an integer vector of length one), Default: 4000
 #' @param new_dir_nm_1L_chr New directory name (a character vector of length one), Default: 'F_TS_Mdls'
+#' @param path_to_write_to_1L_chr Path to write to (a character vector of length one), Default: 'NA'
 #' @param prior_ls Prior (a list), Default: NULL
 #' @param control_ls Control (a list), Default: NULL
 #' @return Output summary (a list)
 #' @rdname write_ts_mdls_from_alg_outp
 #' @export 
+#' @importFrom stringr str_sub
 write_ts_mdls_from_alg_outp <- function (outp_smry_ls, predictors_lup, utl_min_val_1L_dbl = -1, 
     backend_1L_chr = getOption("brms.backend", "rstan"), iters_1L_int = 4000L, 
-    new_dir_nm_1L_chr = "F_TS_Mdls", prior_ls = NULL, control_ls = NULL) 
+    new_dir_nm_1L_chr = "F_TS_Mdls", path_to_write_to_1L_chr = NA_character_, 
+    prior_ls = NULL, control_ls = NULL) 
 {
-    output_dir_1L_chr <- write_new_outp_dir(outp_smry_ls$path_to_write_to_1L_chr, 
+    if (is.na(path_to_write_to_1L_chr)) 
+        path_to_write_to_1L_chr <- outp_smry_ls$path_to_write_to_1L_chr %>% 
+            stringr::str_sub(end = -8)
+    output_dir_1L_chr <- write_new_outp_dir(path_to_write_to_1L_chr, 
         new_dir_nm_1L_chr = new_dir_nm_1L_chr)
     mdls_smry_tb <- write_ts_mdls(data_tb = outp_smry_ls$scored_data_tb, 
         depnt_var_nm_1L_chr = outp_smry_ls$depnt_var_nm_1L_chr, 

R/mthd_author.R

@@ -74,6 +74,52 @@ methods::setMethod("author", "SpecificModels", function (x, prefd_mdl_types_chr
 })
 #' 
 #' Author and save files
+#' @name author-SpecificSynopsis
+#' @description author method applied to SpecificSynopsis
+#' @param x An object of class SpecificSynopsis
+#' @param reference_1L_int Reference (an integer vector of length one), Default: NA
+#' @param type_1L_chr Type (a character vector of length one), Default: 'Report'
+#' @param what_1L_chr What (a character vector of length one), Default: 'Catalogue'
+#' @return NULL
+#' @rdname author-methods
+#' @aliases author,SpecificSynopsis-method
+#' @export 
+#' @importFrom purrr map2_chr map_chr
+#' @importFrom ready4 write_to_dv_with_wait author
+#' @importFrom tibble tibble
+methods::setMethod("author", "SpecificSynopsis", function (x, reference_1L_int = NA_integer_, type_1L_chr = "Report", 
+    what_1L_chr = "Catalogue") 
+{
+    if (what_1L_chr == "Catalogue") {
+        outp_smry_ls_ls <- manufacture(x@b_SpecificResults, what_1L_chr = "indexed_shareable")
+        if (is.na(reference_1L_int)) {
+            outp_smry_ls_ls <- outp_smry_ls_ls[reference_1L_int]
+        }
+        ctlg_nms_chr <- purrr::map2_chr(outp_smry_ls_ls, 1:length(outp_smry_ls_ls), 
+            ~{
+                fl_nm_1L_chr <- paste0("AAA_TTU_MDL_CTG", ifelse(.y == 
+                  1, "", paste0("-", (.y - 1))))
+                authorReport(x %>% renewSlot("b_SpecificResults@a_SpecificShareable@shareable_outp_ls", 
+                  .x), fl_nm_1L_chr = fl_nm_1L_chr, what_1L_chr = "Catalogue")
+                fl_nm_1L_chr
+            })
+        if (!is.na(x@e_Ready4useRepos@dv_ds_nm_1L_chr)) {
+            ready4::write_to_dv_with_wait(dss_tb = tibble::tibble(ds_obj_nm_chr = ctlg_nms_chr, 
+                title_chr = purrr::map_chr(1:length(ctlg_nms_chr), 
+                  ~paste0("Catalogue of utility mapping models", 
+                    ifelse(.x == 1, " (Primary Analysis)", paste0(" (Supplementary Analysis ", 
+                      (.x - 1), ")"))))), dv_nm_1L_chr = x@e_Ready4useRepos@dv_nm_1L_chr, 
+                ds_url_1L_chr = x@e_Ready4useRepos@dv_ds_nm_1L_chr, 
+                parent_dv_dir_1L_chr = paste0(x@b_SpecificResults@a_SpecificShareable@shareable_outp_ls$path_to_write_to_1L_chr, 
+                  "/H_Dataverse"), paths_to_dirs_chr = paste0(x@a_Ready4showPaths@outp_data_dir_1L_chr, 
+                  "/", x@a_Ready4showPaths@reports_dir_1L_chr, 
+                  "/", what_1L_chr), inc_fl_types_chr = ".pdf", 
+                paths_are_rltv_1L_lgl = F)
+        }
+    }
+})
+#' 
+#' Author and save files
 #' @name author-SpecificProject
 #' @description author method applied to SpecificProject
 #' @param x An object of class SpecificProject

R/mthd_authorData.R

@@ -23,7 +23,7 @@ methods::setMethod("authorData", "SpecificMixed", function (x, title_1L_chr = "A
             outp_smry_ls[-1]
         })
         x <- renewSlot(x, "c_SpecificResults@a_SpecificShareable@shareable_outp_ls", 
-            outp_smry_ls[-1])
+            append(results_ls[[1]], results_ls[-1]))
     }
     return(x)
 })

R/mthd_depict.R

@@ -3,31 +3,51 @@
 #' @name depict-SpecificSynopsis
 #' @description depict method applied to SpecificSynopsis
 #' @param x An object of class SpecificSynopsis
-#' @param base_height PARAM_DESCRIPTION, Default: 13
+#' @param axis_text_sclg_1L_dbl Axis text scaling (a double vector of length one), Default: 1.5
+#' @param axis_title_sclg_1L_dbl Axis title scaling (a double vector of length one), Default: 2
+#' @param base_height_1L_dbl Base height (a double vector of length one), Default: 13
 #' @param base_size_1L_dbl Base size (a double vector of length one), Default: 30
 #' @param depnt_var_desc_1L_chr Dependent variable description (a character vector of length one), Default: 'NA'
+#' @param dim_plot_heights_int Dimension plot heights (an integer vector), Default: c(10L, 1L)
+#' @param dim_plot_log_log_tfmn_1L_lgl Dimension plot log log transformation (a logical vector of length one), Default: F
+#' @param dim_plot_rows_cols_pair_int Dimension plot rows columns pair (an integer vector), Default: c(3L, 2L)
 #' @param labels_chr Labels (a character vector), Default: c("A", "B", "C", "D")
 #' @param label_x_1L_dbl Label x (a double vector of length one), Default: 0.2
 #' @param label_y_1L_dbl Label y (a double vector of length one), Default: 0.9
 #' @param label_size_1L_dbl Label size (a double vector of length one), Default: 30
+#' @param legend_sclg_1L_dbl Legend scaling (a double vector of length one), Default: 2
 #' @param mdl_idxs_int Model indices (an integer vector), Default: 1:2
+#' @param rel_heights_dbl Rel heights (a double vector), Default: c(4, 10, 1)
+#' @param scale_dbl Scale (a double vector), Default: c(0.9, 0.9, 0.9)
 #' @param timepoint_old_nms_chr Timepoint old names (a character vector), Default: 'NA'
 #' @param timepoint_new_nms_chr Timepoint new names (a character vector), Default: 'NA'
 #' @param use_png_fls_1L_lgl Use png files (a logical vector of length one), Default: F
+#' @param utl_plot_label_1L_chr Utility plot label (a character vector of length one), Default: ' '
+#' @param utl_by_rnd_plots_params_ls Utility by round plots parameters (a list), Default: list(width_1L_dbl = 6, height_1L_dbl = 4)
 #' @param what_1L_chr What (a character vector of length one), Default: 'composite_mdl'
 #' @param write_1L_lgl Write (a logical vector of length one), Default: F
+#' @param y_label_1L_chr Y label (a character vector of length one), Default: ' '
 #' @return Plot (a plot)
 #' @rdname depict-methods
 #' @aliases depict,SpecificSynopsis-method
 #' @export 
 #' @importFrom ready4show ready4show_correspondences
-#' @importFrom cowplot save_plot
-#' @importFrom ready4 depict
-methods::setMethod("depict", "SpecificSynopsis", function (x, base_height = 13, base_size_1L_dbl = 30, depnt_var_desc_1L_chr = NA_character_, 
-    labels_chr = c("A", "B", "C", "D"), label_x_1L_dbl = 0.2, 
-    label_y_1L_dbl = 0.9, label_size_1L_dbl = 30, mdl_idxs_int = 1:2, 
+#' @importFrom rlang exec
+#' @importFrom youthvars make_var_by_round_plt make_sub_tot_plts
+#' @importFrom ready4 get_from_lup_obj depict
+#' @importFrom cowplot get_legend plot_grid save_plot
+#' @importFrom ggplot2 theme
+methods::setMethod("depict", "SpecificSynopsis", function (x, axis_text_sclg_1L_dbl = 1.5, axis_title_sclg_1L_dbl = 2, 
+    base_height_1L_dbl = 13, base_size_1L_dbl = 30, depnt_var_desc_1L_chr = NA_character_, 
+    dim_plot_heights_int = c(10L, 1L), dim_plot_log_log_tfmn_1L_lgl = F, 
+    dim_plot_rows_cols_pair_int = c(3L, 2L), labels_chr = c("A", 
+        "B", "C", "D"), label_x_1L_dbl = 0.2, label_y_1L_dbl = 0.9, 
+    label_size_1L_dbl = 30, legend_sclg_1L_dbl = 2, mdl_idxs_int = 1:2, 
+    rel_heights_dbl = c(4, 10, 1), scale_dbl = c(0.9, 0.9, 0.9), 
     timepoint_old_nms_chr = NA_character_, timepoint_new_nms_chr = NA_character_, 
-    use_png_fls_1L_lgl = F, what_1L_chr = "composite_mdl", write_1L_lgl = F) 
+    use_png_fls_1L_lgl = F, utl_plot_label_1L_chr = " ", utl_by_rnd_plots_params_ls = list(width_1L_dbl = 6, 
+        height_1L_dbl = 4), what_1L_chr = "composite_mdl", write_1L_lgl = F, 
+    y_label_1L_chr = " ") 
 {
     plt <- NULL
     outp_smry_ls <- append(x@b_SpecificResults@a_SpecificShareable@shareable_outp_ls, 
@@ -45,10 +65,43 @@ methods::setMethod("depict", "SpecificSynopsis", function (x, base_height = 13,
             labels_chr = labels_chr, label_x_1L_dbl = label_x_1L_dbl, 
             label_y_1L_dbl = label_y_1L_dbl, label_size_1L_dbl = label_size_1L_dbl, 
             mdl_idxs_int = mdl_idxs_int, use_png_fls_1L_lgl = use_png_fls_1L_lgl)
-        if (write_1L_lgl) {
-            cowplot::save_plot(paste0(outp_smry_ls$path_to_write_to_1L_chr, 
-                "/dens_and_sctr.png"), plt, base_height = base_height)
-        }
+        write_path_1L_chr <- paste0(outp_smry_ls$path_to_write_to_1L_chr, 
+            "/dens_and_sctr.png")
+    }
+    if (what_1L_chr == "composite_utl") {
+        ds_descvs_ls <- manufacture_SpecificSynopsis(x, what_1L_chr = "ds_descvs_ls")
+        outp_smry_ls <- append(x@b_SpecificResults@a_SpecificShareable@shareable_outp_ls, 
+            x@b_SpecificResults@b_SpecificPrivate@private_outp_ls)
+        maui_domains_col_nms_chr <- x@c_SpecificParameters@domain_labels_chr
+        first_plt <- rlang::exec(youthvars::make_var_by_round_plt, 
+            !!!list(data_tb = outp_smry_ls$scored_data_tb, legend_sclg_1L_dbl = legend_sclg_1L_dbl, 
+                var_nm_1L_chr = ds_descvs_ls$utl_wtd_var_nm_1L_chr, 
+                round_var_nm_1L_chr = ds_descvs_ls$round_var_nm_1L_chr, 
+                x_label_1L_chr = ds_descvs_ls$dictionary_tb %>% 
+                  ready4::get_from_lup_obj(match_value_xx = ds_descvs_ls$utl_wtd_var_nm_1L_chr, 
+                    match_var_nm_1L_chr = "var_nm_chr", target_var_nm_1L_chr = "var_desc_chr", 
+                    evaluate_1L_lgl = F) %>% as.vector(), label_fill_1L_chr = utl_plot_label_1L_chr, 
+                axis_text_sclg_1L_dbl = axis_text_sclg_1L_dbl, 
+                axis_title_sclg_1L_dbl = axis_title_sclg_1L_dbl, 
+                y_label_1L_chr = y_label_1L_chr))
+        second_plt <- rlang::exec(youthvars::make_sub_tot_plts, 
+            !!!list(data_tb = outp_smry_ls$scored_data_tb, add_legend_1L_lgl = F, 
+                axis_text_sclg_1L_dbl = axis_text_sclg_1L_dbl, 
+                axis_title_sclg_1L_dbl = axis_title_sclg_1L_dbl, 
+                col_nms_chr = maui_domains_col_nms_chr, legend_sclg_1L_dbl = legend_sclg_1L_dbl, 
+                plot_rows_cols_pair_int = dim_plot_rows_cols_pair_int, 
+                round_var_nm_1L_chr = ds_descvs_ls$round_var_nm_1L_chr, 
+                heights_int = dim_plot_heights_int, make_log_log_tfmn_1L_lgl = dim_plot_log_log_tfmn_1L_lgl, 
+                y_label_1L_chr = y_label_1L_chr))
+        legend_ls <- cowplot::get_legend(first_plt)
+        plt <- cowplot::plot_grid(first_plt + ggplot2::theme(legend.position = "none"), 
+            second_plt, legend_ls, nrow = 3L, rel_heights = rel_heights_dbl, 
+            scale = scale_dbl)
+        write_path_1L_chr <- paste0(x@a_Ready4showPaths@outp_data_dir_1L_chr, 
+            "/Output/_Descriptives/combined_utl.png")
+    }
+    if (write_1L_lgl) {
+        cowplot::save_plot(write_path_1L_chr, plt, base_height = base_height_1L_dbl)
     }
     return(plt)
 })

R/mthd_investigate.R

@@ -64,6 +64,7 @@ methods::setMethod("investigate", "SpecificMixed", function (x, backend_1L_chr =
             utl_min_val_1L_dbl = x@b_SpecificParameters@depnt_var_min_max_dbl[1], 
             backend_1L_chr = backend_1L_chr, new_dir_nm_1L_chr = new_dir_nm_1L_chr, 
             iters_1L_int = x@b_SpecificParameters@iters_1L_int, 
+            path_to_write_to_1L_chr = x@a_Ready4showPaths@outp_data_dir_1L_chr, 
             prior_ls = prior_ls, control_ls = control_ls)
         rename_lup <- x@c_SpecificResults@a_SpecificShareable@shareable_outp_ls$rename_lup
         session_ls <- x@c_SpecificResults@a_SpecificShareable@shareable_outp_ls$session_ls