new download logic

Author: matthewphamilton

.github/workflows/pkgdown.yaml

@@ -59,7 +59,7 @@ jobs:
         run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE)
         shell: Rscript {0}
 
-      - name: Deploy to GitHub pages <U+0001F680>
+      - name: Deploy to GitHub pages 🚀
         if: github.event_name != 'pull_request'
         uses: JamesIves/[email protected]
         with:

DESCRIPTION

@@ -26,7 +26,7 @@ RoxygenNote: 7.2.3
 Suggests: 
     knitr,
     rmarkdown,
-    scorz,
+    scorz (>= 0.0.0.9062),
     testthat
 VignetteBuilder: knitr
 Imports: 
@@ -57,8 +57,9 @@ Imports:
 Depends: 
     R (>= 2.10)
 LazyData: true
-Remotes: 
+Remotes:  
     ready4-dev/ready4,
     ready4-dev/ready4use,
     ready4-dev/specific,
-    ready4-dev/youthvars
+    ready4-dev/youthvars,
+    ready4-dev/scorz

NAMESPACE

@@ -39,6 +39,8 @@ export(make_predn_metadata_ls)
 export(make_sngl_grp_ds)
 export(predict_from_mdl_coefs)
 export(transform_ds_for_cmprsn)
+export(transform_ds_to_drop_msng)
+export(transform_ds_to_long)
 export(update_col_with_diff)
 export(update_multpl_cols_with_diffs)
 import(methods)
@@ -60,6 +62,7 @@ importFrom(dplyr,everything)
 importFrom(dplyr,filter)
 importFrom(dplyr,group_by)
 importFrom(dplyr,lag)
+importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
 importFrom(dplyr,n)
 importFrom(dplyr,pull)
@@ -91,6 +94,8 @@ importFrom(purrr,pmap_dfr)
 importFrom(purrr,reduce)
 importFrom(purrr,walk)
 importFrom(ready4,get_from_lup_obj)
+importFrom(ready4,ingest)
+importFrom(ready4use,Ready4useRepos)
 importFrom(ready4use,add_labels_from_dictionary)
 importFrom(rlang,exec)
 importFrom(rlang,sym)
@@ -102,10 +107,15 @@ importFrom(stats,na.omit)
 importFrom(stats,rgamma)
 importFrom(stats,rnorm)
 importFrom(stats,setNames)
+importFrom(stringi,stri_replace_first_fixed)
+importFrom(stringi,stri_replace_last_fixed)
 importFrom(stringr,str_detect)
+importFrom(stringr,str_remove_all)
 importFrom(stringr,str_replace)
 importFrom(tibble,as_tibble)
+importFrom(tibble,rowid_to_column)
 importFrom(tibble,tibble)
+importFrom(tidyr,pivot_longer)
 importFrom(tidyr,pivot_wider)
 importFrom(tidyselect,all_of)
 importFrom(truncnorm,rtruncnorm)

R/fn_get.R

@@ -153,27 +153,28 @@ get_mdl_ds_url <- function (mdls_lup, mdl_nm_1L_chr)
 #' @description get_mdl_from_dv() is a Get function that extracts data from an object. Specifically, this function implements an algorithm to get model from dataverse. The function returns Model (a model).
 #' @param mdl_nm_1L_chr Model name (a character vector of length one)
 #' @param dv_ds_nm_1L_chr Dataverse dataset name (a character vector of length one), Default: 'https://doi.org/10.7910/DVN/JC6PTV'
+#' @param dv_nm_1L_chr Dataverse name (a character vector of length one), Default: 'TTU'
 #' @param server_1L_chr Server (a character vector of length one), Default: 'dataverse.harvard.edu'
 #' @param key_1L_chr Key (a character vector of length one), Default: NULL
 #' @return Model (a model)
 #' @rdname get_mdl_from_dv
 #' @export 
