Skip to content

Commit

Permalink
Revise dispatcher functions, add tests
Browse files Browse the repository at this point in the history
  • Loading branch information
@strohne
strohne committed May 8, 2024
1 parent c3afcfe commit 907e3b2
Show file tree
Hide file tree
Showing 12 changed files with 719 additions and 327 deletions.
64 changes: 39 additions & 25 deletions R/effects.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,27 +46,28 @@ effect_counts <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE
cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)
is_items <- length(cols_eval) > 1
is_grouped <- length(cross_eval) == 1
is_cor <- metric != FALSE
is_multi <- length(cross_eval) > 1
is_metric <- metric != FALSE

# Single variables
if (!is_items && !is_grouped && !is_cor) {
if (!is_items && !(is_grouped ||is_multi) && !is_metric) {
effect_counts_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_cor) {
else if (!is_items && is_grouped && !is_metric) {
effect_counts_one_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (!is_items && is_grouped && is_cor) {
else if (!is_items && is_grouped && is_metric) {
effect_counts_one_cor(data, {{ cols }}, {{ cross }}, ...)
}

# Items
else if (is_items && !is_grouped && !is_cor) {
else if (is_items && !(is_grouped || is_multi) && !is_metric) {
effect_counts_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_cor) {
else if (is_items && is_grouped && !is_metric) {
effect_counts_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (is_items && is_grouped && is_cor) {
else if (is_items && (is_grouped || is_multi) && is_metric) {
effect_counts_items_cor(data, {{ cols }}, {{ cross }}, ...)
}
# Not found
Expand Down Expand Up @@ -123,10 +124,11 @@ effect_metrics <- function(data, cols, cross = NULL, metric = FALSE, clean = TRU
cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)
is_items <- length(cols_eval) > 1
is_grouped <- length(cross_eval)== 1
is_multi <- length(cross_eval) > 1
is_cor <- metric != FALSE

# Single variables
if (!is_items && !is_grouped && !is_cor) {
if (!is_items && !is_grouped && !is_multi && !is_cor) {
effect_metrics_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_cor) {
Expand All @@ -137,13 +139,13 @@ effect_metrics <- function(data, cols, cross = NULL, metric = FALSE, clean = TRU
}

# Items
else if (is_items && !is_grouped && !is_cor) {
else if (is_items && !is_grouped && !is_multi && !is_cor) {
effect_metrics_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_cor) {
effect_metrics_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (is_items && is_grouped && is_cor) {
else if (is_items && (is_grouped || is_multi) && is_cor) {
effect_metrics_items_cor(data, {{ cols }}, {{ cross }}, ...)
}
# Not found
Expand Down Expand Up @@ -235,14 +237,14 @@ effect_counts_one_grouped <- function(data, col, cross, clean = TRUE, ...) {

# 6. Prepare output
result <- tibble::tribble(
~Statistic, ~Value, ~.digits,
"Number of cases", n, 0,
"Phi", phi, 2,
"Cramer's V", cramer_v, 2,
"Chi-squared", fit$statistic, 2,
"Degrees of freedom", fit$parameter, 0,
"p value", fit$p.value, 3
#"stars", get_stars(fit$p.value), 0
~Statistic, ~Value,
"Number of cases", as.character(n),
"Phi", as.character(round(phi, 2)),
"Cramer's V", as.character(round(cramer_v, 2)),
"Chi-squared", as.character(round(fit$statistic, 2)),
"Degrees of freedom", as.character(fit$parameter),
"p value", as.character(round(fit$p.value, 3)),
"stars", get_stars(fit$p.value)
)

result <- .attr_transfer(result, data, "missings")
Expand Down Expand Up @@ -484,8 +486,8 @@ effect_metrics_one_grouped <- function(data, col, cross, method = "lm", negative

result <- c(
result,
list(.to_vlkr_tab(lm_params, digits=2, caption = "Regression parameters")),
list(.to_vlkr_tab(lm_model, digits=2, caption = "Model statistics"))
list(.to_vlkr_tab(lm_params, digits=2)),
list(.to_vlkr_tab(lm_model, digits=2))
)
}

Expand Down Expand Up @@ -553,11 +555,14 @@ effect_metrics_one_cor <- function(data, col, cross, method = "pearson", negativ
dplyr::rename("Item 1" = tidyselect::all_of("item1")) |>
dplyr::rename("Item 2" = tidyselect::all_of("item2"))

title <- ifelse(prefix == "", NULL, prefix)
if (prefix == "") {
title <- NULL
}


method <- ifelse(method == "spearman", "Spearman's rho", "Pearson's r")
result <- result |>
dplyr::rename({{ method }} := .data$r) |>
dplyr::rename({{ method }} := "r") |>
dplyr::mutate(dplyr::across(tidyselect::everything(), \(x) as.character(x))) |>
tidyr::pivot_longer(
cols = -tidyselect::all_of(c("Item 1", "Item 2")),
Expand Down Expand Up @@ -627,7 +632,11 @@ effect_metrics_items <- function(data, cols, method = "pearson", negative = FALS
dplyr::rename("Item 1" = tidyselect::all_of("item1")) |>
dplyr::rename("Item 2" = tidyselect::all_of("item2"))

title <- ifelse(prefix == "", NULL, prefix)
if (prefix == "") {
title <- NULL
} else {
title <- prefix
}

result <- .attr_transfer(result, data, "missings")
.to_vlkr_tab(result, digits= 2, caption=title)
Expand Down Expand Up @@ -703,15 +712,20 @@ effect_metrics_items_cor <- function(data, cols, cross, method = "pearson", nega
result <- dplyr::mutate(result, item2 = trim_prefix(.data$item2, prefix))

prefix <- ifelse(prefix == "", "Item", prefix)
title <- ifelse(prefix == "", NULL, prefix)
if (prefix == "") {
title <- NULL
} else {
title <- prefix
}


result <- result %>%
dplyr::rename("Item 1" = tidyselect::all_of("item1")) |>
dplyr::rename("Item 2" = tidyselect::all_of("item2"))

method <- ifelse(method == "spearman", "Spearman's rho", "Pearson's r")
result <- result |>
dplyr::rename({{ method }} := .data$r)
dplyr::rename({{ method }} := "r")

result <- .attr_transfer(result, data, "missings")
.to_vlkr_tab(result, digits= 2, caption=title)
Expand Down
23 changes: 16 additions & 7 deletions R/plots.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,23 +45,31 @@ plot_counts <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE,
cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)
is_items <- length(cols_eval) > 1
is_grouped <- length(cross_eval)== 1
is_multi <- length(cross_eval) > 1
is_metric <- metric != FALSE

# Single variables
if (!is_items && !is_grouped) {
if (!is_items && !(is_grouped || is_multi)) {
plot_counts_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_metric) {
plot_counts_one_grouped(data, {{ cols }}, {{ cross }}, ...)
}

else if (!is_items && is_grouped && is_metric) {
plot_counts_one_cor(data, {{ cols }}, {{ cross }}, ...)
}

# Items
else if (is_items && !is_grouped) {
else if (is_items && !(is_grouped || is_multi)) {
plot_counts_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_metric) {
plot_counts_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (is_items && is_grouped && is_metric) {
plot_counts_items_cor(data, {{ cols }}, {{ cross }}, ...)
}

# Not found
else {
Expand Down Expand Up @@ -114,14 +122,15 @@ plot_metrics <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE,

# Find columns
cols_eval <- tidyselect::eval_select(expr = enquo(cols), data = data)
cols_cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)
cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)

is_items <- length(cols_eval) > 1
is_grouped <- length(cols_cross_eval) == 1
is_grouped <- length(cross_eval) == 1
is_multi <- length(cross_eval) > 1
is_metric <- metric != FALSE

# Single variables
if (!is_items && !is_grouped && !is_metric) {
if (!is_items && !(is_grouped ||is_multi) && !is_metric) {
plot_metrics_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_metric) {
Expand All @@ -132,13 +141,13 @@ plot_metrics <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE,
}

# Items
else if (is_items && !is_grouped && !is_metric) {
else if (is_items && !(is_grouped || is_multi) && !is_metric) {
plot_metrics_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_metric) {
plot_metrics_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (is_items && !is_grouped && is_metric) {
else if (is_items && (is_grouped || is_multi) && is_metric) {
plot_metrics_items_cor(data, {{ cols }}, {{ cross }}, ...)
}

Expand Down
44 changes: 27 additions & 17 deletions R/tables.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,21 +46,22 @@ tab_counts <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE, .
cross_eval <- tidyselect::eval_select(expr = enquo(cross), data = data)
is_items <- length(cols_eval) > 1
is_grouped <- length(cross_eval)== 1
is_cor <- metric != FALSE
is_multi <- length(cross_eval) > 1
is_metric <- metric != FALSE

# Single variables
if (!is_items && !is_grouped) {
if (!is_items && !(is_grouped || is_multi)) {
tab_counts_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_cor) {
else if (!is_items && is_grouped && !is_metric) {
tab_counts_one_grouped(data, {{ cols }}, {{ cross }}, ...)
}

# Items
else if (is_items && !is_grouped) {
else if (is_items && !(is_grouped ||is_multi)) {
tab_counts_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_cor) {
else if (is_items && is_grouped && !is_metric) {
tab_counts_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}

Expand Down Expand Up @@ -119,27 +120,31 @@ tab_metrics <- function(data, cols, cross = NULL, metric = FALSE, clean = TRUE,

is_items <- length(cols_eval) > 1
is_grouped <- length(cross_eval) == 1
is_cor <- metric != FALSE
is_multi <- length(cross_eval) > 1
is_metric <- metric != FALSE

# Single variables
if (!is_items && !is_grouped && !is_cor) {
if (!is_items && !(is_grouped ||is_multi)) {
tab_metrics_one(data, {{ cols }}, ...)
}
else if (!is_items && is_grouped && !is_cor) {
else if (!is_items && is_grouped && !is_metric) {
tab_metrics_one_grouped(data, {{ cols }}, {{ cross }}, ...)
}

else if (!is_items && is_grouped && is_cor) {
else if (!is_items && is_grouped && is_metric) {
tab_metrics_one_cor(data, {{ cols }}, {{ cross }}, ...)
}

# Items
else if (is_items && !is_grouped && !is_cor) {
else if (is_items && !(is_grouped || is_multi) && !is_metric) {
tab_metrics_items(data, {{ cols }} , ...)
}
else if (is_items && is_grouped && !is_cor) {
else if (is_items && is_grouped && !is_metric) {
tab_metrics_items_grouped(data, {{ cols }}, {{ cross }}, ...)
}
else if (is_items && (is_grouped || is_multi) && is_metric) {
tab_metrics_items_cor(data, {{ cols }}, {{ cross }}, ...)
}

# Not found
else {
Expand Down Expand Up @@ -978,7 +983,7 @@ tab_metrics_one_cor <- function(data, col, cross, method = "pearson", ci = FALSE

# Calculate correlation
method <- ifelse(method == "spearman", "spearman", "pearson")
result <- .effect_correlations(data, {{ cols }}, {{ cross}}, method = method, labels = labels)
result <- .effect_correlations(data, {{ col }}, {{ cross}}, method = method, labels = labels)

values <- c("item1", "item2", "n", "r")
if (ci) {
Expand All @@ -993,7 +998,11 @@ tab_metrics_one_cor <- function(data, col, cross, method = "pearson", ci = FALSE
result <- dplyr::mutate(result, item2 = trim_prefix(.data$item2, prefix))

prefix <- ifelse(prefix == "", "Item", prefix)
title <- ifelse(prefix == "", NULL, prefix)
if (prefix == "") {
title <- NULL
} else {
title <- prefix
}

result <- result %>%
dplyr::rename("Item 1" = tidyselect::all_of("item1")) |>
Expand Down Expand Up @@ -1325,7 +1334,6 @@ tab_metrics_items_cor <- function(data, cols, cross, method = "pearson", negativ
# 5. Calculate correlation
result <- .effect_correlations(data, {{ cols }}, {{ cross}}, method = method, labels = labels)


# Remove common item prefix
prefix1 <- get_prefix(result$item1)
prefix2 <- get_prefix(result$item2)
Expand All @@ -1342,16 +1350,18 @@ tab_metrics_items_cor <- function(data, cols, cross, method = "pearson", negativ
}
}

title <- ifelse(title == "", NULL, title)

if(title == "") {
title <- NULL
}

# Create matrix
result <- result %>%
dplyr::select("item1", "item2", "r") |>
tidyr::pivot_wider(names_from = "item2", values_from = "r")

prefix1 <- ifelse(prefix1 == "", "Item", prefix1)
result <- dplyr::rename(result, {{ prefix1 }} := .data$item1)

result <- dplyr::rename(result, {{ prefix1 }} := "item1")

result <- .attr_transfer(result, data, "missings")
.to_vlkr_tab(result, digits = digits, caption = title)
Expand Down
Loading

0 comments on commit 907e3b2

Please sign in to comment.