Skip to content

Commit

Permalink
wip on import to reform renew and create depict methods
Browse files Browse the repository at this point in the history
  • Loading branch information
@matthewphamilton
matthewphamilton committed Oct 31, 2024
1 parent 2bd5f6a commit 44ec805
Show file tree
Hide file tree
Showing 7 changed files with 860 additions and 166 deletions.
164 changes: 93 additions & 71 deletions data-raw/fns/add.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,76 +20,27 @@ add_dictionary <- function (X_Ready4useDyad = Ready4useDyad(), new_cases_r3 = re
dplyr::filter(var_nm_chr %in% names(X_Ready4useDyad@ds_tb))
return(X_Ready4useDyad)
}
add_from_lup_prototype <- function(data_tb,
arrange_1L_chr = character(0),
exclude_chr = character(0),
lup_prototype_tb = NULL,
match_var_nm_1L_chr = "UID_chr",
method_1L_chr = c("first", "sample"),
type_1L_chr = c("sequential", "batch", "self"),
vars_chr = character(0)){
method_1L_chr <- match.arg(method_1L_chr)
add_discrete_palette <- function (plot_plt, colours_chr = c("#de2d26","#fc9272"),
missing_1L_chr = "grey50",
type_1L_chr = c("ggsci", "manual",
"viridis"),
what_1L_chr = "lancet")
{
type_1L_chr <- match.arg(type_1L_chr)
if(type_1L_chr == "sequential"){
data_tb <- purrr::reduce(vars_chr,
.init = data_tb,
~ .x %>%
dplyr::left_join(lup_prototype_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr, .y))) %>% dplyr::distinct()))
if (type_1L_chr == "ggsci") {
one_fn <- get_journal_palette_fn("colour", what_1L_chr = what_1L_chr)
two_fn <- get_journal_palette_fn("fill", what_1L_chr = what_1L_chr)
plot_plt <- plot_plt + one_fn(na.value = missing_1L_chr) + two_fn(na.value = missing_1L_chr)
}
if(type_1L_chr == "batch"){
distinct_tb <- lup_prototype_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr,setdiff(setdiff(names(lup_prototype_tb), names(data_tb)), exclude_chr)))) %>%
make_imputed_distinct_cases(uid_1L_chr = match_var_nm_1L_chr,
method_1L_chr = method_1L_chr)
data_tb <- data_tb %>%
dplyr::left_join(distinct_tb)
if(type_1L_chr == "manual"){
plot_plt <- plot_plt + ggplot2::scale_fill_manual(values = colours_chr)
}
if(type_1L_chr == "self"){
if(identical(vars_chr, character(0))){
vars_chr <- setdiff(names(data_tb), c(match_var_nm_1L_chr, exclude_chr))
}
data_tb <- purrr::reduce(vars_chr,
.init = data_tb,
~ {
distinct_tb <- .x %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr, .y))) %>%
make_imputed_distinct_cases(uid_1L_chr = match_var_nm_1L_chr,
method_1L_chr = method_1L_chr)
complete_tb <- .x %>%
dplyr::filter(!is.na(!!rlang::sym(.y)))
missing_tb <- .x %>%
dplyr::filter(is.na(!!rlang::sym(.y)))
imputed_tb <- missing_tb %>% dplyr::select(-tidyselect::all_of(.y)) %>%
dplyr::left_join(distinct_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr,.y))))
dplyr::bind_rows(complete_tb, imputed_tb)
}
)
if (type_1L_chr == "viridis") {
plot_plt <- plot_plt + viridis::scale_color_viridis(discrete = TRUE,
option = what_1L_chr) + viridis::scale_fill_viridis(discrete = TRUE,
option = what_1L_chr)
}
if(!identical(arrange_1L_chr, character(0)))
data_tb <- data_tb %>% dplyr::arrange(!!rlang::sym(arrange_1L_chr))
return(data_tb)
}
add_latest_match <- function(data_tb,
dynamic_lup,
target_var_nm_1L_chr,
date_var_1L_chr = "Date",
invert_1L_lgl = FALSE,
match_var_nm_1L_chr = "UID_chr",
type_1L_chr = c("chr","dbl","int","lgl")){
type_1L_chr <- match.arg(type_1L_chr)
exec_ls <- switch(type_1L_chr,
"chr" = list(fn = purrr::map2_chr, missing = NA_character_),
"dbl" = list(fn = purrr::map2_dbl, missing = NA_real_),
"int" = list(fn = purrr::map2_int, missing = NA_integer_),
"lgl" = list(fn = purrr::map2_lgl, missing = NA))
test_fn <- ifelse(invert_1L_lgl,`>=`,`<=`)
data_tb <- data_tb %>%
dplyr::mutate(!!rlang::sym(target_var_nm_1L_chr) := !!rlang::sym(match_var_nm_1L_chr) %>% exec_ls$fn(!!rlang::sym(date_var_1L_chr),~ifelse(is.na(.x) | !.x %in% (dynamic_lup %>% dplyr::pull(!!rlang::sym(match_var_nm_1L_chr))),
exec_ls$missing,
ready4::get_from_lup_obj(dynamic_lup %>% dplyr::filter(test_fn(!!rlang::sym(date_var_1L_chr),.y)),
match_var_nm_1L_chr = match_var_nm_1L_chr,
match_value_xx = .x,
target_var_nm_1L_chr = target_var_nm_1L_chr))))
return(data_tb)

return(plot_plt)
}
add_ds_to_dv_repo <- function(dv_1L_chr,
ds_meta_ls,
Expand Down Expand Up @@ -205,14 +156,61 @@ add_files_to_dv <- function (files_tb, data_dir_rt_1L_chr = ".", ds_url_1L_chr,
..1, "/", ..2, ..3)
fl_nm_1L_chr <- paste0(..2, ..3)
ready4::write_fls_to_dv(path_1L_chr,
descriptions_chr = ..4,
ds_url_1L_chr = ds_url_1L_chr,
ds_ls = ds_ls,
key_1L_chr = key_1L_chr,
server_1L_chr = server_1L_chr)
descriptions_chr = ..4,
ds_url_1L_chr = ds_url_1L_chr,
ds_ls = ds_ls,
key_1L_chr = key_1L_chr,
server_1L_chr = server_1L_chr)
})
return(fl_ids_int)
}
add_from_lup_prototype <- function(data_tb,
arrange_1L_chr = character(0),
exclude_chr = character(0),
lup_prototype_tb = NULL,
match_var_nm_1L_chr = "UID_chr",
method_1L_chr = c("first", "sample"),
type_1L_chr = c("sequential", "batch", "self"),
vars_chr = character(0)){
method_1L_chr <- match.arg(method_1L_chr)
type_1L_chr <- match.arg(type_1L_chr)
if(type_1L_chr == "sequential"){
data_tb <- purrr::reduce(vars_chr,
.init = data_tb,
~ .x %>%
dplyr::left_join(lup_prototype_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr, .y))) %>% dplyr::distinct()))
}
if(type_1L_chr == "batch"){
distinct_tb <- lup_prototype_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr,setdiff(setdiff(names(lup_prototype_tb), names(data_tb)), exclude_chr)))) %>%
make_imputed_distinct_cases(uid_1L_chr = match_var_nm_1L_chr,
method_1L_chr = method_1L_chr)
data_tb <- data_tb %>%
dplyr::left_join(distinct_tb)
}
if(type_1L_chr == "self"){
if(identical(vars_chr, character(0))){
vars_chr <- setdiff(names(data_tb), c(match_var_nm_1L_chr, exclude_chr))
}
data_tb <- purrr::reduce(vars_chr,
.init = data_tb,
~ {
distinct_tb <- .x %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr, .y))) %>%
make_imputed_distinct_cases(uid_1L_chr = match_var_nm_1L_chr,
method_1L_chr = method_1L_chr)
complete_tb <- .x %>%
dplyr::filter(!is.na(!!rlang::sym(.y)))
missing_tb <- .x %>%
dplyr::filter(is.na(!!rlang::sym(.y)))
imputed_tb <- missing_tb %>% dplyr::select(-tidyselect::all_of(.y)) %>%
dplyr::left_join(distinct_tb %>% dplyr::select(tidyselect::all_of(c(match_var_nm_1L_chr,.y))))
dplyr::bind_rows(complete_tb, imputed_tb)
}
)
}
if(!identical(arrange_1L_chr, character(0)))
data_tb <- data_tb %>% dplyr::arrange(!!rlang::sym(arrange_1L_chr))
return(data_tb)
}
add_labels_from_dictionary <- function(ds_tb,
dictionary_tb,
remove_old_lbls_1L_lgl = F){
Expand All @@ -237,6 +235,30 @@ add_labels_from_dictionary <- function(ds_tb,
}
return(labelled_ds_tb)
}
add_latest_match <- function(data_tb,
dynamic_lup,
target_var_nm_1L_chr,
date_var_1L_chr = "Date",
invert_1L_lgl = FALSE,
match_var_nm_1L_chr = "UID_chr",
type_1L_chr = c("chr","dbl","int","lgl")){
type_1L_chr <- match.arg(type_1L_chr)
exec_ls <- switch(type_1L_chr,
"chr" = list(fn = purrr::map2_chr, missing = NA_character_),
"dbl" = list(fn = purrr::map2_dbl, missing = NA_real_),
"int" = list(fn = purrr::map2_int, missing = NA_integer_),
"lgl" = list(fn = purrr::map2_lgl, missing = NA))
test_fn <- ifelse(invert_1L_lgl,`>=`,`<=`)
data_tb <- data_tb %>%
dplyr::mutate(!!rlang::sym(target_var_nm_1L_chr) := !!rlang::sym(match_var_nm_1L_chr) %>% exec_ls$fn(!!rlang::sym(date_var_1L_chr),~ifelse(is.na(.x) | !.x %in% (dynamic_lup %>% dplyr::pull(!!rlang::sym(match_var_nm_1L_chr))),
exec_ls$missing,
ready4::get_from_lup_obj(dynamic_lup %>% dplyr::filter(test_fn(!!rlang::sym(date_var_1L_chr),.y)),
match_var_nm_1L_chr = match_var_nm_1L_chr,
match_value_xx = .x,
target_var_nm_1L_chr = target_var_nm_1L_chr))))
return(data_tb)

}
add_with_join <- function (X_Ready4useDyad,
Y_Ready4useDyad){
X_Ready4useDyad@ds_tb <- dplyr::left_join(X_Ready4useDyad@ds_tb,
Expand Down
113 changes: 113 additions & 0 deletions data-raw/fns/get.R
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,35 @@
get_colour_codes <- function(colour_1L_int = 1,
manual_chr = c("#de2d26","#fc9272"),
pick_1L_int = integer(0),
single_1L_lgl = FALSE,
style_1L_chr = get_styles(),
type_1L_chr = c("ggsci", "manual", "viridis")){
style_1L_chr <- match.arg(style_1L_chr)
type_1L_chr <- match.arg(type_1L_chr)
if(identical(pick_1L_int, integer(0))){
pick_1L_int <- colour_1L_int
}
if(type_1L_chr == "manual"){
colour_codes_chr <- ggpubr::get_palette(manual_chr, k=colour_1L_int)
}else{
defaults_chr <- get_styles(type_1L_chr)
if(!style_1L_chr %in% defaults_chr){
style_1L_chr <- defaults_chr[1]
}
}
if(type_1L_chr == "ggsci"){
colour_codes_chr <- ggpubr::get_palette(style_1L_chr, k=colour_1L_int)
}
if(type_1L_chr == "viridis")
colour_codes_chr <- viridis::viridis(colour_1L_int, option = style_1L_chr)
if(single_1L_lgl){
colour_codes_chr <- colour_codes_chr[pick_1L_int]
}else{
colour_codes_chr <- colour_codes_chr[1:pick_1L_int]
}
colour_codes_chr <- colour_codes_chr %>% purrr::discard(is.na)
return(colour_codes_chr)
}
get_drop_offs <- function(X_Ready4useDyad = Ready4useDyad(),
condition_1L_chr = ">1",
uid_var_nm_1L_chr = "uid_chr"){
Expand Down Expand Up @@ -74,6 +106,72 @@ get_fl_meta_from_dv_ls <- function (ds_ls,
}
return(metadata_xx)
}
get_journal_palette_fn <- function (type_1L_chr = c("colour", "fill"), what_1L_chr = "lancet")
{
type_1L_chr <- match.arg(type_1L_chr)
options_ls <- list(scale_colour_aaas = ggsci::scale_colour_aaas,
scale_colour_bmj = ggsci::scale_colour_bmj, scale_colour_bs5 = ggsci::scale_colour_bs5,
scale_colour_cosmic = ggsci::scale_colour_cosmic, scale_colour_d3 = ggsci::scale_colour_d3,
scale_colour_flatui = ggsci::scale_colour_flatui, scale_colour_frontiers = ggsci::scale_colour_frontiers,
scale_colour_futurama = ggsci::scale_colour_futurama,
scale_colour_gsea = ggsci::scale_colour_gsea, scale_colour_igv = ggsci::scale_colour_igv,
scale_colour_jama = ggsci::scale_colour_jama, scale_colour_jco = ggsci::scale_colour_jco,
scale_colour_lancet = ggsci::scale_colour_lancet, scale_colour_locuszoom = ggsci::scale_colour_locuszoom,
scale_colour_material = ggsci::scale_colour_material,
scale_colour_nejm = ggsci::scale_colour_nejm, scale_colour_npg = ggsci::scale_colour_npg,
scale_colour_observable = ggsci::scale_colour_observable,
scale_colour_rickandmorty = ggsci::scale_colour_rickandmorty,
scale_colour_simpsons = ggsci::scale_colour_simpsons,
scale_colour_startrek = ggsci::scale_colour_startrek,
scale_colour_tron = ggsci::scale_colour_tron, scale_colour_tw3 = ggsci::scale_colour_tw3,
scale_colour_uchicago = ggsci::scale_colour_uchicago,
scale_colour_ucscgb = ggsci::scale_colour_ucscgb, scale_fill_aaas = ggsci::scale_fill_aaas,
scale_fill_bmj = ggsci::scale_fill_bmj, scale_fill_bs5 = ggsci::scale_fill_bs5,
scale_fill_cosmic = ggsci::scale_fill_cosmic, scale_fill_d3 = ggsci::scale_fill_d3,
scale_fill_flatui = ggsci::scale_fill_flatui, scale_fill_frontiers = ggsci::scale_fill_frontiers,
scale_fill_futurama = ggsci::scale_fill_futurama, scale_fill_gsea = ggsci::scale_fill_gsea,
scale_fill_igv = ggsci::scale_fill_igv, scale_fill_jama = ggsci::scale_fill_jama,
scale_fill_jco = ggsci::scale_fill_jco, scale_fill_lancet = ggsci::scale_fill_lancet,
scale_fill_locuszoom = ggsci::scale_fill_locuszoom, scale_fill_material = ggsci::scale_fill_material,
scale_fill_nejm = ggsci::scale_fill_nejm, scale_fill_npg = ggsci::scale_fill_npg,
scale_fill_observable = ggsci::scale_fill_observable,
scale_fill_rickandmorty = ggsci::scale_fill_rickandmorty,
scale_fill_simpsons = ggsci::scale_fill_simpsons, scale_fill_startrek = ggsci::scale_fill_startrek,
scale_fill_tron = ggsci::scale_fill_tron, scale_fill_tw3 = ggsci::scale_fill_tw3,
scale_fill_uchicago = ggsci::scale_fill_uchicago, scale_fill_ucscgb = ggsci::scale_fill_ucscgb)
journal_palette_fn <- options_ls %>% purrr::pluck(paste0("scale_",
type_1L_chr, "_", what_1L_chr))
return(journal_palette_fn)
}
get_journal_plot_fn <- function (what_1L_chr = "barplot",
pkg_1L_chr = "ggpubr",
prefix_1L_chr = "gg") {
options_ls <- list(ggbarplot = ggpubr::ggbarplot,
ggballoonplot = ggpubr::ggballoonplot,
ggboxplot = ggpubr::ggboxplot,
ggdensity = ggpubr::ggdensity,
ggdonutchart = ggpubr::ggdonutchart,
ggdotchart = ggpubr::ggdotchart,
ggdotplot = ggpubr::ggdotplot,
ggecdf = ggpubr::ggecdf,
ggerrorplot = ggpubr::ggerrorplot,
gghistogram = ggpubr::gghistogram,
ggline = ggpubr::ggline,
# ggmaplot = ggpubr::ggmaplot,
ggpaired = ggpubr::ggpaired,
ggpie = ggpubr::ggpie,
ggqqplot = ggpubr::ggqqplot,
ggscatter = ggpubr::ggscatter,
ggscatterhist = ggpubr::ggscatterhist,
ggstripchart = ggpubr::ggstripchart,
ggviolin = ggpubr::ggviolin)
if(what_1L_chr == "names"){
journal_plot_xx <- names(options_ls) %>% stringr::str_sub(start = nchar(prefix_1L_chr)+1)
}else{
journal_plot_xx <- options_ls %>% purrr::pluck(paste0(prefix_1L_chr, what_1L_chr))
}
return(journal_plot_xx)
}
get_local_path_to_dv_data <- function(save_dir_path_1L_chr,
fl_nm_1L_chr,
save_fmt_1L_chr){
Expand Down Expand Up @@ -115,6 +213,21 @@ get_reference_descs <- function(correspondences_ls,
~ rbind(.x,.y)) %>% dplyr::pull(new_nms_chr) %>% unique()
return(reference_descs_chr)
}
get_styles <- function(what_1L_chr = c("all", "ggsci", "viridis"),
sort_1L_lgl = FALSE){
what_1L_chr <- match.arg(what_1L_chr)
styles_chr <- character(0)
if(what_1L_chr %in% c("all", "ggsci")){
styles_chr <- c(styles_chr, c("npg", "aaas", "lancet", "jco", "nejm", "ucscgb", "uchicago", "d3", "futurama", "igv", "locuszoom", "rickandmorty", "startrek", "simpsons", "tron"))
}
if(what_1L_chr %in% c("all", "viridis")){
styles_chr <- c(styles_chr, c("magma","A","inferno", "B", "plasma", "C", "viridis", "D", "cividis", "E", "rocket", "F", "mako", "G", "turbo", "H"))
}
if(sort_1L_lgl){
styles_chr <- sort(styles_chr)
}
return(styles_chr)
}
get_valid_path_chr <- function(x){
assert_file_exists(x)
valid_path_chr <- x
Expand Down
Loading

0 comments on commit 44ec805

Please sign in to comment.