From 2720db2e7bfba1fea46045712925873544e1d7b0 Mon Sep 17 00:00:00 2001 From: Matthew P Hamilton <30450935+matthewphamilton@users.noreply.github.com> Date: Fri, 1 Nov 2024 13:40:41 +1100 Subject: [PATCH] further fix for histogram --- .github/workflows/pkgdown.yaml | 10 ++ DESCRIPTION | 3 +- R/fn_add.R | 179 ++++++++++++++++----------------- R/fn_plot.R | 5 +- data-raw/fns/plot.R | 2 +- vignettes/V_04.Rmd | 6 +- 6 files changed, 108 insertions(+), 97 deletions(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 6a9d2f7d..a76687f0 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -30,6 +30,8 @@ jobs: - uses: r-lib/actions/setup-tinytex@v2 + - uses: r-lib/actions/setup-tinytex@v2 + - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 @@ -44,6 +46,14 @@ jobs: sudo add-apt-repository ppa:cran/librdf sudo apt update + # Addresses issue with incompatibility between libcurl4-gnutls-dev and libcurl4-openssl-dev + # Below fix is a customisation of approach outlined in https://github.com/r-hub/sysreqsdb/issues/77#issuecomment-620025428 + - name: Install libraptor on Linux + if: runner.os == 'Linux' + run: | + sudo add-apt-repository ppa:cran/librdf + sudo apt update + # Addresses issue with incompatibility between libcurl4-gnutls-dev and libcurl4-openssl-dev # Below fix is a customisation of approach outlined in https://github.com/r-hub/sysreqsdb/issues/77#issuecomment-620025428 - name: Install libraptor on Linux diff --git a/DESCRIPTION b/DESCRIPTION index f0dde890..d288796c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,7 +20,7 @@ Description: ready4use provides a set of tools for managing data for of the ready4use package has been made available as part of the process of testing and documenting the package. If you have any questions, please contact the authors (matthew.hamilton1@monash.edu). -License: GPL-3 + file LICENSE +License: GPL-3 URL: https://ready4-dev.github.io/ready4use/, https://github.com/ready4-dev/ready4use, https://www.ready4-dev.com/ Encoding: UTF-8 @@ -28,6 +28,7 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 Suggests: knitr, + pkgload, rmarkdown, testthat VignetteBuilder: knitr diff --git a/R/fn_add.R b/R/fn_add.R index 61850cf1..131eaf8b 100644 --- a/R/fn_add.R +++ b/R/fn_add.R @@ -6,30 +6,30 @@ #' @param arrange_by_1L_chr Arrange by (a character vector of length one), Default: c("category", "name") #' @return X (A dataset and data dictionary pair.) #' @rdname add_dictionary -#' @export +#' @export #' @importFrom purrr map_chr #' @importFrom dplyr pull arrange filter #' @importFrom rlang sym -add_dictionary <- function (X_Ready4useDyad = Ready4useDyad(), new_cases_r3 = ready4use_dictionary(), - var_ctg_chr = "Uncategorised", arrange_by_1L_chr = c("category", - "name")) +add_dictionary <- function (X_Ready4useDyad = Ready4useDyad(), new_cases_r3 = ready4use_dictionary(), + var_ctg_chr = "Uncategorised", arrange_by_1L_chr = c("category", + "name")) { arrange_by_1L_chr <- match.arg(arrange_by_1L_chr) if (identical(new_cases_r3, ready4use_dictionary())) { - X_Ready4useDyad <- renewSlot(X_Ready4useDyad, "dictionary_r3", - var_nm_chr = names(X_Ready4useDyad@ds_tb), var_ctg_chr = var_ctg_chr, - var_desc_chr = names(X_Ready4useDyad@ds_tb), var_type_chr = names(X_Ready4useDyad@ds_tb) %>% - purrr::map_chr(~class(X_Ready4useDyad@ds_tb %>% + X_Ready4useDyad <- renewSlot(X_Ready4useDyad, "dictionary_r3", + var_nm_chr = names(X_Ready4useDyad@ds_tb), var_ctg_chr = var_ctg_chr, + var_desc_chr = names(X_Ready4useDyad@ds_tb), var_type_chr = names(X_Ready4useDyad@ds_tb) %>% + purrr::map_chr(~class(X_Ready4useDyad@ds_tb %>% dplyr::pull(.x))[1])) } else { - X_Ready4useDyad <- renewSlot(X_Ready4useDyad, "dictionary_r3", + X_Ready4useDyad <- renewSlot(X_Ready4useDyad, "dictionary_r3", new_cases_r3 = new_cases_r3) } - X_Ready4useDyad@dictionary_r3 <- X_Ready4useDyad@dictionary_r3 %>% - dplyr::arrange(!!rlang::sym(ifelse(arrange_by_1L_chr == + X_Ready4useDyad@dictionary_r3 <- X_Ready4useDyad@dictionary_r3 %>% + dplyr::arrange(!!rlang::sym(ifelse(arrange_by_1L_chr == "name", "var_nm_chr", "var_ctg_chr"))) - X_Ready4useDyad@dictionary_r3 <- X_Ready4useDyad@dictionary_r3 %>% + X_Ready4useDyad@dictionary_r3 <- X_Ready4useDyad@dictionary_r3 %>% dplyr::filter(var_nm_chr %in% names(X_Ready4useDyad@ds_tb)) return(X_Ready4useDyad) } @@ -42,26 +42,26 @@ add_dictionary <- function (X_Ready4useDyad = Ready4useDyad(), new_cases_r3 = re #' @param what_1L_chr What (a character vector of length one), Default: 'lancet' #' @return Plot (a plot) #' @rdname add_discrete_palette -#' @export +#' @export #' @importFrom ggplot2 scale_fill_manual #' @importFrom viridis scale_color_viridis scale_fill_viridis #' @keywords internal -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") +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 == "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) + + plot_plt <- plot_plt + one_fn(na.value = missing_1L_chr) + two_fn(na.value = missing_1L_chr) } if (type_1L_chr == "manual") { plot_plt <- plot_plt + ggplot2::scale_fill_manual(values = colours_chr) } 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, + plot_plt <- plot_plt + viridis::scale_color_viridis(discrete = TRUE, + option = what_1L_chr) + viridis::scale_fill_viridis(discrete = TRUE, option = what_1L_chr) } return(plot_plt) @@ -74,13 +74,13 @@ add_discrete_palette <- function (plot_plt, colours_chr = c("#de2d26", "#fc9272" #' @param server_1L_chr Server (a character vector of length one), Default: Sys.getenv("DATAVERSE_SERVER") #' @return Dataset url (a character vector of length one) #' @rdname add_ds_to_dv_repo -#' @export +#' @export #' @importFrom dataverse get_dataverse dataverse_contents get_dataset update_dataset #' @importFrom purrr map_chr pluck discard map_lgl #' @importFrom utils getFromNamespace #' @keywords internal -add_ds_to_dv_repo <- function (dv_1L_chr, ds_meta_ls, key_1L_chr = Sys.getenv("DATAVERSE_KEY"), - server_1L_chr = Sys.getenv("DATAVERSE_SERVER")) +add_ds_to_dv_repo <- function (dv_1L_chr, ds_meta_ls, key_1L_chr = Sys.getenv("DATAVERSE_KEY"), + server_1L_chr = Sys.getenv("DATAVERSE_SERVER")) { dv <- dataverse::get_dataverse(dv_1L_chr) dv_ls <- dataverse::dataverse_contents(dv) @@ -98,39 +98,39 @@ add_ds_to_dv_repo <- function (dv_1L_chr, ds_meta_ls, key_1L_chr = Sys.getenv("D add_ds_lgl <- !(ds_meta_ls$title %in% db_nm_chr_vec) } if (add_ds_lgl) { - add_sword_ds <- utils::getFromNamespace("initiate_sword_dataset", + add_sword_ds <- utils::getFromNamespace("initiate_sword_dataset", "dataverse") - add_sword_ds(dv_1L_chr, body = ds_meta_ls, key = key_1L_chr, + add_sword_ds(dv_1L_chr, body = ds_meta_ls, key = key_1L_chr, server = server_1L_chr) dv_ls <- dataverse::dataverse_contents(dv) } else { - ds_ls <- dataverse::get_dataset(per_chr_vec[ds_meta_ls$title == + ds_ls <- dataverse::get_dataset(per_chr_vec[ds_meta_ls$title == db_nm_chr_vec]) update_ds_lgl <- purrr::map_lgl(names(ds_meta_ls), ~{ type_name_chr <- { - tmp_chr <- switch(.x, creator = "author", description = "dsDescription", + tmp_chr <- switch(.x, creator = "author", description = "dsDescription", subject = "keyword") - ifelse(is.null(tmp_chr), ifelse(.x %in% ds_ls$metadataBlocks$citation$fields$typeName, + ifelse(is.null(tmp_chr), ifelse(.x %in% ds_ls$metadataBlocks$citation$fields$typeName, .x, NA_character_), tmp_chr) } new_val_chr <- ds_meta_ls %>% purrr::pluck(.x) idx_dbl <- which(type_name_chr == ds_ls$metadataBlocks$citation$fields$typeName) - purrr::map_lgl(1:length(ds_ls$metadataBlocks$citation$fields$value[idx_dbl]), + purrr::map_lgl(1:length(ds_ls$metadataBlocks$citation$fields$value[idx_dbl]), ~{ - if (class(ds_ls$metadataBlocks$citation$fields$value[idx_dbl][[.x]]) == + if (class(ds_ls$metadataBlocks$citation$fields$value[idx_dbl][[.x]]) == "character") { (new_val_chr != ds_ls$metadataBlocks$citation$fields$value[idx_dbl]) } else { - if (class(ds_ls$metadataBlocks$citation$fields$value[idx_dbl][[.x]]) == - "data.frame") + if (class(ds_ls$metadataBlocks$citation$fields$value[idx_dbl][[.x]]) == + "data.frame") (new_val_chr != ds_ls$metadataBlocks$citation$fields$value[idx_dbl][[.x]][[1]]$value) } }) %>% any() }) %>% any() - if (update_ds_lgl & F) - dataverse::update_dataset(dataset = ds_ls, body = ds_meta_ls, + if (update_ds_lgl & F) + dataverse::update_dataset(dataset = ds_ls, body = ds_meta_ls, key = key_1L_chr, server = server_1L_chr) dv_ls <- dataverse::dataverse_contents(dv) } @@ -145,13 +145,13 @@ add_ds_to_dv_repo <- function (dv_1L_chr, ds_meta_ls, key_1L_chr = Sys.getenv("D #' @param save_type_1L_chr Save type (a character vector of length one) #' @return Import (a lookup table) #' @rdname add_dv_meta_to_imp_lup -#' @export +#' @export #' @importFrom dplyr mutate #' @keywords internal -add_dv_meta_to_imp_lup <- function (imp_lup, ds_ui_1L_chr, file_type_1L_chr, save_type_1L_chr) +add_dv_meta_to_imp_lup <- function (imp_lup, ds_ui_1L_chr, file_type_1L_chr, save_type_1L_chr) { assert_single_row_tb(imp_lup) - imp_lup <- imp_lup %>% dplyr::mutate(data_repo_db_ui_chr = ds_ui_1L_chr, + imp_lup <- imp_lup %>% dplyr::mutate(data_repo_db_ui_chr = ds_ui_1L_chr, data_repo_file_ext_chr = file_type_1L_chr, data_repo_save_type_chr = save_type_1L_chr) return(imp_lup) } @@ -164,19 +164,19 @@ add_dv_meta_to_imp_lup <- function (imp_lup, ds_ui_1L_chr, file_type_1L_chr, sav #' @param vars_chr Variables (a character vector) #' @return Dataset (a tibble) #' @rdname add_fields_from_lup -#' @export +#' @export #' @importFrom purrr reduce map_chr #' @importFrom dplyr mutate #' @importFrom rlang sym #' @importFrom ready4 get_from_lup_obj #' @keywords internal -add_fields_from_lup <- function (ds_tb, lup_tb, match_chr, target_1L_chr, vars_chr) +add_fields_from_lup <- function (ds_tb, lup_tb, match_chr, target_1L_chr, vars_chr) { ds_tb <- purrr::reduce(vars_chr, .init = ds_tb, ~{ target_1L_chr <- .y - .x %>% dplyr::mutate(`:=`(!!rlang::sym(target_1L_chr), - !!rlang::sym(match_chr[1]) %>% purrr::map_chr(~ready4::get_from_lup_obj(lup_tb, - match_var_nm_1L_chr = match_chr[2], match_value_xx = .x, + .x %>% dplyr::mutate(`:=`(!!rlang::sym(target_1L_chr), + !!rlang::sym(match_chr[1]) %>% purrr::map_chr(~ready4::get_from_lup_obj(lup_tb, + match_var_nm_1L_chr = match_chr[2], match_value_xx = .x, target_var_nm_1L_chr = target_1L_chr) %>% as.character))) }) return(ds_tb) @@ -190,27 +190,27 @@ add_fields_from_lup <- function (ds_tb, lup_tb, match_chr, target_1L_chr, vars_c #' @param server_1L_chr Server (a character vector of length one), Default: Sys.getenv("DATAVERSE_SERVER") #' @return File identities (an integer vector) #' @rdname add_files_to_dv -#' @export +#' @export #' @importFrom lifecycle deprecate_soft #' @importFrom dataverse get_dataset #' @importFrom purrr pmap_int #' @importFrom ready4 write_fls_to_dv #' @keywords internal -add_files_to_dv <- function (files_tb, data_dir_rt_1L_chr = ".", ds_url_1L_chr, - key_1L_chr = Sys.getenv("DATAVERSE_KEY"), server_1L_chr = Sys.getenv("DATAVERSE_SERVER")) +add_files_to_dv <- function (files_tb, data_dir_rt_1L_chr = ".", ds_url_1L_chr, + key_1L_chr = Sys.getenv("DATAVERSE_KEY"), server_1L_chr = Sys.getenv("DATAVERSE_SERVER")) { - lifecycle::deprecate_soft("0.0.0.9149", "add_files_to_dv()", + lifecycle::deprecate_soft("0.0.0.9149", "add_files_to_dv()", "ready4::write_to_dv_from_tbl()") ds_ls <- dataverse::get_dataset(ds_url_1L_chr) is_draft_1L_lgl <- ds_ls$versionState == "DRAFT" nms_chr <- ds_ls$files$filename fl_ids_int <- purrr::pmap_int(files_tb, ~{ - path_1L_chr <- paste0(ifelse(identical(character(0), - data_dir_rt_1L_chr), "", paste0(data_dir_rt_1L_chr, + path_1L_chr <- paste0(ifelse(identical(character(0), + data_dir_rt_1L_chr), "", paste0(data_dir_rt_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, + 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) }) return(fl_ids_int) @@ -227,48 +227,48 @@ add_files_to_dv <- function (files_tb, data_dir_rt_1L_chr = ".", ds_url_1L_chr, #' @param vars_chr Variables (a character vector), Default: character(0) #' @return Data (a tibble) #' @rdname add_from_lup_prototype -#' @export +#' @export #' @importFrom purrr reduce #' @importFrom dplyr left_join select distinct filter bind_rows arrange #' @importFrom tidyselect all_of #' @importFrom rlang sym -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)) +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, + 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, + 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, + 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, + 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, + 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))) + if (!identical(arrange_1L_chr, character(0))) data_tb <- data_tb %>% dplyr::arrange(!!rlang::sym(arrange_1L_chr)) return(data_tb) } @@ -279,20 +279,20 @@ add_from_lup_prototype <- function (data_tb, arrange_1L_chr = character(0), excl #' @param remove_old_lbls_1L_lgl Remove old labels (a logical vector of length one), Default: F #' @return Labelled dataset (a tibble) #' @rdname add_labels_from_dictionary -#' @export +#' @export #' @importFrom ready4 remove_lbls_from_df #' @importFrom dplyr filter mutate case_when #' @importFrom purrr reduce #' @importFrom Hmisc label -add_labels_from_dictionary <- function (ds_tb, dictionary_tb, remove_old_lbls_1L_lgl = F) +add_labels_from_dictionary <- function (ds_tb, dictionary_tb, remove_old_lbls_1L_lgl = F) { - if (remove_old_lbls_1L_lgl) + if (remove_old_lbls_1L_lgl) ds_tb <- ds_tb %>% ready4::remove_lbls_from_df() - data_dictionary_tb <- dictionary_tb %>% dplyr::filter(var_nm_chr %in% - names(ds_tb)) %>% dplyr::mutate(var_desc_chr = dplyr::case_when(is.na(var_desc_chr) ~ + data_dictionary_tb <- dictionary_tb %>% dplyr::filter(var_nm_chr %in% + names(ds_tb)) %>% dplyr::mutate(var_desc_chr = dplyr::case_when(is.na(var_desc_chr) ~ var_nm_chr, TRUE ~ var_desc_chr)) %>% ready4::remove_lbls_from_df() if (nrow(data_dictionary_tb) > 0) { - labelled_ds_tb <- seq_len(nrow(data_dictionary_tb)) %>% + labelled_ds_tb <- seq_len(nrow(data_dictionary_tb)) %>% purrr::reduce(.init = ds_tb, ~{ Hmisc::label(.x[[data_dictionary_tb$var_nm_chr[.y]]]) <- data_dictionary_tb$var_desc_chr[.y] .x @@ -314,28 +314,28 @@ add_labels_from_dictionary <- function (ds_tb, dictionary_tb, remove_old_lbls_1L #' @param type_1L_chr Type (a character vector of length one), Default: c("chr", "dbl", "int", "lgl") #' @return Data (a tibble) #' @rdname add_latest_match -#' @export +#' @export #' @importFrom purrr map2_chr map2_dbl map2_int map2_lgl #' @importFrom dplyr mutate pull filter #' @importFrom rlang sym #' @importFrom ready4 get_from_lup_obj -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")) +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, + 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, + 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) } @@ -345,14 +345,13 @@ add_latest_match <- function (data_tb, dynamic_lup, target_var_nm_1L_chr, date_v #' @param Y_Ready4useDyad PARAM_DESCRIPTION #' @return X (A dataset and data dictionary pair.) #' @rdname add_with_join -#' @export +#' @export #' @importFrom dplyr left_join filter -add_with_join <- function (X_Ready4useDyad, Y_Ready4useDyad) +add_with_join <- function (X_Ready4useDyad, Y_Ready4useDyad) { - X_Ready4useDyad@ds_tb <- dplyr::left_join(X_Ready4useDyad@ds_tb, + X_Ready4useDyad@ds_tb <- dplyr::left_join(X_Ready4useDyad@ds_tb, Y_Ready4useDyad@ds_tb) - X_Ready4useDyad <- add_dictionary(X_Ready4useDyad, - new_cases_r3 = Y_Ready4useDyad@dictionary_r3 %>% dplyr::filter(!var_nm_chr %in% - X_Ready4useDyad@dictionary_r3$var_nm_chr)) + X_Ready4useDyad <- add_dictionary(X_Ready4useDyad, new_cases_r3 = Y_Ready4useDyad@dictionary_r3 %>% + dplyr::filter(!var_nm_chr %in% X_Ready4useDyad@dictionary_r3$var_nm_chr)) return(X_Ready4useDyad) } diff --git a/R/fn_plot.R b/R/fn_plot.R index 1abe6ece..8724f304 100644 --- a/R/fn_plot.R +++ b/R/fn_plot.R @@ -357,8 +357,9 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch } if (what_1L_chr %in% "histogram" & ifelse(identical(y_1L_chr, character(0)), T, !y_1L_chr %in% c("density", "..density.."))) { - plot_plt <- plot_plt + ggplot2::aes(y = ggplot2::after_stat(count)/sum(after_stat(count))) + - ggpubr::yscale("percent", .format = TRUE) + ggplot2::labs(y = y_label_1L_chr) + plot_plt <- plot_plt + ggplot2::aes(y = ggplot2::after_stat(width) * + (ggplot2::after_stat(density))) + ggpubr::yscale("percent", + .format = TRUE) + ggplot2::labs(y = y_label_1L_chr) } } if (what_1L_chr %in% "balloonplot" & !fill_single_1L_lgl) { diff --git a/data-raw/fns/plot.R b/data-raw/fns/plot.R index 271b8db4..54aaa201 100644 --- a/data-raw/fns/plot.R +++ b/data-raw/fns/plot.R @@ -246,7 +246,7 @@ plot_for_journal <- function(data_tb, ggplot2::labs(y = y_label_1L_chr) } if(what_1L_chr %in% "histogram" & ifelse(identical(y_1L_chr, character(0)),T,!y_1L_chr %in% c("density", "..density.."))){ - plot_plt <- plot_plt + ggplot2::aes(y = ggplot2::after_stat(count)/sum(after_stat(count))) + + plot_plt <- plot_plt + ggplot2::aes(y = ggplot2::after_stat(width)*(ggplot2::after_stat(density))) + ggpubr::yscale("percent", .format = TRUE) + ggplot2::labs(y = y_label_1L_chr) } diff --git a/vignettes/V_04.Rmd b/vignettes/V_04.Rmd index d511321f..7a03157f 100644 --- a/vignettes/V_04.Rmd +++ b/vignettes/V_04.Rmd @@ -363,8 +363,8 @@ depict(X1, x_vars_chr = "k6_total", x_labels_chr = "K6", y_labels_chr = "", as_p ```{r fig.width=8, fig.height=4} depict(X1, x_vars_chr = "k6_total", x_labels_chr = NA_character_, z_vars_chr = "d_sex_birth_s", - z_labels_chr = NA_character_, as_percent_1L_lgl = T, drop_missing_1L_lgl = T, - what_1L_chr = "histogram") + z_labels_chr = NA_character_, as_percent_1L_lgl = T, drop_missing_1L_lgl = T, position_xx = "dodge", + what_1L_chr = "histogram", bins=10) ``` @@ -372,7 +372,7 @@ depict(X1, x_vars_chr = "k6_total", x_labels_chr = NA_character_, z_vars_chr = " ```{r fig.width=8, fig.height=4} depict(X1, x_vars_chr = "k6_total", x_labels_chr = "K6", y_labels_chr = "", - z_vars_chr = "d_sex_birth_s", z_labels_chr = "Sex", as_percent_1L_lgl = T, + z_vars_chr = "d_sex_birth_s", z_labels_chr = "Sex", as_percent_1L_lgl = F, drop_missing_1L_lgl = T, what_1L_chr = "histogram", add = "mean", add_density = TRUE) ```