import from syn sport

ready4-dev · Nov 11, 2024 · a3779a7 · a3779a7
1 parent acb938e
commit a3779a7
Show file tree

Hide file tree

Showing 11 changed files with 114 additions and 32 deletions.
diff --git a/DESCRIPTION b/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

diff --git a/NAMESPACE b/NAMESPACE
@@ -151,7 +151,9 @@ importFrom(english,words)
 importFrom(fs,path_file)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,after_stat)
+importFrom(ggplot2,annotate)
 importFrom(ggplot2,element_blank)
+importFrom(ggplot2,geom_segment)
 importFrom(ggplot2,ggplot_build)
 importFrom(ggplot2,labs)
 importFrom(ggplot2,position_dodge)

diff --git a/R/fn_add.R b/R/fn_add.R
@@ -350,6 +350,7 @@ add_latest_match <- function (data_tb, dynamic_lup, target_var_nm_1L_chr, date_v
 #' @param adjust_1L_dbl Adjust (a double vector of length one), Default: 0.4
 #' @param as_percent_1L_lgl As percent (a logical vector of length one), Default: F
 #' @param digits_1L_int Digits (an integer vector of length one), Default: 4
+#' @param flip_1L_lgl Flip (a logical vector of length one), Default: F
 #' @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
@@ -358,27 +359,47 @@ add_latest_match <- function (data_tb, dynamic_lup, target_var_nm_1L_chr, date_v
 #' @return Plot (a plot)
 #' @rdname add_significance
 #' @export 
-#' @importFrom ggplot2 ggplot_build
+#' @importFrom ggplot2 ggplot_build geom_segment annotate
 #' @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, as_percent_1L_lgl = F, digits_1L_int = 4, 
-    scientific_1L_lgl = F, show_p_1L_lgl = T, show_test_1L_lgl = F, 
-    tip_1L_dbl = 0, ...) 
+    flip_1L_lgl = F, 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()
+    x_axis_xx <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$x$get_labels()
+    if (identical(add_1L_dbl, numeric(0)) & flip_1L_lgl) {
+        add_1L_dbl <- 0
+    }
     if (!identical(add_1L_dbl, numeric(0))) {
         y_axis_dbl <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$y$get_labels() %>% 
             stringr::str_remove_all("%") %>% purrr::discard(is.na) %>% 
             as.numeric()
         y_axis_max_1L_dbl <- y_axis_dbl %>% max()
-        y_position <- y_axis_max_1L_dbl + add_1L_dbl
+        y_axis_min_1L_dbl <- min(y_axis_dbl)
+        if (flip_1L_lgl) {
+            if (is.numeric(x_axis_xx)) {
+                x_val_1L_dbl <- x_axis_xx[length(x_axis_xx)] + 
+                  add_1L_dbl
+            }
+            else {
+                x_val_1L_dbl <- length(x_axis_xx) + add_1L_dbl
+            }
+            y_position <- y_axis_max_1L_dbl
+        }
+        else {
+            y_position <- y_axis_max_1L_dbl + add_1L_dbl
+        }
         if (as_percent_1L_lgl) {
+            if (flip_1L_lgl) {
+                x_val_1L_dbl <- x_val_1L_dbl
+            }
             y_position <- y_position/100
+            y_axis_min_1L_dbl <- y_axis_min_1L_dbl/100
         }
     }
     else {
@@ -391,9 +412,18 @@ add_significance <- function (plot_plt, by_1L_chr, data_tb, var_1L_chr, add_1L_d
         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, ...)
+    if (flip_1L_lgl) {
+        plot_plt <- plot_plt + ggplot2::geom_segment(x = x_val_1L_dbl, 
+            y = y_axis_min_1L_dbl, yend = y_position) + ggplot2::annotate("text", 
+            x = x_val_1L_dbl, y = y_position/2, label = label_1L_chr, 
+            vjust = adjust_1L_dbl, angle = 90)
+    }
+    else {
+        plot_plt <- plot_plt + ggsignif::geom_signif(comparisons = list(x_axis_xx[c(1, 
+            length(x_axis_xx))]), annotations = label_1L_chr, 
+            tip_length = tip_1L_dbl, vjust = adjust_1L_dbl, y_position = y_position, 
+            ...)
+    }
     return(plot_plt)
 }
 #' Add with join

diff --git a/R/fn_plot.R b/R/fn_plot.R
@@ -8,6 +8,7 @@
 #' @param drop_missing_1L_lgl Drop missing (a logical vector of length one), Default: FALSE
 #' @param drop_ticks_1L_lgl Drop ticks (a logical vector of length one), Default: FALSE
 #' @param fill_single_1L_lgl Fill single (a logical vector of length one), Default: FALSE
+#' @param flip_1L_lgl Flip (a logical vector of length one), Default: F
 #' @param label_fill_1L_chr Label fill (a character vector of length one), Default: character(0)
 #' @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
@@ -41,7 +42,7 @@
 plot_for_journal <- 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", 
+    flip_1L_lgl = F, label_fill_1L_chr = character(0), line_1L_chr = "black", 
     position_xx = NULL, recode_lup_r3 = ready4show::ready4show_correspondences(), 
     significance_1L_lgl = F, significance_args_ls = list(), style_1L_chr = get_styles(), 
     title_1L_chr = character(0), type_1L_chr = c("ggsci", "manual", 
@@ -341,7 +342,12 @@ plot_for_journal <- function (data_tb, as_percent_1L_lgl = FALSE, by_1L_chr = ch
             "Freq", y_1L_chr)
         if (!identical(by_1L_chr, x_1L_chr) & !identical(by_1L_chr, 
             character(0))) {
-            data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(by_1L_chr))
+            if (!flip_1L_lgl) {
+                data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(by_1L_chr))
+            }
+            else {
+                data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(x_1L_chr))
+            }
         }
         data_xx <- data_xx %>% dplyr::mutate(Percent = (!!rlang::sym(y_1L_chr)/sum(!!rlang::sym(y_1L_chr))))
         args_ls$y <- "Percent"

