added significance to depict

.Rbuildignore

@@ -84,3 +84,4 @@
 ^data-raw/app/functions\.R$
 ^data-raw/fns/bind\.R$
 ^data-raw/fns/plot\.R$
+^data-raw/fns/print\.R$

.github/workflows/pkgdown.yaml

@@ -4,7 +4,6 @@ on:
   push:
     branches: [main, master]
   pull_request:
-    branches: [main, master]
   release:
     types: [published]
   workflow_dispatch:

DESCRIPTION

@@ -20,14 +20,15 @@ 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
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Suggests: 
     knitr,
+    pkgload,
     rmarkdown,
     testthat
 VignetteBuilder: knitr

NAMESPACE

@@ -21,6 +21,7 @@ export(add_files_to_dv)
 export(add_from_lup_prototype)
 export(add_labels_from_dictionary)
 export(add_latest_match)
+export(add_significance)
 export(add_with_join)
 export(assert_dir_exists)
 export(assert_file_exists)
@@ -63,10 +64,12 @@ export(make_pt_ready4use_distributions)
 export(make_pt_ready4use_imports)
 export(make_pt_ready4use_mapes)
 export(make_r3_from_csv_tb)
+export(make_significance_df)
 export(make_temporal_lup)
 export(manufacture.ready4use_dataverses)
 export(manufacture.ready4use_imports)
 export(plot_for_journal)
+export(print_significance)
 export(procure.ready4use_dataverses)
 export(procure.ready4use_imports)
 export(read_import_from_csv)
@@ -117,6 +120,7 @@ import(methods)
 import(ready4)
 importFrom(Hmisc,capitalize)
 importFrom(Hmisc,label)
+importFrom(arsenal,tableby)
 importFrom(assertthat,are_equal)
 importFrom(assertthat,assert_that)
 importFrom(data.table,fread)
@@ -148,6 +152,7 @@ importFrom(fs,path_file)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,after_stat)
 importFrom(ggplot2,element_blank)
+importFrom(ggplot2,ggplot_build)
 importFrom(ggplot2,labs)
 importFrom(ggplot2,position_dodge)
 importFrom(ggplot2,scale_fill_manual)
@@ -225,6 +230,8 @@ importFrom(ggsci,scale_fill_tron)
 importFrom(ggsci,scale_fill_tw3)
 importFrom(ggsci,scale_fill_uchicago)
 importFrom(ggsci,scale_fill_ucscgb)
+importFrom(ggsignif,geom_signif)
+importFrom(gtools,stars.pval)
 importFrom(lifecycle,deprecate_soft)
 importFrom(lifecycle,deprecate_warn)
 importFrom(lifecycle,deprecated)
@@ -291,6 +298,7 @@ importFrom(rlang,current_env)
 importFrom(rlang,exec)
 importFrom(rlang,sym)
 importFrom(scales,label_percent)
+importFrom(stats,formula)
 importFrom(stats,setNames)
 importFrom(stringi,stri_replace_all_regex)
 importFrom(stringi,stri_replace_first_fixed)
@@ -299,6 +307,7 @@ importFrom(stringi,stri_replace_last_regex)
 importFrom(stringr,str_c)
 importFrom(stringr,str_detect)
 importFrom(stringr,str_remove)
+importFrom(stringr,str_remove_all)
 importFrom(stringr,str_replace_all)
 importFrom(stringr,str_split)
 importFrom(stringr,str_sub)

R/fn_add.R

@@ -340,6 +340,54 @@ add_latest_match <- function (data_tb, dynamic_lup, target_var_nm_1L_chr, date_v
                   match_value_xx = .x, target_var_nm_1L_chr = target_var_nm_1L_chr)))))
     return(data_tb)
 }
