dixes of custom dmt ls and examples

ready4-dev · Nov 17, 2023 · 04a7e57 · 04a7e57
1 parent fc6b4f8
commit 04a7e57
Show file tree

Hide file tree

Showing 64 changed files with 482 additions and 433 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -97,3 +97,4 @@
 ^doc$
 ^Meta$
 ^data-raw/mthds/exhibit\.R$
+^data-raw/examples/get_abbrs\.R$
diff --git a/CITATION.cff b/CITATION.cff
@@ -1,14 +1,14 @@
 cff-version: 1.2.0
 message: "Matthew Hamilton <[email protected]> [aut, cre] (<https://orcid.org/0000-0001-7407-9194>) and Glen Wiesner [aut] (<https://orcid.org/0000-0002-0071-130X>)  (2023). ready4fun: Author and Document Functions that Implement Transferable Health
-Economic Model Algorithms. Version 0.0.0.9528. Zenodo. https://doi.org/10.5281/zenodo.5611779"
+Economic Model Algorithms. Version 0.0.0.9530. Zenodo. https://doi.org/10.5281/zenodo.5611779"
 authors:
   - family-names: "(<https://orcid.org/0000-0001-7407-9194>)"
     given-names: "Matthew Hamilton <[email protected]> [aut, cre]"
   - family-names: "(<https://orcid.org/0000-0002-0071-130X>)"
     given-names: "Glen Wiesner [aut]"
 title: "ready4fun: Author and Document Functions that Implement Transferable Health
 Economic Model Algorithms"
-version: 0.0.0.9528
+version: 0.0.0.9530
 doi: 10.5281/zenodo.5611779
-date-released: 2023-10-02
+date-released: 2023-11-17
 url: "https://ready4-dev.github.io/ready4fun/"
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -44,7 +44,7 @@ Imports:
     purrr,
     readxl,
     ready4 (>= 0.0.0.9131),
-    ready4show,
+    ready4show (>= 0.0.0.9111),
     ready4use (>= 0.0.0.9231),
     rlang,
     sinew,
@@ -65,6 +65,7 @@ Depends:
 LazyData: true
 Suggests: 
     rmarkdown
-Remotes: 
+Remotes:  
     ready4-dev/ready4,
-    ready4-dev/ready4use
+    ready4-dev/ready4use,
+    ready4-dev/ready4show
diff --git a/NAMESPACE b/NAMESPACE
@@ -249,6 +249,7 @@ importFrom(ready4,update_pt_fn_args_ls)
 importFrom(ready4,update_tb_r3)
 importFrom(ready4,write_citation_cff)
 importFrom(ready4,write_env_objs_to_dv)
+importFrom(ready4,write_examples)
 importFrom(ready4,write_fls_to_dv)
 importFrom(ready4,write_from_tmp)
 importFrom(ready4,write_new_dirs)

diff --git a/R/fn_add.R b/R/fn_add.R
@@ -40,6 +40,7 @@ add_build_ignore <- function (build_ignore_ls)
 #' Add functions documentation tibble
 #' @description add_fns_dmt_tb() is an Add function that updates an object by adding data to that object. Specifically, this function implements an algorithm to add functions documentation tibble. Function argument pkg_setup_ls specifies the object to be updated. The function returns Package setup (a list).
 #' @param pkg_setup_ls Package setup (a list)
+#' @param append_1L_lgl Append (a logical vector of length one), Default: T
 #' @param dv_url_pfx_1L_chr Dataverse url prefix (a character vector of length one), Default: character(0)
 #' @param fns_env_ls Functions (a list of environments), Default: NULL
 #' @param inc_methods_1L_lgl Include methods (a logical vector of length one), Default: F
@@ -52,8 +53,8 @@ add_build_ignore <- function (build_ignore_ls)
 #' @importFrom tibble add_case tibble
 #' @importFrom dplyr filter bind_rows distinct
 #' @keywords internal
