|
1 | | -#' Perform cell residuals analysis |
2 | | -#' @param cont_table Contingency table |
3 | | -#' @param method Method for p-value adjustment |
4 | | -#' @return List with residuals and p-values |
5 | | -perform_residuals_analysis <- function(cont_table, method = "bonferroni") { |
6 | | - results <- chisq.posthoc.test::chisq.posthoc.test( |
7 | | - x = cont_table, |
8 | | - method = method, |
9 | | - round = 3 |
10 | | - ) |
11 | | - return(results) |
12 | | -} |
13 | | - |
14 | | -#' Perform pairwise chi-square tests |
15 | | -#' @param data Data frame |
16 | | -#' @param group_var Group variable name |
17 | | -#' @param response_var Response variable name |
18 | | -#' @param method Method for p-value adjustment |
19 | | -#' @return List of pairwise comparison results |
20 | | -perform_pairwise_tests <- function(data, group_var, response_var, method = "bonferroni") { |
21 | | - group_levels <- unique(data[[group_var]]) |
22 | | - n_groups <- length(group_levels) |
23 | | - results <- list() |
24 | | - |
25 | | - if(n_groups > 2) { |
26 | | - # Perform pairwise comparisons |
27 | | - for(i in 1:(n_groups-1)) { |
28 | | - for(j in (i+1):n_groups) { |
29 | | - subset_data <- data[data[[group_var]] %in% c(group_levels[i], group_levels[j]),] |
30 | | - subtable <- table(subset_data[[group_var]], subset_data[[response_var]]) |
31 | | - |
32 | | - test_result <- suppressWarnings(chisq.test(subtable)) |
33 | | - |
34 | | - comparison_name <- paste(group_levels[i], "vs", group_levels[j]) |
35 | | - results[[comparison_name]] <- list( |
36 | | - comparison = comparison_name, |
37 | | - chi_square = test_result$statistic, |
38 | | - df = test_result$parameter, |
39 | | - p_value = test_result$p.value |
40 | | - ) |
41 | | - } |
42 | | - } |
43 | | - |
44 | | - # Adjust p-values |
45 | | - p_values <- sapply(results, function(x) x$p_value) |
46 | | - adjusted_p_values <- p.adjust(p_values, method = method) |
47 | | - |
48 | | - # Add adjusted p-values |
49 | | - for(i in seq_along(results)) { |
50 | | - results[[i]]$adjusted_p_value <- adjusted_p_values[i] |
51 | | - } |
52 | | - } |
53 | | - |
54 | | - return(results) |
55 | | -} |
56 | | - |
57 | | -#' Format post-hoc results as HTML |
58 | | -#' @param residuals_results Results from residuals analysis |
59 | | -#' @param pairwise_results Results from pairwise tests |
60 | | -#' @return HTML string |
61 | | -format_posthoc_html <- function(residuals_results = NULL, pairwise_results = NULL) { |
62 | | - html_parts <- list() |
63 | | - |
64 | | - if(!is.null(residuals_results)) { |
65 | | - # Format residuals table |
66 | | - res_table <- kableExtra::kable( |
67 | | - residuals_results, |
68 | | - format = "html", |
69 | | - caption = "Cell Residuals Analysis", |
70 | | - digits = 3 |
71 | | - ) %>% |
72 | | - kableExtra::kable_styling(bootstrap_options = c("striped", "hover")) |
73 | | - |
74 | | - html_parts$residuals <- res_table |
75 | | - } |
76 | | - |
77 | | - if(!is.null(pairwise_results) && length(pairwise_results) > 0) { |
78 | | - # Create data frame from pairwise results |
79 | | - pair_df <- do.call(rbind, lapply(pairwise_results, function(x) { |
80 | | - data.frame( |
81 | | - Comparison = x$comparison, |
82 | | - ChiSquare = round(x$chi_square, 3), |
83 | | - df = x$df, |
84 | | - p_value = round(x$p_value, 3), |
85 | | - adjusted_p = round(x$adjusted_p_value, 3) |
86 | | - ) |
87 | | - })) |
88 | | - |
89 | | - # Format pairwise table |
90 | | - pair_table <- kableExtra::kable( |
91 | | - pair_df, |
92 | | - format = "html", |
93 | | - caption = "Pairwise Comparisons", |
94 | | - col.names = c("Comparison", "Chi-Square", "df", "p-value", "Adjusted p-value") |
95 | | - ) %>% |
96 | | - kableExtra::kable_styling(bootstrap_options = c("striped", "hover")) |
97 | | - |
98 | | - html_parts$pairwise <- pair_table |
99 | | - } |
100 | | - |
101 | | - # Combine results based on what's available |
102 | | - if(length(html_parts) == 2) { |
103 | | - # Both analyses |
104 | | - html_output <- paste0( |
105 | | - '<div class="posthoc-analyses">', |
106 | | - '<div class="residuals-section">', |
107 | | - html_parts$residuals, |
108 | | - '</div><br><br>', |
109 | | - '<div class="pairwise-section">', |
110 | | - html_parts$pairwise, |
111 | | - '</div>', |
112 | | - '</div>' |
113 | | - ) |
114 | | - } else { |
115 | | - # Single analysis |
116 | | - html_output <- paste0( |
117 | | - '<div class="posthoc-analyses">', |
118 | | - html_parts[[1]], |
119 | | - '</div>' |
120 | | - ) |
121 | | - } |
122 | | - |
123 | | - return(html_output) |
124 | | -} |
| 1 | +#' #' Perform cell residuals analysis |
| 2 | +#' #' @param cont_table Contingency table |
| 3 | +#' #' @param method Method for p-value adjustment |
| 4 | +#' #' @return List with residuals and p-values |
| 5 | +#' perform_residuals_analysis <- function(cont_table, method = "bonferroni") { |
| 6 | +#' results <- chisq.posthoc.test::chisq.posthoc.test( |
| 7 | +#' x = cont_table, |
| 8 | +#' method = method, |
| 9 | +#' round = 3 |
| 10 | +#' ) |
| 11 | +#' return(results) |
| 12 | +#' } |
| 13 | +#' |
| 14 | +#' #' Perform pairwise chi-square tests |
| 15 | +#' #' @param data Data frame |
| 16 | +#' #' @param group_var Group variable name |
| 17 | +#' #' @param response_var Response variable name |
| 18 | +#' #' @param method Method for p-value adjustment |
| 19 | +#' #' @return List of pairwise comparison results |
| 20 | +#' perform_pairwise_tests <- function(data, group_var, response_var, method = "bonferroni") { |
| 21 | +#' group_levels <- unique(data[[group_var]]) |
| 22 | +#' n_groups <- length(group_levels) |
| 23 | +#' results <- list() |
| 24 | +#' |
| 25 | +#' if(n_groups > 2) { |
| 26 | +#' # Perform pairwise comparisons |
| 27 | +#' for(i in 1:(n_groups-1)) { |
| 28 | +#' for(j in (i+1):n_groups) { |
| 29 | +#' subset_data <- data[data[[group_var]] %in% c(group_levels[i], group_levels[j]),] |
| 30 | +#' subtable <- table(subset_data[[group_var]], subset_data[[response_var]]) |
| 31 | +#' |
| 32 | +#' test_result <- suppressWarnings(chisq.test(subtable)) |
| 33 | +#' |
| 34 | +#' comparison_name <- paste(group_levels[i], "vs", group_levels[j]) |
| 35 | +#' results[[comparison_name]] <- list( |
| 36 | +#' comparison = comparison_name, |
| 37 | +#' chi_square = test_result$statistic, |
| 38 | +#' df = test_result$parameter, |
| 39 | +#' p_value = test_result$p.value |
| 40 | +#' ) |
| 41 | +#' } |
| 42 | +#' } |
| 43 | +#' |
| 44 | +#' # Adjust p-values |
| 45 | +#' p_values <- sapply(results, function(x) x$p_value) |
| 46 | +#' adjusted_p_values <- p.adjust(p_values, method = method) |
| 47 | +#' |
| 48 | +#' # Add adjusted p-values |
| 49 | +#' for(i in seq_along(results)) { |
| 50 | +#' results[[i]]$adjusted_p_value <- adjusted_p_values[i] |
| 51 | +#' } |
| 52 | +#' } |
| 53 | +#' |
| 54 | +#' return(results) |
| 55 | +#' } |
| 56 | +#' |
| 57 | +#' #' Format post-hoc results as HTML |
| 58 | +#' #' @param residuals_results Results from residuals analysis |
| 59 | +#' #' @param pairwise_results Results from pairwise tests |
| 60 | +#' #' @return HTML string |
| 61 | +#' format_posthoc_html <- function(residuals_results = NULL, pairwise_results = NULL) { |
| 62 | +#' html_parts <- list() |
| 63 | +#' |
| 64 | +#' if(!is.null(residuals_results)) { |
| 65 | +#' # Format residuals table |
| 66 | +#' res_table <- kableExtra::kable( |
| 67 | +#' residuals_results, |
| 68 | +#' format = "html", |
| 69 | +#' caption = "Cell Residuals Analysis", |
| 70 | +#' digits = 3 |
| 71 | +#' ) %>% |
| 72 | +#' kableExtra::kable_styling(bootstrap_options = c("striped", "hover")) |
| 73 | +#' |
| 74 | +#' html_parts$residuals <- res_table |
| 75 | +#' } |
| 76 | +#' |
| 77 | +#' if(!is.null(pairwise_results) && length(pairwise_results) > 0) { |
| 78 | +#' # Create data frame from pairwise results |
| 79 | +#' pair_df <- do.call(rbind, lapply(pairwise_results, function(x) { |
| 80 | +#' data.frame( |
| 81 | +#' Comparison = x$comparison, |
| 82 | +#' ChiSquare = round(x$chi_square, 3), |
| 83 | +#' df = x$df, |
| 84 | +#' p_value = round(x$p_value, 3), |
| 85 | +#' adjusted_p = round(x$adjusted_p_value, 3) |
| 86 | +#' ) |
| 87 | +#' })) |
| 88 | +#' |
| 89 | +#' # Format pairwise table |
| 90 | +#' pair_table <- kableExtra::kable( |
| 91 | +#' pair_df, |
| 92 | +#' format = "html", |
| 93 | +#' caption = "Pairwise Comparisons", |
| 94 | +#' col.names = c("Comparison", "Chi-Square", "df", "p-value", "Adjusted p-value") |
| 95 | +#' ) %>% |
| 96 | +#' kableExtra::kable_styling(bootstrap_options = c("striped", "hover")) |
| 97 | +#' |
| 98 | +#' html_parts$pairwise <- pair_table |
| 99 | +#' } |
| 100 | +#' |
| 101 | +#' # Combine results based on what's available |
| 102 | +#' if(length(html_parts) == 2) { |
| 103 | +#' # Both analyses |
| 104 | +#' html_output <- paste0( |
| 105 | +#' '<div class="posthoc-analyses">', |
| 106 | +#' '<div class="residuals-section">', |
| 107 | +#' html_parts$residuals, |
| 108 | +#' '</div><br><br>', |
| 109 | +#' '<div class="pairwise-section">', |
| 110 | +#' html_parts$pairwise, |
| 111 | +#' '</div>', |
| 112 | +#' '</div>' |
| 113 | +#' ) |
| 114 | +#' } else { |
| 115 | +#' # Single analysis |
| 116 | +#' html_output <- paste0( |
| 117 | +#' '<div class="posthoc-analyses">', |
| 118 | +#' html_parts[[1]], |
| 119 | +#' '</div>' |
| 120 | +#' ) |
| 121 | +#' } |
| 122 | +#' |
| 123 | +#' return(html_output) |
| 124 | +#' } |
0 commit comments