diff --git a/R/mthd_depict.R b/R/mthd_depict.R
@@ -14,6 +14,7 @@
 #' @param drop_missing_1L_lgl Drop missing (a logical vector of length one), Default: FALSE
 #' @param drop_ticks_1L_lgl Drop ticks (a logical vector of length one), Default: FALSE
 #' @param fill_single_1L_lgl Fill single (a logical vector of length one), Default: FALSE
+#' @param flip_1L_lgl Flip (a logical vector of length one), Default: F
 #' @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()
@@ -41,8 +42,8 @@ methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = characte
     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(), 
+    drop_ticks_1L_lgl = FALSE, fill_single_1L_lgl = FALSE, flip_1L_lgl = F, 
+    line_1L_chr = "black", position_xx = NULL, recode_lup_r3 = ready4show::ready4show_correspondences(), 
     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), 
@@ -243,11 +244,11 @@ methods::setMethod("depict", "Ready4useDyad", function (x, x_vars_chr = characte
             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, 
-            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, 
+            flip_1L_lgl = flip_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, 
             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(plot_for_journal, x@ds_tb, !!!args_ls)

diff --git a/data-raw/fns/add.R b/data-raw/fns/add.R
@@ -260,6 +260,7 @@ add_significance <- function(plot_plt,
                              adjust_1L_dbl = 0.4,
                              as_percent_1L_lgl = F,
                              digits_1L_int = 4,
+                             flip_1L_lgl = F, ###############
                              scientific_1L_lgl = F,
                              show_p_1L_lgl = T,
                              show_test_1L_lgl = F,
@@ -268,29 +269,51 @@ add_significance <- function(plot_plt,
   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()
+  x_axis_xx <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$x$get_labels()
+  if(identical(add_1L_dbl, numeric(0)) & flip_1L_lgl){
+    add_1L_dbl <- 0
+  }
   if(!identical(add_1L_dbl, numeric(0))){
     y_axis_dbl <- ggplot2::ggplot_build(plot_plt)$layout$panel_params[[1]]$y$get_labels() %>% stringr::str_remove_all("%") %>%
       purrr::discard(is.na) %>% as.numeric()
     y_axis_max_1L_dbl <- y_axis_dbl  %>% max()
-    y_position <- y_axis_max_1L_dbl + add_1L_dbl
+    y_axis_min_1L_dbl <- min(y_axis_dbl)
+
+    if(flip_1L_lgl){
+      if(is.numeric(x_axis_xx)){
+        x_val_1L_dbl <- x_axis_xx[length(x_axis_xx)] + add_1L_dbl
+      }else{
+        x_val_1L_dbl <- length(x_axis_xx) + add_1L_dbl
+      }
+      y_position <- y_axis_max_1L_dbl
+    }else{
+      y_position <- y_axis_max_1L_dbl + add_1L_dbl
+    }
     if(as_percent_1L_lgl){
-      y_position <- y_position/100
+      if(flip_1L_lgl){
+        x_val_1L_dbl <- x_val_1L_dbl
+      }
+      y_position <- y_position / 100
+      y_axis_min_1L_dbl <- y_axis_min_1L_dbl / 100
     }
   }else{
     y_position <- NULL
   }
   if(as_percent_1L_lgl){
-    tip_1L_dbl <- tip_1L_dbl/100
+    tip_1L_dbl <- tip_1L_dbl / 100
   }
-  label_1L_chr <- paste0(ifelse(show_p_1L_lgl, paste0("p=", format(round(df$p.value, digits_1L_int), scientific = scientific_1L_lgl)," ")),
+  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,
-                          ...)
+  if(flip_1L_lgl){
+    plot_plt <- plot_plt + ggplot2::geom_segment(x=x_val_1L_dbl, y=y_axis_min_1L_dbl, yend=y_position) + ggplot2::annotate("text",x=x_val_1L_dbl, y=y_position/2, label = label_1L_chr, vjust=adjust_1L_dbl, angle = 90)
+  }else{
+    plot_plt <- plot_plt +
+      ggsignif::geom_signif(comparisons=list(x_axis_xx[c(1,length(x_axis_xx))]),
+                            annotations=label_1L_chr, tip_length = tip_1L_dbl, vjust = adjust_1L_dbl,
+                            y_position = y_position,
+                            ...)
+  }
   return(plot_plt)
 }
 add_with_join <- function (X_Ready4useDyad,

diff --git a/data-raw/fns/plot.R b/data-raw/fns/plot.R
@@ -6,12 +6,13 @@ plot_for_journal <- function (data_tb,
                               drop_missing_1L_lgl = FALSE,
                               drop_ticks_1L_lgl = FALSE,
                               fill_single_1L_lgl = FALSE,
+                              flip_1L_lgl = F, ########################################
                               label_fill_1L_chr = character(0),
                               line_1L_chr = "black",
                               position_xx = NULL,
                               recode_lup_r3 = ready4show::ready4show_correspondences(),
                               significance_1L_lgl = F,
-                              significance_args_ls = list(),
+                              significance_args_ls = list(), #
                               style_1L_chr = get_styles(),
                               title_1L_chr = character(0),
                               type_1L_chr = c("ggsci", "manual", "viridis"),
@@ -284,7 +285,7 @@ plot_for_journal <- function (data_tb,
   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::any_of(unique(c(x_1L_chr, by_1L_chr))
+    data_xx <- table(data_xx %>% dplyr::select(tidyselect::any_of(unique(c(x_1L_chr, by_1L_chr)) #####
     )), useNA = "ifany") %>% tibble::as_tibble() %>%
       dplyr::rename(Freq = n)
     if (drop_missing_1L_lgl) {
@@ -296,10 +297,14 @@ plot_for_journal <- function (data_tb,
     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") & as_percent_1L_lgl){
+  if(what_1L_chr %in% c("barplot") & as_percent_1L_lgl){ ####
     y_1L_chr <- ifelse(identical(y_1L_chr, character(0)), "Freq", y_1L_chr)
     if(!identical(by_1L_chr, x_1L_chr) & !identical(by_1L_chr, character(0))){
-      data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(by_1L_chr))
+      if(!flip_1L_lgl){
+        data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(by_1L_chr))
+      }else{
+        data_xx <- data_xx %>% dplyr::group_by(!!rlang::sym(x_1L_chr))
+      }
     }
     data_xx <- data_xx %>% dplyr::mutate(Percent = (!!rlang::sym(y_1L_chr) / sum(!!rlang::sym(y_1L_chr))))
     args_ls$y <- "Percent"
@@ -318,6 +323,9 @@ plot_for_journal <- function (data_tb,
   }
   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)

diff --git a/data-raw/s4_fns/depict.R b/data-raw/s4_fns/depict.R
@@ -10,6 +10,7 @@ depict_Ready4useDyad <- function(x,
                                  drop_missing_1L_lgl = FALSE,
                                  drop_ticks_1L_lgl = FALSE,
                                  fill_single_1L_lgl = FALSE,
+                                 flip_1L_lgl = F,
                                  line_1L_chr = "black",
                                  position_xx = NULL,
                                  recode_lup_r3 = ready4show::ready4show_correspondences(),
@@ -220,6 +221,7 @@ depict_Ready4useDyad <- function(x,
                                                  drop_missing_1L_lgl = drop_missing_1L_lgl,
                                                  drop_ticks_1L_lgl = drop_ticks_1L_lgl,
                                                  fill_single_1L_lgl = fill_single_1L_lgl,
+                                                 flip_1L_lgl = flip_1L_lgl,
                                                  label_fill_1L_chr = label_fill_1L_chr,
                                                  line_1L_chr = line_1L_chr,
                                                  significance_1L_lgl = significance_1L_lgl, #

diff --git a/man/add_significance.Rd b/man/add_significance.Rd
diff --git a/man/depict-methods.Rd b/man/depict-methods.Rd
diff --git a/man/plot_for_journal.Rd b/man/plot_for_journal.Rd