-add_fns_dmt_tb <- function (pkg_setup_ls, dv_url_pfx_1L_chr = character(0), fns_env_ls = NULL, 
-    inc_methods_1L_lgl = F, key_1L_chr = NULL) 
+add_fns_dmt_tb <- function (pkg_setup_ls, append_1L_lgl = T, dv_url_pfx_1L_chr = character(0), 
+    fns_env_ls = NULL, inc_methods_1L_lgl = F, key_1L_chr = NULL) 
 {
     paths_ls <- make_fn_nms(paste0(pkg_setup_ls$initial_ls$path_to_pkg_rt_1L_chr, 
         "/data-raw"))
@@ -71,7 +72,7 @@ add_fns_dmt_tb <- function (pkg_setup_ls, dv_url_pfx_1L_chr = character(0), fns_
         }
         pkg_setup_ls$subsequent_ls$fns_dmt_tb <- make_dmt_for_all_fns(paths_ls = paths_ls, 
             abbreviations_lup = pkg_setup_ls$subsequent_ls$abbreviations_lup, 
-            custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
+            append_1L_lgl = append_1L_lgl, custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
             fns_env_ls = fns_env_ls, fn_types_lup = pkg_setup_ls$subsequent_ls$fn_types_lup, 
             inc_all_mthds_1L_lgl = T, object_type_lup = pkg_setup_ls$subsequent_ls$object_type_lup, 
             undocumented_fns_dir_chr = undocumented_fns_dir_chr)
@@ -100,7 +101,7 @@ add_fns_dmt_tb <- function (pkg_setup_ls, dv_url_pfx_1L_chr = character(0), fns_
         }
         fns_dmt_tb <- make_dmt_for_all_fns(paths_ls = paths_ls, 
             abbreviations_lup = pkg_setup_ls$subsequent_ls$abbreviations_lup, 
-            custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
+            append_1L_lgl = append_1L_lgl, custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
             fns_env_ls = fns_env_ls, fn_types_lup = pkg_setup_ls$subsequent_ls$fn_types_lup, 
             inc_all_mthds_1L_lgl = T, object_type_lup = pkg_setup_ls$subsequent_ls$object_type_lup, 
             undocumented_fns_dir_chr = undocumented_fns_dir_chr)

diff --git a/R/fn_get.R b/R/fn_get.R
@@ -1,7 +1,9 @@
-#' Get abbreviations
-#' @description get_abbrs() is a Get function that retrieves a pre-existing data object from memory, local file system or online repository. Specifically, this function implements an algorithm to get abbreviations. Function argument text_1L_chr specifies the where to look for the required object. The function returns Abbreviations (a lookup table).
-#' @param text_1L_chr Text (a character vector of length one)
+#' Add additional packagesGet house style abbreviations
+#' @description add_addl_pkgs() is an Add function that updates an object by adding data to that object. Specifically, this function implements an algorithm to add additional packages. Function argument addl_pkgs_ls specifies the object to be updated. The function is called for its side effects and does not return a value.An aspect of the ready4 framework is a consistent house style for code. Retrieve details on framework abbreviations with `get_abbrs`.
+#' @param text_1L_chr Text (a character vector of length one), Default: character(0)
 #' @param abbreviations_lup Abbreviations (a lookup table), Default: NULL
+#' @param gh_repo_1L_chr Github repository (a character vector of length one), Default: 'ready4-dev/ready4'
+#' @param gh_tag_1L_chr Github tag (a character vector of length one), Default: 'Documentation_0.0'
 #' @param search_descs_1L_lgl Search descriptions (a logical vector of length one), Default: T
 #' @return Abbreviations (a lookup table)
 #' @rdname get_abbrs
@@ -10,21 +12,25 @@
 #' @importFrom dplyr filter
 #' @importFrom purrr map_lgl
 #' @importFrom stringr str_detect
-#' @keywords internal
-get_abbrs <- function (text_1L_chr, abbreviations_lup = NULL, search_descs_1L_lgl = T) 
+#' @example man/examples/get_abbrs.R
+get_abbrs <- function (text_1L_chr = character(0), abbreviations_lup = NULL, 
+    gh_repo_1L_chr = "ready4-dev/ready4", gh_tag_1L_chr = "Documentation_0.0", 
+    search_descs_1L_lgl = T) 
 {
     if (is.null(abbreviations_lup)) {
-        abbreviations_lup <- ready4use::Ready4useRepos(gh_repo_1L_chr = "ready4-dev/ready4", 
-            gh_tag_1L_chr = "Documentation_0.0") %>% ingest(fls_to_ingest_chr = c("abbreviations_lup"), 
+        abbreviations_lup <- ready4use::Ready4useRepos(gh_repo_1L_chr = gh_repo_1L_chr, 
+            gh_tag_1L_chr = gh_tag_1L_chr) %>% ingest(fls_to_ingest_chr = c("abbreviations_lup"), 
             metadata_1L_lgl = F)
     }
-    if (!search_descs_1L_lgl) {
-        abbreviations_lup <- abbreviations_lup %>% dplyr::filter(short_name_chr %>% 
-            purrr::map_lgl(~startsWith(.x, text_1L_chr)))
-    }
-    else {
-        abbreviations_lup <- abbreviations_lup %>% dplyr::filter(long_name_chr %>% 
-            purrr::map_lgl(~stringr::str_detect(.x, text_1L_chr)))
+    if (!identical(text_1L_chr, character(0))) {
+        if (!search_descs_1L_lgl) {
+            abbreviations_lup <- abbreviations_lup %>% dplyr::filter(short_name_chr %>% 
+                purrr::map_lgl(~startsWith(.x, text_1L_chr)))
+        }
+        else {
+            abbreviations_lup <- abbreviations_lup %>% dplyr::filter(long_name_chr %>% 
+                purrr::map_lgl(~stringr::str_detect(.x, text_1L_chr)))
+        }
     }
     return(abbreviations_lup)
 }
@@ -158,6 +164,7 @@ get_mthd_title <- function (mthd_nm_1L_chr, pkg_nm_1L_chr = "ready4")
 #' Get new abbreviations
 #' @description get_new_abbrs() is a Get function that retrieves a pre-existing data object from memory, local file system or online repository. Specifically, this function implements an algorithm to get new abbreviations. Function argument pkg_setup_ls specifies the where to look for the required object. The function returns New abbreviations (a character vector).
 #' @param pkg_setup_ls Package setup (a list)
+#' @param append_1L_lgl Append (a logical vector of length one), Default: T
 #' @param classes_to_make_tb Classes to make (a tibble), Default: NULL
 #' @param inc_all_mthds_1L_lgl Include all methods (a logical vector of length one), Default: T
 #' @param paths_ls Paths (a list), Default: make_fn_nms()
@@ -173,9 +180,9 @@ get_mthd_title <- function (mthd_nm_1L_chr, pkg_nm_1L_chr = "ready4")
 #' @importFrom tibble tibble
 #' @importFrom purrr map flatten_chr discard
 #' @keywords internal
-get_new_abbrs <- function (pkg_setup_ls, classes_to_make_tb = NULL, inc_all_mthds_1L_lgl = T, 
-    paths_ls = make_fn_nms(), pkg_ds_ls_ls = NULL, transformations_chr = NULL, 
-    undocumented_fns_dir_chr = make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T), 
+get_new_abbrs <- function (pkg_setup_ls, append_1L_lgl = T, classes_to_make_tb = NULL, 
+    inc_all_mthds_1L_lgl = T, paths_ls = make_fn_nms(), pkg_ds_ls_ls = NULL, 
+    transformations_chr = NULL, undocumented_fns_dir_chr = make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T), 
     use_last_1L_int = NULL, fns_dmt_tb = deprecated()) 
 {
     if (lifecycle::is_present(fns_dmt_tb)) {
@@ -185,7 +192,7 @@ get_new_abbrs <- function (pkg_setup_ls, classes_to_make_tb = NULL, inc_all_mthd
     if (identical(pkg_setup_ls$subsequent_ls$fns_dmt_tb, tibble::tibble())) {
         pkg_setup_ls$subsequent_ls$fns_dmt_tb <- make_dmt_for_all_fns(paths_ls = paths_ls, 
             abbreviations_lup = pkg_setup_ls$subsequent_ls$abbreviations_lup, 
-            custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
+            append_1L_lgl = append_1L_lgl, custom_dmt_ls = pkg_setup_ls$subsequent_ls$custom_dmt_ls, 
             fn_types_lup = pkg_setup_ls$subsequent_ls$fn_types_lup, 
             inc_all_mthds_1L_lgl = inc_all_mthds_1L_lgl, object_type_lup = pkg_setup_ls$subsequent_ls$object_type_lup, 
             undocumented_fns_dir_chr = undocumented_fns_dir_chr)

diff --git a/R/fn_make.R b/R/fn_make.R
@@ -375,24 +375,25 @@ make_depnt_fns_ls <- function (arg_ls, pkg_depcy_ls)
 }
 #' Make documentation for all functions
 #' @description make_dmt_for_all_fns() is a Make function that creates a new R object. Specifically, this function implements an algorithm to make documentation for all functions. The function returns All functions documentation (a tibble).
-#' @param paths_ls Paths (a list), Default: make_fn_nms()
-#' @param undocumented_fns_dir_chr Undocumented functions directory (a character vector), Default: make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T)
-#' @param custom_dmt_ls Custom documentation (a list), Default: make_custom_dmt_ls()
-#' @param fns_env_ls Functions (a list of environments), Default: NULL
-#' @param fn_types_lup Function types (a lookup table)
 #' @param abbreviations_lup Abbreviations (a lookup table)
+#' @param fn_types_lup Function types (a lookup table)
 #' @param object_type_lup Object type (a lookup table)
+#' @param append_1L_lgl Append (a logical vector of length one), Default: T
+#' @param custom_dmt_ls Custom documentation (a list), Default: make_custom_dmt_ls()
+#' @param fns_env_ls Functions (a list of environments), Default: NULL
 #' @param inc_all_mthds_1L_lgl Include all methods (a logical vector of length one), Default: T
+#' @param paths_ls Paths (a list), Default: make_fn_nms()
+#' @param undocumented_fns_dir_chr Undocumented functions directory (a character vector), Default: make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T)
 #' @return All functions documentation (a tibble)
 #' @rdname make_dmt_for_all_fns
 #' @export 
 #' @importFrom utils data
 #' @importFrom purrr map2_dfr
 #' @importFrom dplyr mutate case_when
 #' @keywords internal
-make_dmt_for_all_fns <- function (paths_ls = make_fn_nms(), undocumented_fns_dir_chr = make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T), 
+make_dmt_for_all_fns <- function (abbreviations_lup, fn_types_lup, object_type_lup, append_1L_lgl = T, 
     custom_dmt_ls = make_custom_dmt_ls(), fns_env_ls = NULL, 
-    fn_types_lup, abbreviations_lup, object_type_lup, inc_all_mthds_1L_lgl = T) 
+    inc_all_mthds_1L_lgl = T, paths_ls = make_fn_nms(), undocumented_fns_dir_chr = make_undmtd_fns_dir_chr(drop_empty_1L_lgl = T)) 
 {
     if (is.null(abbreviations_lup)) {
         utils::data("abbreviations_lup", package = "ready4fun", 
@@ -404,7 +405,7 @@ make_dmt_for_all_fns <- function (paths_ls = make_fn_nms(), undocumented_fns_dir
     all_fns_dmt_tb <- purrr::map2_dfr(paths_ls, undocumented_fns_dir_chr, 
         ~{
             fns_dmt_tb <- make_fn_dmt_tbl(.x, fns_dir_chr = .y, 
-                custom_dmt_ls = custom_dmt_ls, append_1L_lgl = T, 
+                custom_dmt_ls = custom_dmt_ls, append_1L_lgl = append_1L_lgl, 
                 fns_env_ls = fns_env_ls, fn_types_lup = fn_types_lup, 
                 abbreviations_lup = abbreviations_lup, object_type_lup = object_type_lup)
             if (inc_all_mthds_1L_lgl) {
@@ -457,9 +458,7 @@ make_fn_desc <- function (fns_chr, title_chr, output_chr, fns_env_ls, fn_types_l
             abbreviations_lup = abbreviations_lup, is_generic_1L_lgl = is_generic_1L_lgl), 
             ifelse(fn_output_1L_chr == "NULL", ifelse(is_generic_1L_lgl, 
                 "", paste0(" The function is called for its side effects and does not return a value.", 
-                  ifelse(fn_name_1L_chr %>% test_for_write_R_warning_fn(), 
-                    " WARNING: This function writes R scripts to your local environment. Make sure to only use if you want this behaviour", 
-                    ""))), paste0(" The function returns ", make_ret_obj_desc(fn, 
+                  "")), paste0(" The function returns ", make_ret_obj_desc(fn, 
                 abbreviations_lup = abbreviations_lup, starts_sentence_1L_lgl = T), 
                 ".")))
     })

diff --git a/R/fn_update.R b/R/fn_update.R
@@ -279,8 +279,8 @@ update_fns_dmt_tb <- function (fns_dmt_tb, title_ls = NULL, desc_ls = NULL, deta
             input_ls <- input_ls_ls[[idx_1L_dbl]] %>% purrr::map(~.x[lgl_vecs_ls[[idx_1L_dbl]]])
             updated_fns_dmt_tb <- purrr::reduce(1:length(lgl_vecs_ls[[idx_1L_dbl]]), 
                 .init = updated_fns_dmt_tb, ~{
-                  eval(parse(text = paste0("new_ls <- ", input_ls[[2]])))
-                  args_ls <- list(.x, data_1L_chr = input_ls[[1]], 
+                  eval(parse(text = paste0("new_ls <- ", input_ls[[2]][.y])))
+                  args_ls <- list(.x, data_1L_chr = input_ls[[1]][.y], 
                     new_ls = new_ls, append_1L_lgl = append_1L_lgl)
                   if (idx_1L_dbl == 2) {
                     args_ls$append_1L_lgl <- NULL
@@ -312,13 +312,13 @@ update_fns_dmt_tb_chr_vars <- function (fns_dmt_tb, data_1L_chr, new_ls, append_
     }
     else {
         fns_dmt_tb <- dplyr::mutate(fns_dmt_tb, `:=`(!!rlang::sym(data_1L_chr), 
-            dplyr::case_when(fns_chr %in% names(new_ls) ~ paste0(ifelse(append_1L_lgl, 
-                paste0(ifelse(is.na(!!rlang::sym(data_1L_chr)), 
+            dplyr::case_when(.data$fns_chr %in% names(new_ls) ~ 
+                paste0(ifelse(append_1L_lgl, paste0(ifelse(is.na(!!rlang::sym(data_1L_chr)), 
                   "", !!rlang::sym(data_1L_chr)), ""), ""), fns_chr %>% 
-                purrr::map_chr(~{
-                  ifelse(.x %in% names(new_ls), new_ls[[.x]], 
-                    NA_character_)
-                })), TRUE ~ !!rlang::sym(data_1L_chr))))
+                  purrr::map_chr(~{
+                    ifelse(.x %in% names(new_ls), new_ls[[.x]], 
+                      NA_character_)
+                  })), TRUE ~ !!rlang::sym(data_1L_chr))))
     }
     return(fns_dmt_tb)
 }
@@ -363,7 +363,7 @@ update_fns_dmt_tb_lgl_vars <- function (fns_dmt_tb, data_1L_chr, new_ls)
 #' @keywords internal
 update_fns_dmt_tb_ls_vars <- function (fns_dmt_tb, data_1L_chr, new_ls, append_1L_lgl) 
 {
-    if (is.na(data_1L_chr)) {
+    if (is.na(data_1L_chr[1])) {
         fns_dmt_tb <- fns_dmt_tb
     }
     else {

diff --git a/R/fn_validate.R b/R/fn_validate.R
@@ -1,6 +1,7 @@
 #' Validate package setup
 #' @description validate_pkg_setup() is a Validate function that validates that an object conforms to required criteria. Specifically, this function implements an algorithm to validate package setup. The function returns Package setup (a list).
 #' @param pkg_setup_ls Package setup (a list)
+#' @param append_1L_lgl Append (a logical vector of length one), Default: T
 #' @param is_method_1L_lgl Is method (a logical vector of length one), Default: F
 #' @return Package setup (a list)
 #' @rdname validate_pkg_setup
@@ -10,7 +11,7 @@
 #' @importFrom stringr str_sub
 #' @importFrom Hmisc capitalize
 #' @keywords internal
-validate_pkg_setup <- function (pkg_setup_ls, is_method_1L_lgl = F) 
+validate_pkg_setup <- function (pkg_setup_ls, append_1L_lgl = T, is_method_1L_lgl = F) 
 {
     message(paste0("Validating ", ifelse(is_method_1L_lgl, "manifest", 
         "pkg_setup_ls"), ". This may take a couple of minutes."))
@@ -73,9 +74,10 @@ validate_pkg_setup <- function (pkg_setup_ls, is_method_1L_lgl = F)
         }
         fns_env_ls <- read_fns(make_undmtd_fns_dir_chr(path_1L_chr = paste0(pkg_setup_ls$initial_ls$path_to_pkg_rt_1L_chr, 
             "/data-raw"), drop_empty_1L_lgl = T))
-        pkg_setup_ls <- add_fns_dmt_tb(pkg_setup_ls, fns_env_ls = fns_env_ls)
+        pkg_setup_ls <- add_fns_dmt_tb(pkg_setup_ls, append_1L_lgl = append_1L_lgl, 
+            fns_env_ls = fns_env_ls)
         missing_obj_types_chr <- get_new_abbrs(pkg_setup_ls, 
-            classes_to_make_tb = pkg_setup_ls$subsequent_ls$cls_fn_ls$args_ls$x, 
+            append_1L_lgl = append_1L_lgl, classes_to_make_tb = pkg_setup_ls$subsequent_ls$cls_fn_ls$args_ls$x, 
             pkg_ds_ls_ls = pkg_setup_ls$subsequent_ls$pkg_ds_ls_ls, 
             use_last_1L_int = 1)
         if (!identical(missing_obj_types_chr, character(0))) {
@@ -92,7 +94,7 @@ validate_pkg_setup <- function (pkg_setup_ls, is_method_1L_lgl = F)
         }
         else {
             missing_abbrs_chr <- get_new_abbrs(pkg_setup_ls, 
-                classes_to_make_tb = pkg_setup_ls$subsequent_ls$cls_fn_ls$args_ls$x, 
+                append_1L_lgl = append_1L_lgl, classes_to_make_tb = pkg_setup_ls$subsequent_ls$cls_fn_ls$args_ls$x, 
                 pkg_ds_ls_ls = pkg_setup_ls$subsequent_ls$pkg_ds_ls_ls)
             if (!identical(missing_abbrs_chr, character(0))) {
                 message(paste0("The following potential abbreviation",
-Original file line number
+Diff line change
@@ Expand Up / @@ -97,3 +97,4 @@ @@
     ^doc$
     ^Meta$
     ^data-raw/mthds/exhibit\.R$
+    ^data-raw/examples/get_abbrs\.R$