Skip to content

Commit

Permalink
new download logic
Browse files Browse the repository at this point in the history
  • Loading branch information
matthewphamilton committed Feb 12, 2024
1 parent 9e66da3 commit 3a59dcc
Show file tree
Hide file tree
Showing 18 changed files with 657 additions and 713 deletions.
2 changes: 1 addition & 1 deletion .github/workflows/pkgdown.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down
7 changes: 4 additions & 3 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@ RoxygenNote: 7.2.3
Suggests:
knitr,
rmarkdown,
scorz,
scorz (>= 0.0.0.9062),
testthat
VignetteBuilder: knitr
Imports:
Expand Down Expand Up @@ -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
10 changes: 10 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down
21 changes: 11 additions & 10 deletions R/fn_get.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
Expand Down
93 changes: 93 additions & 0 deletions R/fn_transform.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
4 changes: 1 addition & 3 deletions data-raw/DATASET.R
Original file line number Diff line number Diff line change
Expand Up @@ -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") %>%
Expand Down
Loading

0 comments on commit 3a59dcc

Please sign in to comment.