+#' Add significance
+#' @description add_significance() is an Add function that updates an object by adding new values to new or empty fields. Specifically, this function implements an algorithm to add significance. The function returns Plot (a plot).
+#' @param plot_plt Plot (a plot)
+#' @param by_1L_chr By (a character vector of length one)
+#' @param data_tb Data (a tibble)
+#' @param var_1L_chr Variable (a character vector of length one)
+#' @param add_1L_dbl Add (a double vector of length one), Default: numeric(0)
+#' @param adjust_1L_dbl Adjust (a double vector of length one), Default: 0.4
+#' @param digits_1L_int Digits (an integer vector of length one), Default: 4
+#' @param scientific_1L_lgl Scientific (a logical vector of length one), Default: F
+#' @param show_p_1L_lgl Show p (a logical vector of length one), Default: T
+#' @param show_test_1L_lgl Show test (a logical vector of length one), Default: F
+#' @param tip_1L_dbl Tip (a double vector of length one), Default: 0
+#' @param ... Additional arguments
+#' @return Plot (a plot)
+#' @rdname add_significance
+#' @export 
+#' @importFrom ggplot2 ggplot_build
+#' @importFrom stringr str_remove_all
+#' @importFrom purrr discard
+#' @importFrom ggsignif geom_signif
+#' @keywords internal
+add_significance <- function (plot_plt, by_1L_chr, data_tb, var_1L_chr, add_1L_dbl = numeric(0), 
+    adjust_1L_dbl = 0.4, digits_1L_int = 4, scientific_1L_lgl = F, 
+    show_p_1L_lgl = T, show_test_1L_lgl = F, tip_1L_dbl = 0, 
+    ...) 
+{
+    df <- make_significance_df(data_tb, by_1L_chr = by_1L_chr, 
+        vars_chr = var_1L_chr)
+    x_axis_chr <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$x$get_labels()
+    if (!identical(add_1L_dbl, numeric(0))) {
+        y_axis_max_1L_dbl <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$y$get_labels() %>% 
+            stringr::str_remove_all("%") %>% purrr::discard(is.na) %>% 
+            as.numeric() %>% max()
+        y_position <- y_axis_max_1L_dbl + add_1L_dbl
+    }
+    else {
+        y_position <- NULL
+    }
+    label_1L_chr <- paste0(ifelse(show_p_1L_lgl, paste0("p=", 
+        format(round(df$p.value, digits_1L_int), scientific = scientific_1L_lgl), 
+        " ")), df$stars, ifelse(show_test_1L_lgl, paste0(" ", 
+        df$test), ""))
+    plot_plt <- plot_plt + ggsignif::geom_signif(comparisons = list(x_axis_chr[c(1, 
+        length(x_axis_chr))]), annotations = label_1L_chr, tip_length = tip_1L_dbl, 
+        vjust = adjust_1L_dbl, y_position = y_position, ...)
+    return(plot_plt)
+}
 #' Add with join
 #' @description add_with_join() is an Add function that updates an object by adding new values to new or empty fields. Specifically, this function implements an algorithm to add with join. The function is called for its side effects and does not return a value.
 #' @param X_Ready4useDyad PARAM_DESCRIPTION

R/fn_make.R

@@ -224,6 +224,35 @@ make_r3_from_csv_tb <- function (csv_tb, r3_fn)
     tb_r3 <- rlang::exec(r3_fn, tb)
     return(tb_r3)
 }
+#' Make significance dataframe
+#' @description make_significance_df() is a Make function that creates a new R object. Specifically, this function implements an algorithm to make significance dataframe. The function returns Data (a data.frame).
+#' @param data_tb Data (a tibble)
+#' @param by_1L_chr By (a character vector of length one)
+#' @param vars_chr Variables (a character vector)
+#' @param sort_1L_lgl Sort (a logical vector of length one), Default: T
+#' @return Data (a data.frame)
+#' @rdname make_significance_df
+#' @export 
+#' @importFrom stats formula
+#' @importFrom rlang exec
+#' @importFrom arsenal tableby
+#' @importFrom dplyr arrange filter select mutate
+#' @importFrom gtools stars.pval
+#' @keywords internal
+make_significance_df <- function (data_tb, by_1L_chr, vars_chr, sort_1L_lgl = T) 
+{
+    args_ls <- list(formula = paste0(by_1L_chr, " ~ ", paste0(paste0(vars_chr, 
+        collapse = " + "))) %>% stats::formula(), data = data_tb)
+    data_xx <- rlang::exec(arsenal::tableby, !!!args_ls)
+    data_df <- data_xx %>% as.data.frame()
+    if (sort_1L_lgl) {
+        data_df <- data_df %>% dplyr::arrange(p.value)
+    }
+    data_df <- data_df %>% dplyr::filter(!term %in% c("countpct", 
+        "Nmiss")) %>% dplyr::select(variable, test, p.value) %>% 
+        dplyr::mutate(stars = gtools::stars.pval(p.value))
+    return(data_df)
+}
 #' Make temporal lookup table
 #' @description make_temporal_lup() is a Make function that creates a new R object. Specifically, this function implements an algorithm to make temporal lookup table. The function returns Temporal (a lookup table).
 #' @param dyad_ls Dyad (a list)

