diff --git a/data-raw/fns/add.R b/data-raw/fns/add.R index 6d69323f..3eaf3c0c 100644 --- a/data-raw/fns/add.R +++ b/data-raw/fns/add.R @@ -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, @@ -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){ @@ -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, diff --git a/data-raw/fns/get.R b/data-raw/fns/get.R index 711fdd44..3d35dff5 100644 --- a/data-raw/fns/get.R +++ b/data-raw/fns/get.R @@ -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"){ @@ -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){ @@ -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 diff --git a/data-raw/fns/make.R b/data-raw/fns/make.R index 9c66de80..f608cb70 100644 --- a/data-raw/fns/make.R +++ b/data-raw/fns/make.R @@ -61,6 +61,271 @@ make_imputed_distinct_cases <- function(data_tb, dplyr::bind_rows(most_complete_tb) return(distinct_tb) } +make_journal_plot <- function(data_tb, + as_percent_1L_lgl = FALSE, + by_1L_chr = character(0), + colours_chr = c("#de2d26","#fc9272"), + drop_legend_1L_lgl = FALSE, + drop_missing_1L_lgl = FALSE, + drop_ticks_1L_lgl = FALSE, + fill_single_1L_lgl = FALSE, + label_fill_1L_chr = character(0), + line_1L_chr = "black", # used for: balloon, donut, histogram, line, pie + position_xx = NULL, + recode_lup_r3 = ready4show::ready4show_correspondences(), + style_1L_chr = get_styles(), + title_1L_chr = character(0), + type_1L_chr = c("ggsci", "manual", "viridis"), + x_1L_chr = character(0), + x_label_1L_chr = character(0), + y_1L_chr = character(0), + y_label_1L_chr = character(0), + what_1L_chr = get_journal_plot_fn("names"), + ... +){ + style_1L_chr <- match.arg(style_1L_chr) + type_1L_chr <- match.arg(type_1L_chr) + what_1L_chr <- match.arg(what_1L_chr) + if(what_1L_chr %in% c("donutchart", "pie") & !identical(by_1L_chr, character(0)) & drop_missing_1L_lgl){ + message("Ignoring drop_missing_1L_lgl argument value - this is only used when not directly supplying a frequency table") + drop_missing_1L_lgl <- FALSE + } + custom_args_ls <- args_ls <- list(...) + call_ls <- sys.call() + load_pkg_1L_lgl <- F + if("add" %in% names(custom_args_ls)){ + if(startsWith(custom_args_ls$add, "mean") & custom_args_ls$add!="mean"){ + load_pkg_1L_lgl <- !(paste("package", "ggpubr", sep = ":") %in% search()) + } + } + if(what_1L_chr %in% c("errorplot")){ + load_pkg_1L_lgl <- !(paste("package", "ggpubr", sep = ":") %in% search()) + } + if(load_pkg_1L_lgl){ + message("You need to load the package ggpubr for this function call to execute correctly.") + } + if("fill" %in% names(call_ls) ){ + if(!"fill_single_1L_lgl" %in% names(call_ls)){ + fill_single_1L_lgl <- FALSE + }else{ + fill_single_1L_lgl <- call_ls$fill_single_1L_lgl %>% as.character() %>% as.logical() + } + custom_args_ls$fill <- args_ls$fill <- call_ls$fill %>% as.character() + custom_args_ls$fill_single_1L_lgl <- args_ls$fill_single_1L_lgl <- NULL + } + if("title" %in% names(call_ls) ){ + if(!"title_1L_chr" %in% names(call_ls)){ + title_1L_chr <- character(0) + }else{ + title_1L_chr <- call_ls$title_1L_chr %>% as.character() + } + custom_args_ls$title <- args_ls$title <- call_ls$title %>% as.character() + custom_args_ls$title_1L_chr <- args_ls$title_1L_chr <- NULL + } + if("facet.by" %in% names(custom_args_ls)){ + extras_chr <- custom_args_ls$facet.by + }else{ + extras_chr <- character(0) + } + data_xx <- data_tb %>% dplyr::select(tidyselect::all_of(c(x_1L_chr, y_1L_chr, by_1L_chr, extras_chr))) + if(drop_missing_1L_lgl){ + data_xx <- tidyr::drop_na(data_xx, tidyselect::all_of(c(x_1L_chr, y_1L_chr, by_1L_chr, extras_chr))) + } + plot_fn <- get_journal_plot_fn(what_1L_chr) + colour_1L_int <- 1 + pick_1L_int <- integer(0) + if(!what_1L_chr %in% c("balloonplot")){ + if(what_1L_chr %in% c("barplot","density", "histogram", "donutchart", "pie", #"dotchart", + "ecdf", "errorplot", "line", "qqplot", "scatter", "scatterhist", "stripchart", "violin")){## + if((what_1L_chr %in% c("barplot","qqplot", "stripchart","violin","donutchart", "pie") & identical(by_1L_chr, character(0)))){ + var_1L_chr <- x_1L_chr + }else{ + var_1L_chr <- by_1L_chr + } + }else{ + var_1L_chr <- x_1L_chr + } + if(!identical(var_1L_chr, character(0))){ # + colour_1L_int <- pick_1L_int <- data_xx %>% dplyr::pull(!!rlang::sym(var_1L_chr)) %>% unique() %>% length() + } + } + if(what_1L_chr %in% c("balloonplot") & !fill_single_1L_lgl){ + colour_1L_int <- 3 + } + if(what_1L_chr %in% c("scatter") & identical(by_1L_chr, character(0))){ + colour_1L_int <- 2 + } + colour_codes_chr <- get_colour_codes(colour_1L_int = colour_1L_int, manual_chr = colours_chr, pick_1L_int = pick_1L_int, + single_1L_lgl = FALSE, style_1L_chr = style_1L_chr, type_1L_chr = type_1L_chr) + if(what_1L_chr %in% c("barplot", "boxplot", "dotplot", "paired" ) & identical(by_1L_chr, character(0))){ ##"donutchart", "pie" + by_1L_chr <- x_1L_chr + } + if(!("palette" %in% names(custom_args_ls)) & !fill_single_1L_lgl & !(type_1L_chr=="manual" & length(colours_chr) == 1)){ + args_ls <- append(args_ls, list(palette = colour_codes_chr)) + } + if(what_1L_chr %in% c("balloonplot") | fill_single_1L_lgl | (identical(by_1L_chr, character(0)) & !what_1L_chr %in% c("donutchart", "pie"))){ + fill_1L_chr <- ifelse(what_1L_chr %in% c("balloonplot") & !fill_single_1L_lgl, by_1L_chr, colour_codes_chr[1]) + }else{ + fill_1L_chr <- ifelse(what_1L_chr %in% c("donutchart", "pie") & identical(by_1L_chr, character(0)), x_1L_chr, by_1L_chr) + } + if(!fill_single_1L_lgl & !("fill" %in% names(custom_args_ls))){ + if(what_1L_chr %in% c("barplot", "boxplot")){ + line_1L_chr <- ifelse(!identical(by_1L_chr, character(0)), by_1L_chr, x_1L_chr) + } + if(what_1L_chr %in% c("density","histogram", "dotchart", "ecdf", "errorplot", "qqplot", "scatter", "stripchart", "violin", "baloonplot") & !identical(by_1L_chr, character(0))){ + line_1L_chr <- by_1L_chr + }else{ + if(what_1L_chr %in% c("dotchart")){ + line_1L_chr <- x_1L_chr + } + } + if(what_1L_chr %in% c("ecdf", "qqplot", "scatter", "scatterhist", "stripchart", "violin", "errorplot") & identical(by_1L_chr, character(0))){ + line_1L_chr <- ifelse(what_1L_chr %in% c("stripchart", "violin"), + ifelse((type_1L_chr=="manual" & length(colours_chr) == 1), colour_codes_chr[1], x_1L_chr), + colour_codes_chr[1]) + } + }else{ + if("fill" %in% names(custom_args_ls)){ + line_1L_chr <- custom_args_ls$fill + }else{ + line_1L_chr <- colour_codes_chr[1] + } + } + if(!"add.params" %in% names(custom_args_ls) & what_1L_chr %in% c("scatter") & identical(by_1L_chr, character(0))){ + if("add" %in% names(custom_args_ls)){ + if(custom_args_ls$add %in% c("loess", "reg.line")){ + args_ls <- list(add.params = list(color = colour_codes_chr[max(2,length(colour_codes_chr))], fill = "lightgray")) %>% append(args_ls) + } + } + } + if(!"bins" %in% names(custom_args_ls) & what_1L_chr %in% "histogram"){ + args_ls <- list(bins = min(data_xx %>% dplyr::pull(!!rlang::sym(x_1L_chr)) %>% purrr::discard(is.na) %>% unique() %>% length(),30)) %>% append(args_ls) + } + if(!"color" %in% names(custom_args_ls)){ + args_ls <- list(color = ifelse(what_1L_chr %in% c("dotchart", "line", "paired", "scatterhist") & !identical(by_1L_chr, character(0)), by_1L_chr, ifelse(what_1L_chr %in% c("line"), colour_codes_chr[1], line_1L_chr))) %>% append(args_ls) + } + if(!"fill" %in% names(custom_args_ls) & !what_1L_chr %in% c("boxplot", "errorplot", "paired", "qqplot", "scatterhist", "stripchart", "violin")){ + args_ls <- list(fill = fill_1L_chr) %>% append(args_ls) + } + if(!"group" %in% names(custom_args_ls) & what_1L_chr %in% c("dotchart") & !identical(by_1L_chr, character(0))){ + args_ls <- list(group = by_1L_chr) %>% append(args_ls) + } + if(!"line.color" %in% names(custom_args_ls) & what_1L_chr %in% c("paired")){ + args_ls <- list(line.color = line_1L_chr) %>% append(args_ls) + } + if(!"linetype" %in% names(custom_args_ls) & what_1L_chr %in% c("ecdf", "line") & !identical(by_1L_chr, character(0))){ + args_ls <- list(linetype = by_1L_chr) %>% append(args_ls) + } + if(!"margin.params" %in% names(custom_args_ls) & what_1L_chr %in% c("scatterhist")){ + if(!identical(by_1L_chr, character(0))){ + args_ls <- list(margin.params = list(fill = by_1L_chr, color = line_1L_chr)) %>% append(args_ls) + }else{ + args_ls <- list(margin.params = list(fill = line_1L_chr)) %>% append(args_ls) + } + } + if(!"position" %in% names(custom_args_ls)){ + if(what_1L_chr %in% c("barplot") & is.null(position_xx)){ + position_xx <- ggplot2::position_dodge() + } + if(!is.null(position_xx)){ + args_ls <- list(position = position_xx) %>% append(args_ls) + } + } + if(!"shape" %in% names(custom_args_ls) & what_1L_chr %in% c("line") & !identical(by_1L_chr, character(0))){ + args_ls <- list(shape = by_1L_chr) %>% append(args_ls) + } + if(!"title" %in% names(custom_args_ls) & !identical(title_1L_chr, character(0))){ + args_ls <- list(title = title_1L_chr) %>% append(args_ls) + } + if(!"xlab" %in% names(custom_args_ls) & (what_1L_chr %in% c("paired") | !identical(x_label_1L_chr, character(0)))){ + args_ls <- list(xlab = ifelse(what_1L_chr %in% c("paired") & identical(y_label_1L_chr, character(0)), x_1L_chr, + x_label_1L_chr)) %>% append(args_ls) + } + if(!"ylab" %in% names(custom_args_ls) & (what_1L_chr %in% c("barplot","paired","qqplot") | !identical(y_label_1L_chr, character(0)))){ + args_ls <- list(ylab = ifelse(what_1L_chr %in% c("qqplot") & identical(y_label_1L_chr, character(0)), x_1L_chr, + ifelse(what_1L_chr %in% c("paired") & identical(y_label_1L_chr, character(0)), y_1L_chr, + ifelse(what_1L_chr %in% c("barplot") & identical(y_1L_chr, character(0)) & identical(y_label_1L_chr, character(0)), "Count", + ifelse(identical(y_label_1L_chr, character(0)),"",y_label_1L_chr))))) %>% append(args_ls) + } + if((what_1L_chr %in% c("donutchart", "pie") & identical(by_1L_chr, character(0)))){ + args_ls <- append(args_ls, list(x = "Freq")) + }else{ + if(!identical(x_1L_chr, character(0)) & !"x" %in% names(custom_args_ls)){ + args_ls <- append(args_ls, list(x = x_1L_chr)) + } + } + if(!"y" %in% names(custom_args_ls) & (!identical(y_1L_chr, character(0)) | (what_1L_chr %in% c("barplot", "histogram") & identical(y_1L_chr, character(0))))){ + if(what_1L_chr %in% c("barplot") & identical(y_1L_chr, character(0))){ + args_ls <- append(args_ls, list(y = "Freq")) + }else{ + if(what_1L_chr %in% c("histogram") & identical(y_1L_chr, character(0))){ + args_ls <- append(args_ls, list(y = ifelse(as_percent_1L_lgl, "density","count"))) + }else{ + args_ls <- append(args_ls, list(y = y_1L_chr)) + } + } + } + if (!identical(recode_lup_r3, ready4show::ready4show_correspondences())) { + if(!is.numeric(data_xx %>% dplyr::pull(!!rlang::sym(x_1L_chr)))){ + data_xx <- data_xx %>% dplyr::mutate(`:=`(!!rlang::sym(x_1L_chr), + recode_lup_r3 %>% ready4show::manufacture.ready4show_correspondences(data_xx %>% dplyr::select(!!rlang::sym(x_1L_chr)), flatten_1L_lgl = TRUE))) + } + if(!identical(by_1L_chr, character(0))){ + if(!is.numeric(data_xx %>% dplyr::pull(!!rlang::sym(by_1L_chr)))){ + data_xx <- data_xx %>% dplyr::mutate(`:=`(!!rlang::sym(by_1L_chr), + recode_lup_r3 %>% ready4show::manufacture.ready4show_correspondences(data_xx %>% dplyr::select(!!rlang::sym(by_1L_chr)), flatten_1L_lgl = TRUE))) + } + } + } + if((what_1L_chr %in% c("donutchart", "pie") & identical(by_1L_chr, character(0))) | (what_1L_chr %in% c("barplot") & identical(y_1L_chr, character(0)))){ + data_xx <- table(data_xx %>% dplyr::select(tidyselect::all_of(c(x_1L_chr, by_1L_chr))), useNA = "ifany") %>% tibble::as_tibble() %>% dplyr::rename(Freq=n) + if(drop_missing_1L_lgl){ + data_xx <- tidyr::drop_na(data_xx, tidyselect::any_of(c(x_1L_chr, by_1L_chr, "Freq"))) + } + new_by_1L_chr <- "Freq" + }else{ + new_by_1L_chr <- ifelse(what_1L_chr %in% c("donutchart", "pie"), x_1L_chr, by_1L_chr) + } + if(what_1L_chr %in% c("donutchart", "pie") & as_percent_1L_lgl){ + data_xx <- data_xx %>% dplyr::mutate(!!rlang::sym(new_by_1L_chr) := round(!!rlang::sym(new_by_1L_chr) / sum(!!rlang::sym(new_by_1L_chr)) * 100,0)) + } + if(!"label" %in% names(custom_args_ls) & what_1L_chr %in% c("donutchart", "pie") & as_percent_1L_lgl){ + args_ls <- list(label = paste0(data_xx %>% dplyr::pull(!!rlang::sym(new_by_1L_chr)), "%")) %>% append(args_ls) + } + if(what_1L_chr %in% "balloonplot" & !fill_single_1L_lgl){ + palette_chr <- args_ls$palette + args_ls$palette <- NULL + } + plot_plt <- rlang::exec(plot_fn, data_xx, !!!args_ls) + if(as_percent_1L_lgl){ + if(what_1L_chr %in% c("barplot")){ + plot_plt <- plot_plt + + ggplot2::aes(y = !!rlang::sym(new_by_1L_chr)/sum(!!rlang::sym(new_by_1L_chr))) + } + if(!what_1L_chr %in% c("donutchart", "pie")){ + plot_plt <- plot_plt + + ggplot2::scale_y_continuous(labels = scales::label_percent()) + + ggplot2::labs(y = y_label_1L_chr) + } + } + if(what_1L_chr %in% "balloonplot" & !fill_single_1L_lgl){ + plot_plt <- plot_plt + ggpubr::gradient_fill(palette_chr) + } + if(!identical(label_fill_1L_chr, character(0))){ + plot_plt <- plot_plt + + ggplot2::labs(fill = label_fill_1L_chr, color = label_fill_1L_chr, shape = label_fill_1L_chr, linetype = label_fill_1L_chr) + } + if(drop_legend_1L_lgl | fill_single_1L_lgl & !what_1L_chr %in% c("balloonplot")) { + plot_plt <- plot_plt + ggplot2::theme(legend.position = "none") + } + if(drop_ticks_1L_lgl){ + plot_plt <- plot_plt + + ggplot2::theme(axis.text.x = ggplot2::element_blank(), + axis.ticks.x = ggplot2::element_blank()) + } + # args_ls -> plot_plt + return(plot_plt) +} make_keep_lgl <- function(ds_tb, filter_fn = is.na, summary_fn = any, diff --git a/data-raw/fns/transform.R b/data-raw/fns/transform.R index b76cd06b..5edc29e6 100644 --- a/data-raw/fns/transform.R +++ b/data-raw/fns/transform.R @@ -19,16 +19,16 @@ transform_dates <- function(dates_chr, dates_dtm <- dates_chr %>% lubridate::as_date() return(dates_dtm) } -transform_dyad_to_series <- function(X_Ready4useDyad = Ready4useDyad(), - timepoint_vals_chr = c("baseline","follow_up"), - id_var_nm_1L_chr = "uid_chr", - participation_var_1L_chr = "participation", - timepoint_var_nm_1L_chr = "timing_fct"){ - Z_YouthvarsSeries <- YouthvarsSeries(a_Ready4useDyad = X_Ready4useDyad, id_var_nm_1L_chr = id_var_nm_1L_chr, participation_var_1L_chr = participation_var_1L_chr, - timepoint_vals_chr = timepoint_vals_chr, timepoint_var_nm_1L_chr = timepoint_var_nm_1L_chr) - Z_YouthvarsSeries@a_Ready4useDyad@ds_tb <- Z_YouthvarsSeries@a_Ready4useDyad@ds_tb %>% dplyr::filter(!!rlang::sym(timepoint_var_nm_1L_chr) %in% Z_YouthvarsSeries@timepoint_vals_chr) - return(Z_YouthvarsSeries) -} +# transform_dyad_to_series <- function(X_Ready4useDyad = Ready4useDyad(), +# timepoint_vals_chr = c("baseline","follow_up"), +# id_var_nm_1L_chr = "uid_chr", +# participation_var_1L_chr = "participation", +# timepoint_var_nm_1L_chr = "timing_fct"){ +# Z_YouthvarsSeries <- YouthvarsSeries(a_Ready4useDyad = X_Ready4useDyad, id_var_nm_1L_chr = id_var_nm_1L_chr, participation_var_1L_chr = participation_var_1L_chr, +# timepoint_vals_chr = timepoint_vals_chr, timepoint_var_nm_1L_chr = timepoint_var_nm_1L_chr) +# Z_YouthvarsSeries@a_Ready4useDyad@ds_tb <- Z_YouthvarsSeries@a_Ready4useDyad@ds_tb %>% dplyr::filter(!!rlang::sym(timepoint_var_nm_1L_chr) %in% Z_YouthvarsSeries@timepoint_vals_chr) +# return(Z_YouthvarsSeries) +# } transform_raw_df <- function(data_df, cases_start_at_1L_int = 1L){ ds_tb <- data_df %>% dplyr::slice(cases_start_at_1L_int:nrow(.)) %>% tibble::as_tibble() diff --git a/data-raw/fns/update.R b/data-raw/fns/update.R index 3bbc163a..986efa8b 100644 --- a/data-raw/fns/update.R +++ b/data-raw/fns/update.R @@ -1,3 +1,43 @@ +update_character_vars <- function(ds_tb, + var_nms_chr, + as_missing_chr = character(0), + missing_1L_chr = NA_character_, + prefix_1L_chr = character(0), + remove_end_chr = character(0), + remove_start_chr = character(0), + replacement_fn_ls = list(end = stringi::stri_replace_last_fixed, + start = stringi::stri_replace_first_fixed), + x_ready4show_correspondences = ready4show::ready4show_correspondences()){ + if(!identical(prefix_1L_chr, character(0))){ + ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~.x, .names = paste0(prefix_1L_chr,"_{.col}"))) + var_nms_chr <- paste0(prefix_1L_chr, "_", var_nms_chr) + } + + if(!identical(as_missing_chr, character(0))){ + ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(.x %in% as_missing_chr, missing_1L_chr, .x))) + } + if(!identical(remove_end_chr, character(0))){ + ds_tb <- remove_end_chr %>% purrr::reduce(.init = ds_tb, + ~{ + pattern_1L_chr <- .y + .x %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(endsWith(.x, pattern_1L_chr), replacement_fn_ls$end(.x, pattern_1L_chr,""), .x))) + }) + } + if(!identical(remove_start_chr, character(0))){ + ds_tb <- remove_start_chr %>% purrr::reduce(.init = ds_tb, + ~{ + pattern_1L_chr <- .y + .x %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(startsWith(.x, pattern_1L_chr), replacement_fn_ls$start(.x, pattern_1L_chr,""), .x))) + }) + } + if(!identical(x_ready4show_correspondences, ready4show::ready4show_correspondences())){ + ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ .x %>% purrr::map_chr(~ifelse(.x %in% x_ready4show_correspondences$old_nms_chr, + ready4::get_from_lup_obj(x_ready4show_correspondences, match_var_nm_1L_chr = "old_nms_chr", + match_value_xx = .x, target_var_nm_1L_chr = "new_nms_chr"), + .x)))) + } + return(ds_tb) +} update_column_names <- function(X_Ready4useDyad, patterns_ls = list(c("[[:space:]]", "")), update_desc_1L_lgl = FALSE){ @@ -156,13 +196,7 @@ update_correspondences <- function(correspondences_ls, update_dyad_ls <- function(dyad_ls, add_lups_1L_lgl = F, arrange_1L_chr = c("var_ctg_chr, var_nm_chr"), - - #drop_chr = character(0), factors_chr = character(0), - #tfmn_fn = identity, - - # lup_var_ctg_1L_chr = "Lookup", - # lup_var_nm_1L_chr = "temporal_lup_ls", range_int = 1L:12L, recode_ls = NULL, reference_1L_int = 2L, @@ -170,7 +204,6 @@ update_dyad_ls <- function(dyad_ls, standard_spaces_1L_lgl = F, tfmn_cls_1L_chr = "character", tfmns_ls = list(bind = identity, class = as.character), - #tfmn_fn = as.character, type_1L_chr = c("sequence", "composite", "bind", "class", "default", "interval", "reference"), units_chr = c("minute","hour","week","month","year"), uid_var_nm_1L_chr = character(0)){# @@ -354,48 +387,8 @@ update_dyad_ls <- function(dyad_ls, } return(dyad_ls) } -update_character_vars <- function(ds_tb, - var_nms_chr, - as_missing_chr = character(0), - missing_1L_chr = NA_character_, - prefix_1L_chr = character(0), - remove_end_chr = character(0), - remove_start_chr = character(0), - replacement_fn_ls = list(end = stringi::stri_replace_last_fixed, - start = stringi::stri_replace_first_fixed), - x_ready4show_correspondences = ready4show::ready4show_correspondences()){ - if(!identical(prefix_1L_chr, character(0))){ - ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~.x, .names = paste0(prefix_1L_chr,"_{.col}"))) - var_nms_chr <- paste0(prefix_1L_chr, "_", var_nms_chr) - } - - if(!identical(as_missing_chr, character(0))){ - ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(.x %in% as_missing_chr, missing_1L_chr, .x))) - } - if(!identical(remove_end_chr, character(0))){ - ds_tb <- remove_end_chr %>% purrr::reduce(.init = ds_tb, - ~{ - pattern_1L_chr <- .y - .x %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(endsWith(.x, pattern_1L_chr), replacement_fn_ls$end(.x, pattern_1L_chr,""), .x))) - }) - } - if(!identical(remove_start_chr, character(0))){ - ds_tb <- remove_start_chr %>% purrr::reduce(.init = ds_tb, - ~{ - pattern_1L_chr <- .y - .x %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ ifelse(startsWith(.x, pattern_1L_chr), replacement_fn_ls$start(.x, pattern_1L_chr,""), .x))) - }) - } - if(!identical(x_ready4show_correspondences, ready4show::ready4show_correspondences())){ - ds_tb <- ds_tb %>% dplyr::mutate(dplyr::across(var_nms_chr, ~ .x %>% purrr::map_chr(~ifelse(.x %in% x_ready4show_correspondences$old_nms_chr, - ready4::get_from_lup_obj(x_ready4show_correspondences, match_var_nm_1L_chr = "old_nms_chr", - match_value_xx = .x, target_var_nm_1L_chr = "new_nms_chr"), - .x)))) - } - return(ds_tb) -} update_dyad <- function(X_Ready4useDyad, # Add to ready4use - arrange_1L_chr = c("var_ctg_chr, var_nm_chr"), + arrange_1L_chr = c("var_ctg_chr, var_nm_chr", "category", "name", "both"), categories_chr = character(0), dictionary_r3 = ready4use_dictionary(), fn = NULL, @@ -405,6 +398,9 @@ update_dyad <- function(X_Ready4useDyad, # Add to ready4use what_1L_chr = c("all","dataset","dictionary") ){ type_1L_chr <- match.arg(type_1L_chr) + type_1L_chr <- ifelse(type_1L_chr=="category","var_ctg_chr", + ifelse(type_1L_chr=="name","var_nm_chr", + ifelse(type_1L_chr=="both","var_ctg_chr, var_nm_chr",type_1L_chr))) what_1L_chr <- match.arg(what_1L_chr) if(what_1L_chr %in% c("all","dataset")){ if(type_1L_chr == "mutate"){ @@ -489,7 +485,9 @@ update_raw_data <- function(ds_tb, if(nrow(correspondences_r3)>0){ if(!identical(intersect(correspondences_r3$old_nms_chr, names(ds_tb)), character(0))){ ds_tb <- purrr::reduce(intersect(correspondences_r3$old_nms_chr, names(ds_tb)),.init = ds_tb, - ~ .x %>% dplyr::rename(!!rlang::sym(ready4::get_from_lup_obj(correspondences_r3, match_value_xx = .y, match_var_nm_1L_chr = "old_nms_chr", target_var_nm_1L_chr = "new_nms_chr")) := !!rlang::sym(.y))) + ~ .x %>% dplyr::rename(!!rlang::sym(ready4::get_from_lup_obj(correspondences_r3, match_value_xx = .y, + match_var_nm_1L_chr = "old_nms_chr", + target_var_nm_1L_chr = "new_nms_chr")) := !!rlang::sym(.y))) } } if(force_integers_1L_lgl){ @@ -533,9 +531,9 @@ update_raw_data <- function(ds_tb, return(ds_tb) } update_tb_src_loc_to_url_sngl_tb <- function(x, - y, - local_to_url_vec_chr, - urls_vec_chr){ + y, + local_to_url_vec_chr, + urls_vec_chr){ updated_tb <- x %>% dplyr::mutate(download_url_chr = purrr::map2_chr(local_file_src_chr, download_url_chr, ~ ifelse(.x %in% local_to_url_vec_chr, diff --git a/data-raw/s4_fns/depict.R b/data-raw/s4_fns/depict.R new file mode 100644 index 00000000..cba84520 --- /dev/null +++ b/data-raw/s4_fns/depict.R @@ -0,0 +1,235 @@ +depict_Ready4useDyad <- function(x, + x_vars_chr = character(0), + y_vars_chr = character(0), + z_vars_chr = character(0), + arrange_1L_lgl = FALSE, + arrange_args_ls = list(), + as_percent_1L_lgl = FALSE, + colours_chr = c("#de2d26","#fc9272"), + drop_legend_1L_lgl = FALSE, + drop_missing_1L_lgl = FALSE, + drop_ticks_1L_lgl = FALSE, + fill_single_1L_lgl = FALSE, + line_1L_chr = "black", + position_xx = NULL, + recode_lup_r3 = ready4show::ready4show_correspondences(), + style_1L_chr = get_styles(), + titles_chr = character(0), + type_1L_chr = c("ggsci", "manual", "viridis"), + x_labels_chr = character(0), + y_labels_chr = character(0), + z_labels_chr = character(0), + what_1L_chr = get_journal_plot_fn("names"), + ...){ + style_1L_chr <- match.arg(style_1L_chr) + type_1L_chr <- match.arg(type_1L_chr) + what_1L_chr <- match.arg(what_1L_chr) + custom_args_ls <- list(...) + call_ls <- sys.call() + if("fill" %in% names(call_ls) ){ + if(!"fill_single_1L_lgl" %in% names(call_ls)){ + fill_single_1L_lgl <- FALSE + }else{ + fill_single_1L_lgl <- call_ls$fill_single_1L_lgl %>% as.character() %>% as.logical() + } + custom_args_ls$fill <- call_ls$fill %>% as.character() + custom_args_ls$fill_single_1L_lgl <- NULL + } + if("title" %in% names(call_ls) ){ + if(!"titles_chr" %in% names(call_ls)){ + titles_chr <- character(0) + }else{ + titles_chr <- call_ls$titles_chr %>% as.character() + } + custom_args_ls$title <- call_ls$title %>% as.character() + custom_args_ls$titles_chr <- NULL + } + if(!identical(x_vars_chr, character(0))){ + if(identical(x_labels_chr, character(0))){ + if(what_1L_chr == "qqplot"){ + x_labels_chr <- rep("Theoretical",length(x_vars_chr)) + }else{ + x_labels_chr <- x_vars_chr + } + + }else{ + if(is.na(x_labels_chr[1])){ + x_labels_chr <- x_vars_chr %>% + purrr::map_chr(~ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = .x, + target_var_nm_1L_chr = "var_desc_chr")) + } + } + } + if(!identical(y_vars_chr, character(0)) | what_1L_chr %in% c("qqplot")){ + if(length(y_vars_chr)==1 & length(x_vars_chr)>1){ + y_vars_chr <- rep(y_vars_chr, length(x_vars_chr)) + } + if(identical(y_labels_chr, character(0))){ + y_labels_chr <- y_vars_chr + }else{ + if(is.na(y_labels_chr[1])){ + if(what_1L_chr %in% c("qqplot")){ + y_labels_chr <- x_vars_chr %>% + purrr::map_chr(~ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = .x, + target_var_nm_1L_chr = "var_desc_chr")) + }else{ + y_labels_chr <- y_vars_chr %>% + purrr::map_chr(~ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = .x, + target_var_nm_1L_chr = "var_desc_chr")) + } + + } + } + } + if(length(y_labels_chr)==1){ + y_labels_chr <- rep(y_labels_chr, length(x_vars_chr)) + } + if(what_1L_chr %in% c("donutchart","pie") & identical(z_vars_chr, character(0))){ + z_labels_chr <- x_labels_chr + }else{ + if(!identical(z_vars_chr, character(0))){ + if(length(z_vars_chr)==1 & length(x_vars_chr)>1){ + z_vars_chr <- rep(z_vars_chr, length(x_vars_chr)) + } + if(identical(z_labels_chr, character(0))){ + z_labels_chr <- z_vars_chr + } + } + if(is.na(z_labels_chr[1])){ + if(identical(z_vars_chr, character(0))){ + z_labels_chr <- x_vars_chr %>% + purrr::map_chr(~ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = .x, + target_var_nm_1L_chr = "var_desc_chr")) + }else{ + z_labels_chr <- z_vars_chr %>% + purrr::map_chr(~ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = .x, + target_var_nm_1L_chr = "var_desc_chr")) + } + + } + if(length(z_labels_chr)==1){ + z_labels_chr <- rep(z_labels_chr, length(x_vars_chr)) + } + } + + if(!identical(titles_chr, character(0))){ + if(is.na(titles_chr[1])){ + titles_chr <- 1:length(x_vars_chr) %>% + purrr::map_chr(~{ + text_1L_chr <- "" + if(!identical(y_vars_chr, character(0))){ + text_1L_chr <- paste0(ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = y_vars_chr[.x], + target_var_nm_1L_chr = "var_desc_chr"), + " by ") + } + text_1L_chr <- paste0(text_1L_chr, ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = x_vars_chr[.x], + target_var_nm_1L_chr = "var_desc_chr")) + if(!identical(z_vars_chr, character(0))){ + text_1L_chr <- paste0(paste0(text_1L_chr, ifelse(!identical(y_vars_chr, character(0)), " and ", " by ")), + ready4::get_from_lup_obj(x@dictionary_r3, + match_var_nm_1L_chr = "var_nm_chr", + match_value_xx = z_vars_chr[.x], + target_var_nm_1L_chr = "var_desc_chr")) + } + text_1L_chr + }) + } + if(length(titles_chr)==1){ + titles_chr <- rep(titles_chr, length(x_vars_chr)) + } + } + + plot_ls <- purrr::map(1:length(x_vars_chr), + ~ { + if(identical(x_vars_chr, character(0))){ + x_1L_chr <- character(0) + }else{ + x_1L_chr <- x_vars_chr[.x] + } + if(identical(x_labels_chr, character(0))){ + x_label_1L_chr <- character(0) + }else{ + x_label_1L_chr <- x_labels_chr[.x] + } + if(identical(y_vars_chr, character(0))){ + y_1L_chr <- character(0) + }else{ + y_1L_chr <- y_vars_chr[.x] + } + if(identical(y_labels_chr, character(0))){ + y_label_1L_chr <- character(0) + }else{ + y_label_1L_chr <- y_labels_chr[.x] + } + if(identical(z_vars_chr, character(0))){ + by_1L_chr <- character(0) + }else{ + by_1L_chr <- z_vars_chr[.x] + } + if(identical(z_labels_chr, character(0))){ + label_fill_1L_chr <- character(0) + }else{ + label_fill_1L_chr <- ifelse(what_1L_chr %in% "scatterhist", NA_character_, z_labels_chr[.x]) + if(is.na(label_fill_1L_chr)){ + label_fill_1L_chr <- character(0) + } + } + if(identical(titles_chr, character(0))){ + title_1L_chr <- character(0) + }else{ + title_1L_chr <- titles_chr[.x] + } + args_ls <- append(custom_args_ls, + list(as_percent_1L_lgl = as_percent_1L_lgl, + by_1L_chr = by_1L_chr, + colours_chr = colours_chr, + drop_legend_1L_lgl = drop_legend_1L_lgl, + drop_missing_1L_lgl = drop_missing_1L_lgl, + drop_ticks_1L_lgl = drop_ticks_1L_lgl, + fill_single_1L_lgl = fill_single_1L_lgl, + label_fill_1L_chr = label_fill_1L_chr, + line_1L_chr = line_1L_chr, + position_xx = position_xx, + style_1L_chr = style_1L_chr, + title_1L_chr = title_1L_chr, + type_1L_chr = type_1L_chr, + x_1L_chr = x_1L_chr, + x_label_1L_chr = x_label_1L_chr, + recode_lup_r3 = recode_lup_r3, + y_1L_chr = y_1L_chr, + y_label_1L_chr = y_label_1L_chr, + what_1L_chr = what_1L_chr)) + rlang::exec(make_journal_plot, x@ds_tb, !!!args_ls) + }) + if(length(x_vars_chr) == length(unique(x_vars_chr))){ + plot_ls <- plot_ls %>% stats::setNames(x_vars_chr) + } + if(arrange_1L_lgl){ + if("plotlist" %in% names(arrange_args_ls)){ + plot_ls <- append(arrange_args_ls$plotlist, plot_ls) + } + arrange_args_ls$plotlist <- plot_ls + plot_xx <- rlang::exec(ggpubr::ggarrange, !!!arrange_args_ls) + }else{ + if(length(x_vars_chr) == 1){ + plot_xx <- plot_ls %>% purrr::pluck(1) + }else{ + plot_xx <- plot_ls + } + } + return(plot_xx) +} diff --git a/data-raw/s4_fns/renew.R b/data-raw/s4_fns/renew.R index cf01a245..59662d4e 100644 --- a/data-raw/s4_fns/renew.R +++ b/data-raw/s4_fns/renew.R @@ -1,44 +1,105 @@ renew_Ready4useDyad <- function(x, + arrange_by_1L_chr = c("category", "name", "both"), + categories_chr = character(0), + drop_chr = character(0), + dictionary_r3 = ready4use_dictionary(), # new_cases_r3 = ready4use_dictionary(), + dummys_ls = NULL, + factors_chr = character(0), + fn = NULL, + fn_args_ls = NULL, + names_chr = character(0), new_val_xx = NULL, + + remove_old_lbls_1L_lgl = T, tfmn_1L_chr = "capitalise", - type_1L_chr = "label", + type_1L_chr = c("label", "base", "case", "drop", "dummys", "join", "keep", "levels", "mutate", "rbind", "unlabel"), + uid_var_nm_1L_chr = character(0), + var_ctg_chr = "Uncategorised", + what_1L_chr = c("all", "dataset", "dictionary"), ...){ - if(type_1L_chr %in% c("label","case")){ - dictionary_tb <- x@dictionary_r3 - if(tfmn_1L_chr == "capitalise") - dictionary_tb$var_desc_chr <- dictionary_tb$var_desc_chr %>% - Hmisc::capitalize() - if(tfmn_1L_chr == "title") - dictionary_tb$var_desc_chr <- dictionary_tb$var_desc_chr %>% - stringr::str_to_title() - } - if(type_1L_chr == "case"){ - x@dictionary_r3 <- dictionary_tb + type_1L_chr <- match.arg(type_1L_chr) + what_1L_chr <- match.arg(what_1L_chr) + if(type_1L_chr %in% c("label", "base", "case", "dummys", "levels", "unlabel")){ + if(type_1L_chr %in% c("label","case")){ + dictionary_tb <- x@dictionary_r3 + if(tfmn_1L_chr == "capitalise"){ + dictionary_tb$var_desc_chr <- dictionary_tb$var_desc_chr %>% + Hmisc::capitalize() + } + if(tfmn_1L_chr == "title"){ + dictionary_tb$var_desc_chr <- dictionary_tb$var_desc_chr %>% + stringr::str_to_title() + } + } + if(type_1L_chr == "case"){ + x@dictionary_r3 <- dictionary_tb + } + if(type_1L_chr == "label"){ + tfd_ds_tb <- add_labels_from_dictionary(x@ds_tb, + dictionary_tb = dictionary_tb %>% ready4::remove_lbls_from_df(), + remove_old_lbls_1L_lgl = remove_old_lbls_1L_lgl) + x@ds_tb <- tfd_ds_tb + } + if(type_1L_chr == "unlabel"){ + x@ds_tb <- remove_labels_from_ds(x@ds_tb) + } + if(type_1L_chr %in% c("base","dummys","levels")){ + if(is.null(dummys_ls)){ + dummys_ls <- new_val_xx + } + dummys_dict_r3 <- manufacture(x, dummys_ls = dummys_ls, flatten_1L_lgl = F, type_1L_chr = ifelse(type_1L_chr=="levels", "all", type_1L_chr), what_1L_chr = "factors-d") + x@dictionary_r3 <- renew.ready4use_dictionary(x@dictionary_r3, new_cases_r3 = dummys_dict_r3) + x@ds_tb <- purrr::reduce(dummys_dict_r3$var_ctg_chr %>% unique(), + .init = x@ds_tb, + ~{ + var_nm_1L_chr <- .y + val_1_1L_chr <- if("base" %in% ready4::get_from_lup_obj(dummys_dict_r3, match_value_xx = .y, match_var_nm_1L_chr = "var_ctg_chr", target_var_nm_1L_chr = "var_type_chr")){character(0)}else{levels(.x %>% dplyr::pull(!!rlang::sym(.y)))[1]} + .x %>% dplyr::mutate(!!rlang::sym(.y) := factor(!!rlang::sym(.y), labels = c(val_1_1L_chr, + ready4::get_from_lup_obj(dummys_dict_r3, match_value_xx = .y, match_var_nm_1L_chr = "var_ctg_chr", target_var_nm_1L_chr = "var_nm_chr") %>% + purrr::map_chr(~stringi::stri_replace_first_fixed(.x,var_nm_1L_chr,"")) + ))) + } ) + + } + }else{ + if(!is.null(dyad_ls)){ + dyad_ls <- list(x) %>% append(dyad_ls) + } } - if(type_1L_chr == "label"){ - tfd_ds_tb <- add_labels_from_dictionary(x@ds_tb, - dictionary_tb = dictionary_tb %>% ready4::remove_lbls_from_df(), - remove_old_lbls_1L_lgl = remove_old_lbls_1L_lgl) - x@ds_tb <- tfd_ds_tb + # add_dictionary, add_with_join, + if(type_1L_chr == "dictionary"){ + x <- add_dictionary(x, + new_cases_r3 = dictionary_r3, + var_ctg_chr = var_ctg_chr, + arrange_by_1L_chr = ifelse(arrange_by_1L_chr=="both","category",arrange_by_1L_chr)) } - if(type_1L_chr == "unlabel"){ - x@ds_tb <- remove_labels_from_ds(x@ds_tb) + if(type_1L_chr %in% c("drop", "keep", "mutate")){ # "rbind" + x <- update_dyad(x, + arrange_1L_chr = arrange_1L_chr, + categories_chr = categories_chr, + dictionary_r3 = dictionary_r3, + fn = fn, + fn_args_ls = fn_args_ls, + names_chr = names_chr, + type_1L_chr = type_1L_chr,#c("keep","drop", "mutate") + what_1L_chr = what_1L_chr) + } + if(type_1L_chr == "join"){ + x <- purrr::reduce(dyad_ls, + ~ add_with_join(.x,.y)) } - if(type_1L_chr %in% c("base","dummys","levels")){ - dummys_dict_r3 <- manufacture(x, dummys_ls = new_val_xx, flatten_1L_lgl = F, type_1L_chr = ifelse(type_1L_chr=="levels","all",type_1L_chr), what_1L_chr = "factors-d") - x@dictionary_r3 <- renew.ready4use_dictionary(x@dictionary_r3, new_cases_r3 = dummys_dict_r3) - x@ds_tb <- purrr::reduce(dummys_dict_r3$var_ctg_chr %>% unique(), - .init = x@ds_tb, - ~{ - var_nm_1L_chr <- .y - val_1_1L_chr <- if("base" %in% ready4::get_from_lup_obj(dummys_dict_r3, match_value_xx = .y, match_var_nm_1L_chr = "var_ctg_chr", target_var_nm_1L_chr = "var_type_chr")){character(0)}else{levels(.x %>% dplyr::pull(!!rlang::sym(.y)))[1]} - .x %>% dplyr::mutate(!!rlang::sym(.y) := factor(!!rlang::sym(.y), labels = c(val_1_1L_chr, - ready4::get_from_lup_obj(dummys_dict_r3, match_value_xx = .y, match_var_nm_1L_chr = "var_ctg_chr", target_var_nm_1L_chr = "var_nm_chr") %>% - purrr::map_chr(~stringi::stri_replace_first_fixed(.x,var_nm_1L_chr,"")) - ))) - } ) - + if(type_1L_chr == "rbind"){ + if(is.null(fn)){ + tfmn_fn <- identity + }else{ + tfmn_fn <- fn + } + x <- bind_dyads(dyad_ls, + drop_chr = drop_chr, + factors_chr = factors_chr, + tfmn_fn = tfmn_fn, + uid_var_nm_1L_chr = uid_var_nm_1L_chr) } return(x) }