-#' @importFrom dataverse dataset_files
-#' @importFrom purrr map_chr
+#' @importFrom ready4use Ready4useRepos
+#' @importFrom ready4 ingest
+#' @importFrom purrr pluck
 get_mdl_from_dv <- function (mdl_nm_1L_chr, dv_ds_nm_1L_chr = "https://doi.org/10.7910/DVN/JC6PTV", 
-    server_1L_chr = "dataverse.harvard.edu", key_1L_chr = NULL) 
+    dv_nm_1L_chr = "TTU", server_1L_chr = "dataverse.harvard.edu", 
+    key_1L_chr = NULL) 
 {
-    ds_ls <- dataverse::dataset_files(dv_ds_nm_1L_chr, server = server_1L_chr, 
-        key = key_1L_chr)
-    all_mdls_chr <- purrr::map_chr(ds_ls, ~.x$label)
-    idx_1L_int <- which(all_mdls_chr == paste0(mdl_nm_1L_chr, 
-        ".RDS"))
+    X <- ready4use::Ready4useRepos(dv_nm_1L_chr = dv_nm_1L_chr, 
+        dv_server_1L_chr = server_1L_chr, dv_ds_nm_1L_chr = dv_ds_nm_1L_chr)
+    contents_ls <- ready4::ingest(X, metadata_1L_lgl = F)
+    idx_1L_int <- which(names(contents_ls) == mdl_nm_1L_chr)
     if (identical(idx_1L_int, integer(0))) {
         model_mdl <- NULL
     }
     else {
-        model_mdl <- readRDS(url(paste0("https://dataverse.harvard.edu/api/access/datafile/", 
-            ds_ls[[idx_1L_int]]$dataFile$id)))
+        model_mdl <- contents_ls %>% purrr::pluck(idx_1L_int)
     }
     return(model_mdl)
 }

R/fn_transform.R

@@ -30,3 +30,96 @@ transform_ds_for_cmprsn <- function (ds_tb, cmprsn_var_nm_1L_chr, id_var_nm_1L_c
         cmprsn_groups_chr)
     return(ds_tb)
 }