R/fn_plot.R

@@ -12,6 +12,8 @@
 #' @param line_1L_chr Line (a character vector of length one), Default: 'black'
 #' @param position_xx Position (an output object of multiple potential types), Default: NULL
 #' @param recode_lup_r3 Recode (a ready4 submodule extension of lookup table), Default: ready4show::ready4show_correspondences()
+#' @param significance_1L_lgl Significance (a logical vector of length one), Default: F
+#' @param significance_args_ls Significance arguments (a list), Default: list()
 #' @param style_1L_chr Style (a character vector of length one), Default: get_styles()
 #' @param title_1L_chr Title (a character vector of length one), Default: character(0)
 #' @param type_1L_chr Type (a character vector of length one), Default: c("ggsci", "manual", "viridis")
@@ -25,12 +27,12 @@
 #' @rdname plot_for_journal
 #' @export 
 #' @importFrom ready4show ready4show_correspondences manufacture.ready4show_correspondences
-#' @importFrom dplyr select pull mutate rename
+#' @importFrom dplyr select pull mutate rename group_by
 #' @importFrom tidyselect any_of
 #' @importFrom tidyr drop_na
 #' @importFrom rlang sym exec
 #' @importFrom purrr discard
-#' @importFrom ggplot2 position_dodge aes scale_y_continuous labs after_stat theme element_blank
+#' @importFrom ggplot2 position_dodge scale_y_continuous labs aes after_stat theme element_blank
 #' @importFrom tibble as_tibble
 #' @importFrom scales label_percent
 #' @importFrom ggpubr yscale gradient_fill
@@ -40,10 +42,11 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
     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", 
     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"), ...) 
+    significance_1L_lgl = F, significance_args_ls = list(), 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)
@@ -272,9 +275,9 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
             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)
+                identical(y_label_1L_chr, character(0)), ifelse(as_percent_1L_lgl, 
+                "", "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)))) {
@@ -332,6 +335,14 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
         new_by_1L_chr <- ifelse(what_1L_chr %in% c("donutchart", 
             "pie"), x_1L_chr, by_1L_chr)
     }
+    if (what_1L_chr %in% c("barplot") & !identical(by_1L_chr, 
+        x_1L_chr) & !identical(by_1L_chr, character(0)) & as_percent_1L_lgl) {
+        y_1L_chr <- ifelse(identical(y_1L_chr, character(0)), 
+            "Freq", y_1L_chr)
+        data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(by_1L_chr))
+        data_xx <- data_xx %>% dplyr::mutate(Percent = (!!rlang::sym(y_1L_chr)/sum(!!rlang::sym(y_1L_chr))))
+        args_ls$y <- "Percent"
+    }
     if (what_1L_chr %in% c("donutchart", "pie") & as_percent_1L_lgl) {
         data_xx <- data_xx %>% dplyr::mutate(new_label_chr = paste0(round(!!rlang::sym(new_by_1L_chr)/sum(!!rlang::sym(new_by_1L_chr)) * 
             100, 0), "%"))
@@ -346,9 +357,6 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
     }
     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", "histogram")) {
             plot_plt <- plot_plt + ggplot2::scale_y_continuous(labels = scales::label_percent()) + 
                 ggplot2::labs(y = y_label_1L_chr)
@@ -376,5 +384,10 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
         plot_plt <- plot_plt + ggplot2::theme(axis.text.x = ggplot2::element_blank(), 
             axis.ticks.x = ggplot2::element_blank())
     }
+    if (significance_1L_lgl & what_1L_chr %in% c("barplot")) {
+        significance_args_ls <- append(list(by_1L_chr = by_1L_chr, 
+            data_tb = data_tb, var_1L_chr = x_1L_chr), significance_args_ls)
+        plot_plt <- rlang::exec(add_significance, plot_plt, !!!significance_args_ls)
+    }
     return(plot_plt)
 }

R/fn_print.R

