Skip to content

Commit

Permalink
Final refactoring
Browse files Browse the repository at this point in the history
  • Loading branch information
@cyberosa
cyberosa committed Mar 31, 2024
1 parent 64f4ae0 commit da8cb97
Show file tree
Hide file tree
Showing 3 changed files with 88 additions and 88 deletions.
116 changes: 58 additions & 58 deletions R/005_printing.R
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
# TODO add proper documentation
print_greeting_header <- function() {
dabest_ver <- utils::packageVersion("dabestr")
line1 <- paste("DABESTR v", dabest_ver, sep = "")
Expand All @@ -24,17 +25,20 @@ print_greeting_header <- function() {
cat("\n")
}

print_each_comparism <- function(dabest_object) {
# TODO add proper documentation
print_each_comparism <- function(dabest_obj) {
check_dabest_object(dabest_obj)

i <- 1
if (is.list(dabest_object$idx)) {
for (group in dabest_object$idx) {
if (is.list(dabest_obj$idx)) {
for (group in dabest_obj$idx) {
# Get test groups (everything else in group), loop through them and compute
# the difference between group[1] and each group.
# Test groups are the 2nd element of group onwards.
control_group <- group[1]
test_groups <- group[2:length(group)]

if (is.null(dabest_object$paired) || dabest_object$paired == "baseline") {
if (is.null(dabest_obj$paired) || dabest_obj$paired == "baseline") {
control_group <- group[1]
test_groups <- group[2:length(group)]
for (current_test_group in test_groups) {
Expand All @@ -51,20 +55,20 @@ print_each_comparism <- function(dabest_object) {
}
}

if (isTRUE(dabest_object$minimeta)) {
if (dabest_obj$minimeta) {
cat(stringr::str_interp("${i}. weighted delta (only for mean difference)\n"))
i <- i + 1
}

if (isTRUE(dabest_object$delta2)) {
experiment1 <- dabest_object$experiment_label[2]
experiment2 <- dabest_object$experiment_label[1]
if (dabest_obj$delta2) {
experiment1 <- dabest_obj$experiment_label[2]
experiment2 <- dabest_obj$experiment_label[1]

cat(stringr::str_interp("${i}. ${experiment1} minus ${experiment2} (only for mean difference)\n"))
}
} else {
control_group <- dabest_object$idx[1]
test_groups <- dabest_object$idx[2:length(dabest_object$idx)]
control_group <- dabest_obj$idx[1]
test_groups <- dabest_obj$idx[2:length(dabest_obj$idx)]

for (current_test_group in test_groups) {
cat(stringr::str_interp(" ${i}. ${current_test_group} minus ${control_group}\n"))
Expand All @@ -74,56 +78,51 @@ print_each_comparism <- function(dabest_object) {
cat("\n")
}

print_each_comparism_effectsize <- function(dabest_object, effectsize) {
if (effectsize == "mean_diff") {
es <- "mean difference"
} else if (effectsize == "median_diff") {
es <- "median difference"
} else if (effectsize == "cohens_d") {
es <- "Cohen's d"
} else if (effectsize == "hedges_g") {
es <- "Hedges'g"
} else if (effectsize == "cliffs_delta") {
es <- "Cliff's delta"
} else {
es <- "Cohen's h"
}
# TODO add proper documentation
print_each_comparism_effectsize <- function(dabest_effectsize_obj, effectsize) {
es_lookup <- c(
"mean_diff" = "mean difference",
"median_diff" = "median difference",
"cohens_d" = "Cohen's d",
"hedges_g" = "Hedges'g",
"cliffs_delta" = "Cliff's delta"
)
tryCatch(
{
es <- es_lookup[effectsize]
},
error = function(e) {
# default value
es <- "Cohen's h"
}
)

check_effectsize_object(dabest_effectsize_obj)
i <- 1
paired <- dabest_object$paired
difference <- round(dabest_object$boot_result$difference, 3)
bca_low <- round(dabest_object$boot_result$bca_ci_low, 3)
bca_high <- round(dabest_object$boot_result$bca_ci_high, 3)
ci <- dabest_object$boot_result$ci
pvalue <- dabest_object$permtest_pvals$pval_for_tests

# TODO switch lookup table
if (is.null(paired)) {
rm_status <- ""
} else if (paired == "sequential") {
rm_status <- "for the sequential design of repeated-measures experiment \n"
} else if (paired == "baseline") {
rm_status <- "for repeated measures against baseline \n"
}

if (is.null(paired)) {
paired_status <- "unpaired"
} else if (paired == "sequential") {
paired_status <- "paired"
} else if (paired == "baseline") {
paired_status <- "paired"
}

if (is.list(dabest_object$idx)) {
for (group in dabest_object$idx) {
paired <- dabest_effectsize_obj$paired
difference <- round(dabest_effectsize_obj$boot_result$difference, 3)
bca_low <- round(dabest_effectsize_obj$boot_result$bca_ci_low, 3)
bca_high <- round(dabest_effectsize_obj$boot_result$bca_ci_high, 3)
ci <- dabest_effectsize_obj$boot_result$ci
pvalue <- dabest_effectsize_obj$permtest_pvals$pval_for_tests

# Use a lookup table for rm_status and paired_status
rm_status_lookup <- c(NULL = "", "sequential" = "for the sequential design of repeated-measures experiment \\n", "baseline" = "for repeated measures against baseline \\n")
paired_status_lookup <- c(NULL = "unpaired", "sequential" = "paired", "baseline" = "paired")

rm_status <- rm_status_lookup[paired]
paired_status <- paired_status_lookup[paired]

if (is.list(dabest_effectsize_obj$idx)) {
for (group in dabest_effectsize_obj$idx) {
# Get test groups (everything else in group), loop through them and compute
# the difference between group[1] and each group.
# Test groups are the 2nd element of group onwards.

control_group <- group[1]
test_groups <- group[2:length(group)]

if (is.null(dabest_object$paired) || dabest_object$paired == "baseline") {
if (is.null(dabest_effectsize_obj$paired) || dabest_effectsize_obj$paired == "baseline") {
control_group <- group[1]
test_groups <- group[2:length(group)]
for (current_test_group in test_groups) {
Expand Down Expand Up @@ -158,8 +157,8 @@ print_each_comparism_effectsize <- function(dabest_object, effectsize) {
}
}
} else {
control_group <- dabest_object$idx[1]
test_groups <- dabest_object$idx[2:length(dabest_object$idx)]
control_group <- dabest_effectsize_obj$idx[1]
test_groups <- dabest_effectsize_obj$idx[2:length(dabest_effectsize_obj$idx)]

for (current_test_group in test_groups) {
cat(stringr::str_interp("The ${paired_status} ${es} between ${current_test_group} and ${control_group} is ${difference} [${ci}%CI ${bca_low}, ${bca_high}].\n"))
Expand All @@ -168,13 +167,14 @@ print_each_comparism_effectsize <- function(dabest_object, effectsize) {
}
}

print_ending <- function(dabest_object) {
if (methods::is(dabest_object, "dabest")) {
nboots <- dabest_object$resamples
# TODO add proper documentation. If the parameter can be sth that is not a dabest_object maybe change the name
print_ending <- function(dabest_obj) {
if (inherits(dabest_obj, "dabest")) {
nboots <- dabest_obj$resamples
cat(stringr::str_interp("${nboots} resamples will be used to generate the effect size bootstraps.\n\n"))
} else {
nboots <- dabest_object$resamples
nreshuffles <- length(dabest_object$permtest_pvals$permutation_test_results[[1]]$permutations)
nboots <- dabest_obj$resamples
nreshuffles <- length(dabest_obj$permtest_pvals$permutation_test_results[[1]]$permutations)
cat(stringr::str_interp("${nboots} bootstrap samples were taken; the confidence interval is bias-corrected and accelerated.\n"))
cat("Any p-value reported is the probability of observing the effect size (or greater),\n")
cat("assuming the null hypothesis of zero difference is true.\n")
Expand Down
59 changes: 29 additions & 30 deletions R/999_plot_kwargs.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,9 +46,8 @@
#' npg, aaas, nejm, lancet, jama, jco, ucscgb, d3, locuszoom, igv, cosmic, uchicago, brewer, ordinal, viridis_d.
#'
#'
NULL

assign_plot_kwargs <- function(dabest_effectsize_obj, plot_kwargs) {
check_effectsize_object(dabest_effectsize_obj)
custom_palette <- "d3"

swarm_label <- dabest_effectsize_obj$raw_y_labels
Expand Down Expand Up @@ -85,88 +84,88 @@ assign_plot_kwargs <- function(dabest_effectsize_obj, plot_kwargs) {
sankey <- TRUE
flow <- TRUE

if (isFALSE(is.null(plot_kwargs$swarm_label))) {
if (!(is.null(plot_kwargs$swarm_label))) {
swarm_label <- plot_kwargs$swarm_label
}
if (isFALSE(is.null(plot_kwargs$contrast_label))) {
if (!(is.null(plot_kwargs$contrast_label))) {
contrast_label <- plot_kwargs$contrast_label
}
if (isFALSE(is.null(plot_kwargs$custom_palette))) {
if (!(is.null(plot_kwargs$custom_palette))) {
custom_palette <- plot_kwargs$custom_palette
}
if (isFALSE(is.null(plot_kwargs$swarm_ylim))) {
if (!(is.null(plot_kwargs$swarm_ylim))) {
swarm_ylim <- plot_kwargs$swarm_ylim
}
if (isFALSE(is.null(plot_kwargs$contrast_ylim))) {
if (!(is.null(plot_kwargs$contrast_ylim))) {
contrast_ylim <- plot_kwargs$contrast_ylim
}
if (isFALSE(is.null(plot_kwargs$delta2_ylim))) {
if (!(is.null(plot_kwargs$delta2_ylim))) {
delta2_ylim <- plot_kwargs$delta2_ylim
}
if (isFALSE(is.null(plot_kwargs$delta2_label))) {
if (!(is.null(plot_kwargs$delta2_label))) {
delta2_label <- plot_kwargs$delta2_label
}
if (isFALSE(is.null(plot_kwargs$show_delta2))) {
if (!(is.null(plot_kwargs$show_delta2))) {
show_delta2 <- plot_kwargs$show_delta2
}
if (isFALSE(is.null(plot_kwargs$show_mini_meta))) {
if (!(is.null(plot_kwargs$show_mini_meta))) {
show_mini_meta <- plot_kwargs$show_mini_meta
}
if (isFALSE(is.null(plot_kwargs$raw_marker_size))) {
if (!(is.null(plot_kwargs$raw_marker_size))) {
raw_marker_size <- plot_kwargs$raw_marker_size
}
if (isFALSE(is.null(plot_kwargs$raw_marker_alpha))) {
if (!(is.null(plot_kwargs$raw_marker_alpha))) {
raw_marker_alpha <- plot_kwargs$raw_marker_alpha
}
if (isFALSE(is.null(plot_kwargs$raw_marker_side_shift))) {
if (!(is.null(plot_kwargs$raw_marker_side_shift))) {
raw_marker_side_shift <- plot_kwargs$raw_marker_side_shift
}
if (isFALSE(is.null(plot_kwargs$tufte_size))) {
if (!(is.null(plot_kwargs$tufte_size))) {
tufte_size <- plot_kwargs$tufte_size
}
if (isFALSE(is.null(plot_kwargs$es_marker_size))) {
if (!(is.null(plot_kwargs$es_marker_size))) {
es_marker_size <- plot_kwargs$es_marker_size
}
if (isFALSE(is.null(plot_kwargs$es_line_size))) {
if (!(is.null(plot_kwargs$es_line_size))) {
es_line_size <- plot_kwargs$es_line_size
}
if (isFALSE(is.null(plot_kwargs$raw_bar_width))) {
if (!(is.null(plot_kwargs$raw_bar_width))) {
raw_bar_width <- plot_kwargs$raw_bar_width
}
if (isFALSE(is.null(plot_kwargs$raw_marker_spread))) {
if (!(is.null(plot_kwargs$raw_marker_spread))) {
raw_marker_spread <- plot_kwargs$raw_marker_spread
}
if (isFALSE(is.null(plot_kwargs$sankey))) {
if (!(is.null(plot_kwargs$sankey))) {
sankey <- plot_kwargs$sankey
}
if (isFALSE(is.null(plot_kwargs$flow))) {
if (!(is.null(plot_kwargs$flow))) {
flow <- plot_kwargs$flow
}
if (isFALSE(is.null(plot_kwargs$raw_flow_alpha))) {
if (!(is.null(plot_kwargs$raw_flow_alpha))) {
raw_flow_alpha <- plot_kwargs$raw_flow_alpha
}
if (isFALSE(is.null(plot_kwargs$swarm_y_text))) {
if (!(is.null(plot_kwargs$swarm_y_text))) {
swarm_y_text <- plot_kwargs$swarm_y_text
}
if (isFALSE(is.null(plot_kwargs$swarm_x_text))) {
if (!(is.null(plot_kwargs$swarm_x_text))) {
swarm_x_text <- plot_kwargs$swarm_x_text
}
if (isFALSE(is.null(plot_kwargs$contrast_y_text))) {
if (!(is.null(plot_kwargs$contrast_y_text))) {
contrast_y_text <- plot_kwargs$contrast_y_text
}
if (isFALSE(is.null(plot_kwargs$contrast_x_text))) {
if (!(is.null(plot_kwargs$contrast_x_text))) {
contrast_x_text <- plot_kwargs$contrast_x_text
}
if (isFALSE(is.null(plot_kwargs$show_zero_dot))) {
if (!(is.null(plot_kwargs$show_zero_dot))) {
show_zero_dot <- plot_kwargs$show_zero_dot
}
if (isFALSE(is.null(plot_kwargs$show_baseline_ec))) {
if (!(is.null(plot_kwargs$show_baseline_ec))) {
show_baseline_ec <- plot_kwargs$show_baseline_ec
}
if (isFALSE(is.null(plot_kwargs$show_legend))) {
if (!(is.null(plot_kwargs$show_legend))) {
show_legend <- plot_kwargs$show_legend
}
if (isFALSE(is.null(plot_kwargs$asymmetric_side))) {
if (!(is.null(plot_kwargs$asymmetric_side))) {
asymmetric_side <- plot_kwargs$asymmetric_side
}

Expand Down
1 change: 1 addition & 0 deletions R/999_plot_palettes.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
# Contains function `apply_palette`.

# Applies palettes to <ggplot> objects
# TODO add proper documentation.
apply_palette <- function(ggplot_object, palette_name) {
ggplot_object <- switch(palette_name,
"npg" =
Expand Down

0 comments on commit da8cb97

Please sign in to comment.