+#' Transform dataset to drop missing
+#' @description transform_ds_to_drop_msng() is a Transform function that edits an object in such a way that core object attributes - e.g. shape, dimensions, elements, type - are altered. Specifically, this function implements an algorithm to transform dataset to drop missing. The function returns Dataset (a tibble).
+#' @param ds_tb Dataset (a tibble)
+#' @param predictors_chr Predictors (a character vector)
+#' @param uid_var_nm_1L_chr Unique identifier variable name (a character vector of length one), Default: 'UID_chr'
+#' @return Dataset (a tibble)
+#' @rdname transform_ds_to_drop_msng
+#' @export 
+#' @importFrom dplyr pull filter
+#' @importFrom rlang sym
+#' @keywords internal
+transform_ds_to_drop_msng <- function (ds_tb, predictors_chr, uid_var_nm_1L_chr = "UID_chr") 
+{
+    drop_chr <- ds_tb[rowSums(is.na(ds_tb[predictors_chr])) > 
+        0, ] %>% dplyr::pull(!!rlang::sym(uid_var_nm_1L_chr))
+    ds_tb <- dplyr::filter(ds_tb, !(!!rlang::sym(uid_var_nm_1L_chr) %in% 
+        drop_chr))
+    return(ds_tb)
+}
+#' Transform dataset to long
+#' @description transform_ds_to_long() is a Transform function that edits an object in such a way that core object attributes - e.g. shape, dimensions, elements, type - are altered. Specifically, this function implements an algorithm to transform dataset to long. The function returns Dataset (a tibble).
+#' @param ds_tb Dataset (a tibble)
+#' @param predictors_chr Predictors (a character vector)
+#' @param drop_underscore_1L_lgl Drop underscore (a logical vector of length one), Default: T
+#' @param msrmnt_date_var_nm_1L_chr Measurement date variable name (a character vector of length one), Default: 'date_dtm'
+#' @param round_var_nm_1L_chr Round variable name (a character vector of length one), Default: 'Timepoint_chr'
+#' @param row_id_nm_1L_chr Row identity name (a character vector of length one), Default: 'case_id'
+#' @param time_is_sfx_1L_lgl Time is suffix (a logical vector of length one), Default: T
+#' @return Dataset (a tibble)
+#' @rdname transform_ds_to_long
+#' @export 
+#' @importFrom stringi stri_replace_first_fixed stri_replace_last_fixed
+#' @importFrom purrr map map_lgl map_chr flatten_chr reduce
+#' @importFrom stats setNames
+#' @importFrom stringr str_remove_all
+#' @importFrom tidyr pivot_longer
+#' @importFrom tibble rowid_to_column
+#' @importFrom dplyr mutate select left_join
+#' @importFrom rlang sym
+#' @importFrom tidyselect all_of
+#' @keywords internal
+transform_ds_to_long <- function (ds_tb, predictors_chr, drop_underscore_1L_lgl = T, 
+    msrmnt_date_var_nm_1L_chr = "date_dtm", round_var_nm_1L_chr = "Timepoint_chr", 
+    row_id_nm_1L_chr = "case_id", time_is_sfx_1L_lgl = T) 
+{
+    names_chr <- names(ds_tb)
+    if (time_is_sfx_1L_lgl) {
+        crop_fn <- stringi::stri_replace_first_fixed
+        select_fn <- startsWith
+    }
+    else {
+        crop_fn <- stringi::stri_replace_last_fixed
+        select_fn <- endsWith
+    }
+    predictors_ls <- predictors_chr %>% purrr::map(~{
+        predictor_1L_chr <- .x
+        predictor_vars_chr <- names_chr[names_chr %>% purrr::map_lgl(~{
+            name_1L_chr <- .x
+            select_fn(name_1L_chr, predictor_1L_chr)
+        })]
+    }) %>% stats::setNames(predictors_chr)
+    prefixes_chr <- suffixes_chr <- character(0)
+    extensions_chr <- predictors_ls[[1]] %>% purrr::map_chr(~crop_fn(.x, 
+        pattern = names(predictors_ls)[1], replacement = ""))
+    if (time_is_sfx_1L_lgl) {
+        suffixes_chr <- extensions_chr
+    }
+    else {
+        prefixes_chr <- extensions_chr
+    }
+    if (drop_underscore_1L_lgl) {
+        tfmn_fn <- function(x) {
+            stringr::str_remove_all(x, "_")
+        }
+    }
+    else {
+        tfmn_fn <- identity
+    }
+    predictor_vars_chr <- predictors_ls %>% purrr::flatten_chr()
+    other_vars_chr <- setdiff(names_chr, c(paste0(prefixes_chr, 
+        msrmnt_date_var_nm_1L_chr, suffixes_chr), predictor_vars_chr))
+    ds_tb <- c(msrmnt_date_var_nm_1L_chr, predictors_chr) %>% 
+        purrr::map(~ds_tb %>% tidyr::pivot_longer(cols = paste0(prefixes_chr, 
+            .x, suffixes_chr), names_to = round_var_nm_1L_chr, 
+            values_to = .x) %>% tibble::rowid_to_column(row_id_nm_1L_chr) %>% 
+            dplyr::mutate(`:=`(!!rlang::sym(round_var_nm_1L_chr), 
+                !!rlang::sym(round_var_nm_1L_chr) %>% crop_fn(pattern = .x, 
+                  replacement = "") %>% tfmn_fn() %>% factor())) %>% 
+            dplyr::select(tidyselect::all_of(c(row_id_nm_1L_chr, 
+                other_vars_chr, round_var_nm_1L_chr, .x)))) %>% 
+        purrr::reduce(~dplyr::left_join(.x, .y)) %>% dplyr::select(-tidyselect::all_of(row_id_nm_1L_chr))
+    return(ds_tb)
+}

data-raw/DATASET.R

@@ -55,9 +55,7 @@ z <- ready4pack::make_pt_ready4pack_manifest(x,
                                              pkg_ds_ls_ls = datasets_ls) %>%
   ready4pack::ready4pack_manifest()
 z <- ready4::author(z)
-usethis::use_dev_package("scorz",
-                         type = "Suggests",
-                         remote = "ready4-dev/scorz")
+usethis::use_dev_package("scorz", type = "Suggests", remote = "ready4-dev/scorz")
 ready4::write_extra_pkgs_to_actions(path_to_dir_1L_chr = ".github/workflows", consent_1L_chr = "Y")
 write_to_edit_workflow("pkgdown.yaml", consent_1L_chr = "Y") # In other packages, run for "test-coverage.yaml" as well.
 readLines("_pkgdown.yml") %>%