@@ -0,0 +1,28 @@
+#' Print significance
+#' @description print_significance() is a Print function that prints output to console. Specifically, this function implements an algorithm to print significance. The function returns Data (an output object of multiple potential types).
+#' @param data_tb Data (a tibble)
+#' @param by_1L_chr By (a character vector of length one)
+#' @param vars_chr Variables (a character vector)
+#' @param caption_1L_chr Caption (a character vector of length one), Default: character(0)
+#' @param output_type_1L_chr Output type (a character vector of length one), Default: 'HTML'
+#' @param sort_1L_lgl Sort (a logical vector of length one), Default: T
+#' @return Data (an output object of multiple potential types)
+#' @rdname print_significance
+#' @export 
+#' @importFrom dplyr rename
+#' @importFrom ready4show print_table
+#' @keywords internal
+print_significance <- function (data_tb, by_1L_chr, vars_chr, caption_1L_chr = character(0), 
+    output_type_1L_chr = "HTML", sort_1L_lgl = T) 
+{
+    if (identical(caption_1L_chr, character(0))) {
+        caption_1L_chr <- paste0("Differentiation by ", tolower(by_1L_chr))
+    }
+    data_df <- make_significance_df(data_tb, by_1L_chr = by_1L_chr, 
+        vars_chr = vars_chr)
+    data_df <- data_df %>% dplyr::rename(Variable = variable, 
+        p = p.value, ` ` = stars)
+    data_xx <- data_df %>% ready4show::print_table(output_type_1L_chr = output_type_1L_chr, 
+        caption = caption_1L_chr)
+    return(data_xx)
+}

R/mthd_depict.R

@@ -17,6 +17,8 @@
 #' @param line_1L_chr Line (a character vector of length one), Default: 'black'
 #' @param position_xx Position (an output object of multiple potential types), Default: NULL
 #' @param recode_lup_r3 Recode (a ready4 submodule extension of lookup table), Default: ready4show::ready4show_correspondences()
+#' @param significance_1L_lgl Significance (a logical vector of length one), Default: F
+#' @param significance_args_ls Significance arguments (a list), Default: list()
 #' @param style_1L_chr Style (a character vector of length one), Default: get_styles()
 #' @param titles_chr Titles (a character vector), Default: character(0)
 #' @param type_1L_chr Type (a character vector of length one), Default: c("ggsci", "manual", "viridis")
@@ -30,9 +32,9 @@
 #' @aliases depict,Ready4useDyad-method
 #' @export 
 #' @importFrom ready4show ready4show_correspondences
-#' @importFrom purrr map_chr map pluck
-#' @importFrom ready4 get_from_lup_obj depict
+#' @importFrom purrr map_int map_lgl map_chr map pluck
 #' @importFrom rlang exec
+#' @importFrom ready4 get_from_lup_obj depict
 #' @importFrom stats setNames
 #' @importFrom ggpubr ggarrange
 methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = character(0), y_vars_chr = character(0), 
@@ -41,8 +43,9 @@ methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = characte
     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), 
+    significance_1L_lgl = F, significance_args_ls = list(), 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"), 
     ...) 
 {
@@ -66,6 +69,29 @@ methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = characte
         custom_args_ls$title <- call_ls$title %>% as.character()
         custom_args_ls$titles_chr <- NULL
     }
+    lengths_int <- list(x_vars_chr, y_vars_chr, z_vars_chr) %>% 
+        purrr::map_int(~length(.x))
+    longest_1L_int <- lengths_int[which(lengths_int == max(lengths_int))][1]
+    if (lengths_int[1] == 1 & lengths_int[1] < longest_1L_int) {
+        x_vars_chr <- rep(x_vars_chr, longest_1L_int)
+    }
+    if (lengths_int[2] == 1 & lengths_int[2] < longest_1L_int) {
+        y_vars_chr <- rep(y_vars_chr, longest_1L_int)
+    }
+    if (lengths_int[3] == 1 & lengths_int[3] < longest_1L_int) {
+        z_vars_chr <- rep(z_vars_chr, longest_1L_int)
+    }
+    functions_lgl <- list(x_labels_chr, y_labels_chr, z_labels_chr) %>% 
+        purrr::map_lgl(~is.function(.x))
+    if (functions_lgl[1]) {
+        x_labels_chr <- rlang::exec(x_labels_chr, x_vars_chr)
+    }
+    if (functions_lgl[2]) {
+        y_labels_chr <- rlang::exec(y_labels_chr, y_vars_chr)
+    }
+    if (functions_lgl[3]) {
+        z_labels_chr <- rlang::exec(z_labels_chr, z_vars_chr)
+    }
     if (!identical(x_vars_chr, character(0))) {
         if (identical(x_labels_chr, character(0))) {
             if (what_1L_chr == "qqplot") {
@@ -218,6 +244,7 @@ methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = characte
             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, 
+            significance_1L_lgl = significance_1L_lgl, significance_args_ls = significance_args_ls, 
             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,