From a3ece632b039a7a8fa61e6fb0b006a181fd732c8 Mon Sep 17 00:00:00 2001 From: Lejing Li Date: Thu, 29 Jan 2026 01:03:59 +0800 Subject: [PATCH 01/68] update stan and plot --- R/plot.R | 952 ++++++++++++++++++------- inst/stan/glm_multi_beta_binomial.stan | 391 +++++----- 2 files changed, 907 insertions(+), 436 deletions(-) diff --git a/R/plot.R b/R/plot.R index f0e15331..0747658f 100644 --- a/R/plot.R +++ b/R/plot.R @@ -2,22 +2,18 @@ #' #' @description This function plots a summary of the results of the model. #' -#' @importFrom ggrepel geom_text_repel -#' @importFrom tidyr pivot_longer -#' @import ggplot2 -#' @importFrom tidyr unite -#' @importFrom tidyr pivot_longer -#' @importFrom dplyr with_groups +#' @importFrom dplyr filter select #' @importFrom magrittr equals #' #' @param x A tibble including a cell_group name column | sample name column | read counts column | factor columns | Pvalue column | a significance column -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.025. +#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.05. #' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. -#' @param ... For internal use +#' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels in 2D intervals. Default is TRUE. +#' @param ... For internal use #' -#' @return A `ggplot` +#' @return A list containing ggplot objects #' #' @references #' S. Mangiola, A.J. Roth-Schulze, M. Trussart, E. Zozaya-Valdés, M. Ma, Z. Gao, A.F. Rubin, T.P. Speed, H. Shim, & A.T. Papenfuss, sccomp: Robust differential composition and variability analysis for single-cell data, Proc. Natl. Acad. Sci. U.S.A. 120 (33) e2203828120, https://doi.org/10.1073/pnas.2203828120 (2023). @@ -38,31 +34,36 @@ #' counts_obj, #' ~ type, ~1, "sample", "cell_group", "count", #' cores = 1 -#' ) +#' ) |> +#' sccomp_test() #' -#' # estimate |> plot() +#' plots = estimate |> plot() #' } #' } #' -plot.sccomp_tbl <- function(x, significance_threshold = 0.05, test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), significance_statistic = c("pH0", "FDR"), show_fdr_message = TRUE, ...) { - +plot.sccomp_tbl <- function( + x, + significance_threshold = 0.05, + test_composition_above_logit_fold_change = x |> attr("test_composition_above_logit_fold_change"), + significance_statistic = c("pH0", "FDR"), + show_fdr_message = TRUE, + add_marginal_density = TRUE, + sort_by = c("none", "effect", "significance", "alphabetical"), + ... +) { + significance_statistic <- match.arg(significance_statistic) - + sort_by <- match.arg(sort_by) + # Define the variables as NULL to avoid CRAN NOTES - parameter <- NULL - count_data <- x |> attr("count_data") v_effect <- NULL - - .cell_group = attr(x, ".cell_group") - .count = attr(x, ".count") - .sample = attr(x, ".sample") - + plots = list() - + # Check if test have been done if(x |> select(ends_with("FDR")) |> ncol() |> equals(0)) stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") - + data_proportion = x |> @@ -133,24 +134,31 @@ plot.sccomp_tbl <- function(x, significance_threshold = 0.05, test_composition_ } + # 1D intervals plots$credible_intervals_1D = plot_1D_intervals( - .data = x, + .data = x, significance_threshold = significance_threshold, + test_composition_above_logit_fold_change = test_composition_above_logit_fold_change, significance_statistic = significance_statistic, - show_fdr_message = show_fdr_message + show_fdr_message = show_fdr_message, + sort_by = sort_by ) - - # 2D intervals - if("v_effect" %in% colnames(x) && (x |> filter(!is.na(v_effect)) |> nrow()) > 0) plots$credible_intervals_2D = plot_2D_intervals( - .data = x, - significance_threshold = significance_threshold, - significance_statistic = significance_statistic, - show_fdr_message = show_fdr_message - ) - + + # 2D intervals (only if variance effects exist) + if("v_effect" %in% colnames(x) && (x |> filter(!is.na(v_effect)) |> nrow()) > 0) { + plots$credible_intervals_2D = plot_2D_intervals( + .data = x, + significance_threshold = significance_threshold, + test_composition_above_logit_fold_change = test_composition_above_logit_fold_change, + significance_statistic = significance_statistic, + show_fdr_message = show_fdr_message, + add_marginal_density = add_marginal_density + ) + } + plots - + } #' Plot 1D Intervals for Cell-group Effects @@ -158,21 +166,22 @@ plot.sccomp_tbl <- function(x, significance_threshold = 0.05, test_composition_ #' This function creates a series of 1D interval plots for cell-group effects, highlighting significant differences based on a given significance threshold. #' #' @param .data Data frame containing the main data. -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. +#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. #' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". +#' @param sort_by Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical". #' @importFrom patchwork wrap_plots #' @importFrom forcats fct_reorder #' @importFrom tidyr drop_na -#' +#' #' @export -#' +#' #' @return A combined plot of 1D interval plots. #' @examples -#' +#' #' print("cmdstanr is needed to run this example.") -#' +#' #' \donttest{ #' if (instantiate::stan_cmdstan_exists()) { #' data("counts_obj") @@ -185,71 +194,92 @@ plot.sccomp_tbl <- function(x, significance_threshold = 0.05, test_composition_ #' "cell_group", #' "count", #' cores = 1 -#' ) |> +#' ) |> #' sccomp_test() -#' +#' #' # Example usage: -#' my_plot = plot_1D_intervals(estimate) -#' +#' my_plot = plot_1D_intervals(estimate, sort_by = "effect") +#' #' } #' } #' -#' +#' plot_1D_intervals = function( - .data, - significance_threshold = 0.05, - test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), - show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR") + .data, + significance_threshold = 0.05, + test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), + show_fdr_message = TRUE, + significance_statistic = c("pH0", "FDR"), + sort_by = c("none", "effect", "significance", "alphabetical") ) { significance_statistic <- match.arg(significance_statistic) - + sort_by <- match.arg(sort_by) + # Define the variables as NULL to avoid CRAN NOTES parameter <- NULL estimate <- NULL value <- NULL pH0 <- NULL FDR <- NULL - + effect <- NULL + .cell_group = attr(.data, ".cell_group") - + # Check if test have been done if(.data |> select(ends_with("FDR")) |> ncol() |> equals(0)) stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") - - plot_list = + + plot_list = .data |> filter(parameter != "(Intercept)") |> - + # Reshape data - select(-contains("n_eff"), -contains("R_k_hat"), -contains("_ess"), -contains("_rhat")) |> + select(-contains("n_eff"), -contains("R_k_hat"), -contains("_ess"), -contains("_rhat")) |> pivot_longer(c(contains("c_"), contains("v_")), names_sep = "_", names_to = c("which", "estimate")) |> pivot_wider(names_from = estimate, values_from = value) |> - + # Nest data by parameter and which nest(data = -c(parameter, which)) |> mutate(plot = pmap( list(data, which, parameter), - ~ { - plot_data <- ..1 + function(plot_data, plot_which, plot_param) { # Check if there are any statistics to plot - if(plot_data |> filter(!effect |> is.na()) |> nrow() |> equals(0)) + if(plot_data |> filter(!is.na(effect)) |> nrow() |> equals(0)) return(NA) - + # Choose color variable and legend if (significance_statistic == "FDR") { - color_var <- plot_data$FDR < significance_threshold color_aes <- aes(xmin = lower, xmax = upper, color = FDR < significance_threshold) color_scale <- scale_color_manual(values = c("grey40", "red")) legend_title <- "FDR < significance_threshold" } else { - color_var <- plot_data$pH0 < significance_threshold color_aes <- aes(xmin = lower, xmax = upper, color = pH0 < significance_threshold) color_scale <- scale_color_manual(values = c("grey40", "red")) legend_title <- "pH0 < significance_threshold" } - - ggplot(plot_data, aes(x = effect, y = fct_reorder(!!.cell_group, effect))) + + + # Determine y-axis variable based on sort_by + # Use string-based column selection instead of NSE + if (sort_by == "none") { + # No sorting + plot_data$y_var <- plot_data[[.cell_group]] + } else if (sort_by == "effect") { + # Sort by absolute effect size + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], abs(plot_data$effect)) + } else if (sort_by == "significance") { + # Sort by significance + if (significance_statistic == "FDR") { + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$FDR, .desc = TRUE) + } else { + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$pH0, .desc = TRUE) + } + } else if (sort_by == "alphabetical") { + # Alphabetical sorting + plot_data <- plot_data %>% arrange(.data[[.cell_group]]) + plot_data$y_var <- fct_inorder(plot_data[[.cell_group]]) + } + + ggplot(plot_data, aes(x = effect, y = y_var)) + geom_vline(xintercept = test_composition_above_logit_fold_change, colour = "grey") + geom_vline(xintercept = -test_composition_above_logit_fold_change, colour = "grey") + geom_errorbar(color_aes) + @@ -257,17 +287,17 @@ plot_1D_intervals = function( color_scale + xlab("Credible interval of the slope") + ylab("Cell group") + - ggtitle(sprintf("%s %s", ..2, ..3)) + + ggtitle(sprintf("%s %s", plot_which, plot_param)) + sccomp_theme() + theme(legend.position = "bottom") + guides(color = guide_legend(title = legend_title)) } )) %>% - + # Filter out NA plots - filter(!plot |> is.na()) |> - pull(plot) - + filter(!is.na(plot)) |> + pull(plot) + # Combine all individual plots into one plot combined_plot <- plot_list |> wrap_plots(ncol = plot_list |> length() |> sqrt() |> ceiling()) @@ -287,34 +317,33 @@ plot_1D_intervals = function( combined_plot } - #' Plot 2D Intervals for Mean-Variance Association #' -#' This function creates a 2D interval plot for mean-variance association, highlighting significant differences based on a given significance threshold. +#' This function creates a 2D interval plot for mean-variance association, handling both single and bimodal models. +#' It highlights significant differences based on a given significance threshold. #' #' @param .data Data frame containing the main data. -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.025. -#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. +#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.05. +#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". -#' -#' -#' @importFrom dplyr filter arrange mutate if_else row_number -#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point annotate aes facet_wrap +#' @param model_type Character indicating "single" or "bimodal" model type. If NULL, will be auto-detected from prec_coeff dimensions. +#' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. +#' +#' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups +#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point geom_line geom_area aes facet_wrap theme_bw theme labs guides guide_legend scale_color_manual scale_alpha_manual scale_fill_manual scale_y_continuous coord_flip theme_void element_rect element_text margin #' @importFrom ggrepel geom_text_repel -#' @importFrom scales trans_new -#' @importFrom stringr str_replace -#' @importFrom stats quantile -#' @importFrom magrittr equals -#' +#' @importFrom stringr str_detect +#' @importFrom patchwork plot_annotation wrap_plots plot_layout +#' #' @export -#' +#' #' @return A ggplot object representing the 2D interval plot. -#' +#' #' @examples -#' +#' #' print("cmdstanr is needed to run this example.") -#' +#' #' \donttest{ #' if (instantiate::stan_cmdstan_exists()) { #' data("counts_obj") @@ -326,27 +355,31 @@ plot_1D_intervals = function( #' "sample", #' "cell_group", #' "count", -#' cores = 1 -#' ) |> +#' cores = 1, +#' bimodal_mean_variability_association = TRUE +#' ) |> #' sccomp_test() -#' -#' # Example usage: -#' my_plot = plot_2D_intervals(estimate) -#' +#' +#' # Example usage: +#' my_plot = plot_2D_intervals(estimate) +#' #' } #' } -#' -plot_2D_intervals = function( - .data, - significance_threshold = 0.05, - test_composition_above_logit_fold_change = +#' +plot_2D_intervals <- function( + .data, + significance_threshold = 0.05, + test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR") -){ + significance_statistic = c("pH0", "FDR"), + model_type = NULL, + add_marginal_density = TRUE +) { + significance_statistic <- match.arg(significance_statistic) - - # Define the variables as NULL to avoid CRAN NOTES + + # Define variables to avoid CRAN NOTES v_effect <- NULL parameter <- NULL c_effect <- NULL @@ -359,159 +392,302 @@ plot_2D_intervals = function( cell_type_label <- NULL pH0 <- NULL FDR <- NULL - - .cell_group = attr(.data, ".cell_group") - - # Check if test have been done - if(.data |> select(ends_with("FDR")) |> ncol() |> equals(0)) - stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") - - # Extract prec_coeff parameters from the fitted model for regression line - fit = attr(.data, "fit") - prec_coeff_summary = fit$summary("prec_coeff") - prec_coeff_intercept = prec_coeff_summary$mean[1] - prec_coeff_slope = prec_coeff_summary$mean[2] - - # Add adjusted intercept (unbiased variability) as a new facet - .data_adjusted <- .data %>% - filter(parameter == "(Intercept)") %>% - mutate( - v_effect = v_effect + prec_coeff_slope * c_effect, - v_lower = v_lower + prec_coeff_slope * c_effect, - v_upper = v_upper + prec_coeff_slope * c_effect, - parameter = "(Intercept, adjusted)" - ) - - # Bind adjusted data to original (uncorrected comes first) + c_pH0 <- NULL + v_pH0 <- NULL + component <- NULL + assigned_component <- NULL + + .cell_group <- attr(.data, ".cell_group") + + # Check if test has been done + if(.data |> select(ends_with("FDR")) |> ncol() == 0) + stop("sccomp says: you need to run sccomp_test() first.") + + # Extract fitted model and prec_coeff + fit <- attr(.data, "fit") + prec_coeff_summary <- fit$summary("prec_coeff") + + # Get number of parameters (effects) + n_params <- .data |> + filter(!is.na(v_effect)) |> + distinct(parameter) |> + nrow() + + # Auto-detect model type if not specified + if (is.null(model_type)) { + n_prec_coeff <- nrow(prec_coeff_summary) + if (n_prec_coeff == 2 * n_params) { + model_type <- "single" + } else if (n_prec_coeff == 4 * n_params) { + model_type <- "bimodal" + } else { + stop("Cannot auto-detect model type from prec_coeff dimensions") + } + } + + # Extract parameters based on model type + if (model_type == "single") { + params_list <- lapply(1:n_params, function(a) { + param_name <- .data |> + filter(!is.na(v_effect)) |> + distinct(parameter) |> + slice(a) |> + pull(parameter) + intercept_idx <- 2 * (a - 1) + 1 + slope_idx <- 2 * (a - 1) + 2 + list( + parameter = param_name, + intercept = prec_coeff_summary$mean[intercept_idx], + slope = prec_coeff_summary$mean[slope_idx] + ) + }) + + cat("=== Single Model Parameters ===\n") + for(i in 1:length(params_list)) { + p <- params_list[[i]] + cat(sprintf("\n%s:\n", p$parameter)) + cat(sprintf(" v = -(%.3f + %.3f × c)\n", p$intercept, p$slope)) + } + cat("\n") + + } else { + mix_p <- fit$summary("mix_p") |> pull(mean) + + params_list <- lapply(1:n_params, function(a) { + param_name <- .data |> + filter(!is.na(v_effect)) |> + distinct(parameter) |> + slice(a) |> + pull(parameter) + + list( + parameter = param_name, + intercept_1 = prec_coeff_summary$mean[1 + (a-1)*4], + slope_1 = prec_coeff_summary$mean[2 + (a-1)*4], + slope_2 = prec_coeff_summary$mean[3 + (a-1)*4], + intercept_2 = prec_coeff_summary$mean[4 + (a-1)*4] + ) + }) + + cat("=== Bimodal Model Parameters ===\n") + for(i in 1:length(params_list)) { + p <- params_list[[i]] + cat(sprintf("\n%s:\n", p$parameter)) + cat(sprintf(" Component 1: v = -(%.3f + %.3f × c)\n", p$intercept_1, p$slope_1)) + cat(sprintf(" Component 2: v = -(%.3f + %.3f × c)\n", p$intercept_2, p$slope_2)) + } + cat("\n") + } + + # Create adjusted data based on model type + if (model_type == "single") { + .data_adjusted_list <- lapply(params_list, function(params) { + param_data <- .data %>% + filter(parameter == params$parameter) + + param_data_adjusted <- param_data %>% + mutate( + v_effect = v_effect + params$slope * c_effect, + v_lower = v_lower + params$slope * c_effect, + v_upper = v_upper + params$slope * c_effect, + parameter = paste0(params$parameter, ", adjusted") + ) + + return(param_data_adjusted) + }) + } else { + .data_adjusted_list <- lapply(params_list, function(params) { + param_data <- .data %>% + filter(parameter == params$parameter) + + param_data_adjusted <- param_data %>% + rowwise() %>% + mutate( + residual_comp1 = abs(v_effect - (-(params$intercept_1 + params$slope_1 * c_effect))), + residual_comp2 = abs(v_effect - (-(params$intercept_2 + params$slope_2 * c_effect))), + assigned_component = if_else(residual_comp1 < residual_comp2, 1, 2), + slope_to_use = if_else(assigned_component == 1, params$slope_1, params$slope_2), + v_effect = v_effect + slope_to_use * c_effect, + v_lower = v_lower + slope_to_use * c_effect, + v_upper = v_upper + slope_to_use * c_effect, + parameter = paste0(params$parameter, ", adjusted") + ) %>% + ungroup() %>% + select(-residual_comp1, -residual_comp2, -slope_to_use) + + return(param_data_adjusted) + }) + } + + .data_adjusted <- bind_rows(.data_adjusted_list) .data_plot <- bind_rows(.data, .data_adjusted) - - # Always set parameter factor levels to only those present in the data - if ("parameter" %in% colnames(.data_plot)) { - .data_plot$parameter <- factor(.data_plot$parameter, levels = unique(.data_plot$parameter)) + + # Set parameter factor levels + param_order <- c() + for(p in params_list) { + param_order <- c(param_order, p$parameter, paste0(p$parameter, ", adjusted")) } - # Use .data_plot instead of .data in the rest of the function - plot <- .data_plot %>% - # Filter where variance is inferred + .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) + + # Add labels for significant cell groups + .data_plot <- .data_plot %>% filter(!is.na(v_effect)) %>% - - # Add labels for significant cell groups with_groups( parameter, ~ .x %>% arrange(c_FDR) %>% - mutate(cell_type_label = if_else(row_number() <= 3 & c_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)"), !!.cell_group, "")) + mutate( + cell_type_label = if_else( + row_number() <= 3 & + c_FDR < significance_threshold & + !str_detect(parameter, "adjusted"), + !!sym(.cell_group), + "" + ) + ) ) %>% with_groups( parameter, ~ .x %>% arrange(v_FDR) %>% - mutate(cell_type_label = if_else((row_number() <= 3 & v_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)") ), !!.cell_group, cell_type_label)) - ) %>% - { - .x = (.) - - # Choose color variable and legend - if (significance_statistic == "FDR") { - color_c_aes <- aes(xmin = c_lower, xmax = c_upper, color = c_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)"), alpha = c_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)")) - color_v_aes <- aes(ymin = v_lower, ymax = v_upper, color = v_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)"), alpha = v_FDR < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)")) - color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) - alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) - legend_title <- "FDR < significance_threshold" - } else { - color_c_aes <- aes(xmin = c_lower, xmax = c_upper, color = c_pH0 < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)"), alpha = c_pH0 < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)")) - color_v_aes <- aes(ymin = v_lower, ymax = v_upper, color = v_pH0 < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)"), alpha = v_pH0 < significance_threshold & !parameter %in% c("(Intercept)", "(Intercept, adjusted)")) - color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) - alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) - legend_title <- "pH0 < significance_threshold" - } - - # Calculate range for regression line - c_range = range(.x$c_effect, na.rm = TRUE) - c_seq = seq(c_range[1], c_range[2], length.out = 100) - v_pred = -(prec_coeff_intercept + prec_coeff_slope * c_seq) - - # Create regression line data only for (Intercept) - regression_data = data.frame( + mutate( + cell_type_label = if_else( + row_number() <= 3 & + v_FDR < significance_threshold & + !str_detect(parameter, "adjusted") & + cell_type_label == "", + !!sym(.cell_group), + cell_type_label + ) + ) + ) + + # Choose color aesthetics based on significance statistic + if (significance_statistic == "FDR") { + color_c_aes <- aes( + xmin = c_lower, xmax = c_upper, + color = c_FDR < significance_threshold & str_detect(parameter, "adjusted"), + alpha = c_FDR < significance_threshold & str_detect(parameter, "adjusted") + ) + color_v_aes <- aes( + ymin = v_lower, ymax = v_upper, + color = v_FDR < significance_threshold & str_detect(parameter, "adjusted"), + alpha = v_FDR < significance_threshold & str_detect(parameter, "adjusted") + ) + color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) + alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) + legend_title <- "FDR < significance_threshold" + } else { + color_c_aes <- aes( + xmin = c_lower, xmax = c_upper, + color = c_pH0 < significance_threshold & !str_detect(parameter, "adjusted"), + alpha = c_pH0 < significance_threshold & !str_detect(parameter, "adjusted") + ) + color_v_aes <- aes( + ymin = v_lower, ymax = v_upper, + color = v_pH0 < significance_threshold & !str_detect(parameter, "adjusted"), + alpha = v_pH0 < significance_threshold & !str_detect(parameter, "adjusted") + ) + color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) + alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) + legend_title <- "pH0 < significance_threshold" + } + + # Prepare regression line data based on model type + if (model_type == "single") { + regression_data_all <- lapply(params_list, function(params) { + param_data <- .data_plot %>% filter(parameter == params$parameter) + if(nrow(param_data) == 0) return(NULL) + + c_range <- range(param_data$c_effect, na.rm = TRUE) + c_seq <- seq(c_range[1], c_range[2], length.out = 100) + v_pred <- -(params$intercept + params$slope * c_seq) + + data.frame( c_effect = c_seq, v_effect = v_pred, - parameter = "(Intercept)" + parameter = params$parameter, + stringsAsFactors = FALSE ) - - # Plot - p <- ggplot(.x, aes(c_effect, v_effect)) + - # Add vertical and horizontal lines - geom_vline(xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), colour = "grey", linetype = "dashed", linewidth = 0.3) + - geom_hline(yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), colour = "grey", linetype = "dashed", linewidth = 0.3) - - # Add regression line only for (Intercept) facet - p <- p + geom_line( - data = regression_data, - mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, - inherit.aes = FALSE + }) %>% bind_rows() + + adjusted_lines_all <- lapply(params_list, function(params) { + adj_param <- paste0(params$parameter, ", adjusted") + adj_data <- .data_plot %>% filter(parameter == adj_param) + if(nrow(adj_data) == 0) return(NULL) + + c_range_adj <- range(adj_data$c_effect, na.rm = TRUE) + mean_adj <- mean(adj_data$v_effect, na.rm = TRUE) + + data.frame( + c_effect = c_range_adj, + v_effect = rep(mean_adj, 2), + parameter = adj_param, + stringsAsFactors = FALSE ) + }) %>% bind_rows() + + caption_text <- paste( + "Single model with parameter-specific slopes", + "\nBlue line shows mean-variability relationship for each parameter", + "\n'Adjusted' panels show variability after removing parameter-specific mean-variability association", + "\nMarginal density shows posterior distribution of variability intercept parameters", + "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", + sep = "" + ) - # Add horizontal line for (Intercept, adjusted) facet - if ("(Intercept, adjusted)" %in% unique(.x$parameter)) { - mean_adjusted <- mean(.x$v_effect[.x$parameter == "(Intercept, adjusted)"]) - c_range_adjusted <- range(.x$c_effect[.x$parameter == "(Intercept, adjusted)"], na.rm = TRUE) - - # Create horizontal line data for adjusted intercept only - horizontal_line_data <- data.frame( - c_effect = c_range_adjusted, - v_effect = rep(mean_adjusted, 2), - parameter = "(Intercept, adjusted)" + } else { + regression_data_all <- lapply(params_list, function(params) { + param_data <- .data_plot %>% filter(parameter == params$parameter) + if(nrow(param_data) == 0) return(NULL) + + c_range <- range(param_data$c_effect, na.rm = TRUE) + c_seq <- seq(c_range[1], c_range[2], length.out = 100) + + v_pred_1 <- -(params$intercept_1 + params$slope_1 * c_seq) + v_pred_2 <- -(params$intercept_2 + params$slope_2 * c_seq) + + bind_rows( + data.frame( + c_effect = c_seq, v_effect = v_pred_1, + parameter = params$parameter, component = "Component 1" + ), + data.frame( + c_effect = c_seq, v_effect = v_pred_2, + parameter = params$parameter, component = "Component 2" ) - - p <- p + - geom_line( - data = horizontal_line_data, - mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, - inherit.aes = FALSE - ) - } + ) + }) %>% bind_rows() + + adjusted_lines_all <- lapply(params_list, function(params) { + adj_param <- paste0(params$parameter, ", adjusted") + c_range_adj <- range(.data_plot$c_effect[.data_plot$parameter == adj_param], na.rm = TRUE) + + bind_rows( + data.frame( + c_effect = c_range_adj, v_effect = rep(-params$intercept_1, 2), + parameter = adj_param, component = "Component 1" + ), + data.frame( + c_effect = c_range_adj, v_effect = rep(-params$intercept_2, 2), + parameter = adj_param, component = "Component 2" + ) + ) + }) %>% bind_rows() - p <- p + - # Add error bars - geom_errorbar(color_c_aes, linewidth = 0.2) + - geom_errorbar(color_v_aes, linewidth = 0.2) + - # Add points - geom_point(size = 0.2) + - # Add annotations - # annotate("text", x = 0, y = 3.5, label = "Variability", size = 2) + # Disabled temporarily; revisit if annotations are needed for variability. - # annotate("text", x = 5, y = 0, label = "Abundance", size = 2, angle = 270) + # Disabled temporarily; revisit if annotations are needed for abundance. - # Add text labels for significant cell groups - geom_text_repel(aes(c_effect, -v_effect, label = cell_type_label), size = 2.5, data = .x %>% filter(cell_type_label != "")) + - # Set color and alpha scales - color_scale + - alpha_scale + - # Facet by parameter - facet_wrap( - ~ fct_relevel(parameter, c("(Intercept)", "(Intercept, adjusted)")) |> - - # I have to understand why this works but throws warning - suppressWarnings(), - scales = "free" - ) + - xlab("c_effect (Abundance effect)") + - ylab("v_effect (Variability effect)") + - # Apply custom theme - sccomp_theme() + - theme(legend.position = "bottom") + - guides(color = guide_legend(title = legend_title), alpha = "none") - p - } + caption_text <- paste( + sprintf("Bimodal model: mix_p = %.3f (Component 1 weight)", mix_p), + "\nSolid blue line = Component 1 | Dashed orange line = Component 2", + "\n'Adjusted' panels show variability after removing mean-variability association", + "\nMarginal density shows posterior distribution of variability intercept parameters", + "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", + sep = "") + } - # Only show the FDR message if significance_statistic == "FDR" and show_fdr_message is TRUE + # Add caption based on model type if (significance_statistic == "FDR" && show_fdr_message) { - caption_text <- paste( - "Bayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", - "\nFDR-significant populations may cross fold change thresholds because Bayesian FDR considers posterior probabilities rather than p-values.", - "\nThe method sorts null hypothesis probabilities in ascending order and calculates cumulative averages for robust false discovery control.", - sep = "" - ) + plot <- plot + ggplot2::labs(caption = caption_text) plot <- plot + theme(plot.caption = ggplot2::element_text(hjust = 0)) } @@ -664,45 +840,277 @@ plot_scatterplot = function( color = "black", span = 1 ) + } } else { - my_scatterplot= - my_scatterplot + - - # Add smoothed line with significance colors - geom_smooth( - aes(!!as.symbol(factor_of_interest), proportion, fill = name), - data = data_proportion , - fatten = 0.5, - lwd=0.5, - color = "black", - span = 1 + caption_text <- NULL + } + + # Add marginal density plots if requested + if (add_marginal_density) { + + plot_list <- lapply(param_order, function(param) { + + param_data <- .data_plot %>% filter(parameter == param) + if(nrow(param_data) == 0) return(NULL) + + # Create main plot + p_param <- ggplot(param_data, aes(c_effect, v_effect)) + + geom_vline( + xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + geom_hline( + yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + # Add regression lines + if (model_type == "single") { + reg_data <- regression_data_all %>% filter(parameter == param) + if(!is.null(reg_data) && nrow(reg_data) > 0) { + p_param <- p_param + + geom_line(data = reg_data, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + + adj_line <- adjusted_lines_all %>% filter(parameter == param) + if(!is.null(adj_line) && nrow(adj_line) > 0) { + p_param <- p_param + + geom_line(data = adj_line, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + + } else { + reg_data <- regression_data_all %>% filter(parameter == param) + if(!is.null(reg_data) && nrow(reg_data) > 0) { + p_param <- p_param + + geom_line(data = reg_data %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = reg_data %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + + adj_line <- adjusted_lines_all %>% filter(parameter == param) + if(!is.null(adj_line) && nrow(adj_line) > 0) { + p_param <- p_param + + geom_line(data = adj_line %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = adj_line %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + } + + # Add error bars, points, and labels + p_param <- p_param + + geom_errorbar(color_c_aes, linewidth = 0.2) + + geom_errorbar(color_v_aes, linewidth = 0.2) + + geom_point(size = 0.2) + + geom_text_repel( + aes(c_effect, -v_effect, label = cell_type_label), + size = 2.5, + data = param_data %>% filter(cell_type_label != ""), + max.overlaps = 20 + ) + + color_scale + + alpha_scale + + xlab("c_effect (Abundance effect)") + + ylab("v_effect (Variability effect)") + + ggtitle(param) + + theme_bw() + + theme( + legend.position = "bottom", + strip.background = element_rect(fill = "white"), + panel.grid.minor = element_blank() + ) + + guides(color = guide_legend(title = legend_title), alpha = "none") + + # Add marginal density for adjusted panels (not Intercept) + if (str_detect(param, "adjusted") && !str_detect(param, "Intercept")) { + + if (model_type == "single") { + param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) + + if (length(param_idx) > 0) { + intercept_var_name <- paste0("prec_coeff[1,", param_idx, "]") + + tryCatch({ + intercept_draws <- fit$draws(variables = intercept_var_name, format = "draws_df") + intercept_values <- as.vector(intercept_draws[[intercept_var_name]]) + + dens <- density(-intercept_values, na.rm = TRUE) + dens_df <- data.frame(x = dens$x, y = dens$y) + + + y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range + + p_density <- ggplot(dens_df, aes(x = x, y = y)) + + geom_area(alpha = 0.5, position = "identity") + + geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + + coord_flip(xlim = y_range) + + scale_y_continuous(expand = c(0, 0)) + + xlab("Posterior Probability") + + theme_void() + + theme( + plot.margin = margin(t = 0, r = 0, b = 0, l = 6), + axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) + ) + + p_combined <- p_param + p_density + + plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & + theme(legend.position = "bottom") + + return(p_combined) + }, error = function(e) { + warning(sprintf("Could not extract intercept draws for %s: %s", intercept_var_name, e$message)) + return(p_param) + }) + } + + } else { + param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) + + if (length(param_idx) > 0) { + intercept1_var_name <- paste0("prec_coeff[1,", param_idx, "]") + intercept2_var_name <- paste0("prec_coeff[4,", param_idx, "]") + + tryCatch({ + intercept1_draws <- fit$draws(variables = intercept1_var_name, format = "draws_df") + intercept2_draws <- fit$draws(variables = intercept2_var_name, format = "draws_df") + + intercept1_values <- as.vector(intercept1_draws[[intercept1_var_name]]) + intercept2_values <- as.vector(intercept2_draws[[intercept2_var_name]]) + + dens1 <- density(-intercept1_values, na.rm = TRUE) + dens2 <- density(-intercept2_values, na.rm = TRUE) + + dens_df <- bind_rows( + data.frame(x = dens1$x, y = dens1$y, component = "Component 1"), + data.frame(x = dens2$x, y = dens2$y, component = "Component 2") + ) + + + y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range + + p_density <- ggplot(dens_df, aes(x = x, y = y, fill = component)) + + geom_area(alpha = 0.5, position = "identity") + + geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + + scale_fill_manual(values = c("Component 1" = "#0072B2", "Component 2" = "#D55E00")) + + coord_flip(xlim = y_range) + + scale_y_continuous(expand = c(0, 0)) + + xlab("Posterior Probability") + + theme_void() + + theme( + plot.margin = margin(t = 0, r = 0, b = 0, l = 5), + legend.position = "none", + axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) + ) + + p_combined <- p_param + p_density + + plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & + theme(legend.position = "bottom") + + return(p_combined) + }, error = function(e) { + warning(sprintf("Could not extract intercept draws: %s", e$message)) + return(p_param) + }) + } + } + } + + return(p_param) + }) + + + plot_list <- plot_list[!sapply(plot_list, is.null)] + combined_plot <- patchwork::wrap_plots(plot_list, ncol = 2) + + if (!is.null(caption_text)) { + combined_plot <- combined_plot + + plot_annotation( + caption = caption_text, + theme = theme(plot.caption = element_text(hjust = 0, size = 9)) + ) + } + + return(combined_plot) + + } else { + # Return faceted plot without marginal densities + p <- ggplot(.data_plot, aes(c_effect, v_effect)) + + geom_vline( + xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + geom_hline( + yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 ) + + # Add regression lines + if (model_type == "single") { + if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { + p <- p + geom_line(data = regression_data_all, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { + p <- p + geom_line(data = adjusted_lines_all, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + } else { + if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { + p <- p + + geom_line(data = regression_data_all %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = regression_data_all %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { + p <- p + + geom_line(data = adjusted_lines_all %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = adjusted_lines_all %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + } + + p <- p + + geom_errorbar(color_c_aes, linewidth = 0.2) + + geom_errorbar(color_v_aes, linewidth = 0.2) + + geom_point(size = 0.2) + + geom_text_repel( + aes(c_effect, -v_effect, label = cell_type_label), + size = 2.5, + data = .data_plot %>% filter(cell_type_label != ""), + max.overlaps = 20 + ) + + color_scale + + alpha_scale + + facet_wrap(~ parameter, scales = "free", ncol = 2) + + xlab("c_effect (Abundance effect)") + + ylab("v_effect (Variability effect)") + + theme_bw() + + theme( + legend.position = "bottom", + strip.background = element_rect(fill = "white"), + panel.grid.minor = element_blank() + ) + + guides(color = guide_legend(title = legend_title), alpha = "none") + + if (!is.null(caption_text)) { + p <- p + + theme(plot.caption = element_text(hjust = 0, size = 9)) + + labs(caption = caption_text) + } + + return(p) } - - my_scatterplot + - - # Add jittered points for individual data - geom_point( - aes(!!as.symbol(factor_of_interest), proportion, shape=outlier, color=outlier), - data = data_proportion, - position=position_jitterdodge(jitter.height = 0, jitter.width = 0.2), - size = 0.5 - ) + - - # Facet wrap by cell group - facet_wrap( - vars(!!.cell_group), - scales = "free_y", - nrow = 4 - ) + - scale_color_manual(values = c("black", "#e11f28")) + - scale_y_continuous(trans=S_sqrt_trans(), labels = dropLeadingZero) + - scale_fill_discrete(na.value = "white") + - xlab("Biological condition") + - ylab("Cell-group proportion") + - guides(color="none", alpha="none", size="none") + - labs(fill="Significant difference") + - ggtitle("Note: Be careful judging significance (or outliers) visually for lowly abundant cell groups. \nVisualising proportion hides the uncertainty characteristic of count data, that a count-based statistical model can estimate.") + - my_theme + - theme(axis.text.x = element_text(angle=20, hjust = 1), title = element_text(size = 3)) } diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 3d16fa36..3084660a 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -1,9 +1,9 @@ functions{ - + #include common_functions.stan - + array[] int rep_each(array[] int x, int K) { int N = size(x); array[N * K] int y; @@ -16,75 +16,81 @@ functions{ } return y; } - - - real abundance_variability_regression(row_vector variability, row_vector abundance, array[] real prec_coeff, real prec_sd, int bimodal_mean_variability_association, real mix_p){ - + + + real abundance_variability_regression(row_vector variability, row_vector abundance, array[] real prec_coeff, real prec_sd_1, real prec_sd_2, int bimodal_mean_variability_association, real mix_p){ + real lp = 0; + int nu = 3; // df // If mean-variability association is bimodal such as for single-cell RNA use mixed model if(bimodal_mean_variability_association == 1){ for(m in 1:cols(variability)) lp += log_mix(mix_p, - normal_lpdf(variability[m] | abundance[m] * prec_coeff[2] + prec_coeff[1], prec_sd ), - normal_lpdf(variability[m] | abundance[m] * prec_coeff[2] + 1, prec_sd) // -0.73074903 is what we observe in single-cell dataset Therefore it is safe to fix it for this mixture model as it just want to capture few possible outlier in the association + student_t_lpdf(variability[m] | nu, + abundance[m] * prec_coeff[2] + prec_coeff[1], + prec_sd_1), // c1 + student_t_lpdf(variability[m] | nu, + abundance[m] * prec_coeff[3] + prec_coeff[4], + prec_sd_2) // c2 // -0.73074903 is what we observe in single-cell dataset Therefore it is safe to fix it for this mixture model as it just want to capture few possible outlier in the association ); - + // If no bimodal } else { - lp = normal_lpdf(variability | abundance * prec_coeff[2] + prec_coeff[1], prec_sd ); + lp = student_t_lpdf(variability | nu, + abundance * prec_coeff[2] + prec_coeff[1], prec_sd_1); } - + return(lp); } - + real partial_sum_2_lpmf( // Parallel array[] int idx_y, int start, int end, - + // General int is_proportion, array[,] int y, array[,] real y_proportion, array[] int exposure, // Sliced - + // Precision matrix Xa, // Sliced matrix alpha, - + // Fixed effects matrix X, // Sliced - matrix beta, - int M, - + matrix beta, + int M, + // Random effects array[] int ncol_X_random_eff, matrix X_random_effect, // Sliced matrix X_random_effect_2, // Sliced matrix random_effect, matrix random_effect_2, - + // truncation array[,] int truncation_not_idx_minimal - + ){ - + int N = end-start+1; - + // mu matrix[M, N] mu = (X[idx_y,] * beta)'; if(ncol_X_random_eff[1]> 0) mu = mu + (X_random_effect[idx_y,] * random_effect)'; - + if(ncol_X_random_eff[2]>0 ) mu = mu + (X_random_effect_2[idx_y,] * random_effect_2)'; - + for(n in 1:N) mu[,n] = softmax(mu[,n]); - + // Precision matrix[M, N] precision = (Xa[idx_y,] * alpha)'; - + // vectorisation vector[N*M] mu_array = to_vector(mu); vector[N*M] precision_array = to_vector(exp(precision)); @@ -92,7 +98,7 @@ functions{ // truncation if(W == 0){ - + // If input is proportions if(is_proportion) return beta_lupdf( @@ -100,7 +106,7 @@ functions{ (mu_array .* precision_array), (1.0 - mu_array) .* precision_array ) ; - + // If input is counts else return beta_binomial_lupmf( @@ -109,16 +115,16 @@ functions{ (mu_array .* precision_array), (1.0 - mu_array) .* precision_array ) ; - + } else{ // If truncation is null for my chunk // Get non missing, invert the missing, this will be a big array - array[N * M - W] int non_missing_indices = + array[N * M - W] int non_missing_indices = get_non_missing_indices( - N, - M, + N, + M, filter_missing_indices(truncation_not_idx_minimal, idx_y) ); @@ -129,7 +135,7 @@ functions{ (mu_array[non_missing_indices] .* precision_array[non_missing_indices]), (1.0 - mu_array[non_missing_indices]) .* precision_array[non_missing_indices] ) ; - + // If input is counts else return beta_binomial_lupmf( @@ -140,10 +146,10 @@ functions{ ) ; } - + } - + /** * Counts the number of rows in missing_indices where the first column matches any value in idx_y. * @@ -158,7 +164,7 @@ functions{ int num_missing = dims(missing_indices)[1]; // Number of rows in missing_indices int num_idx_y = num_elements(idx_y); // Number of elements in idx_y int num_filtered = 0; // Initialize the count of filtered rows - + for (i in 1:num_missing) { for (j in 1:num_idx_y) { if (missing_indices[i, 1] == idx_y[j]) { @@ -167,10 +173,10 @@ functions{ } } } - + return num_filtered; } - + /** * Filters the missing_indices matrix to include only rows where the first column matches values in idx_y. * @@ -185,31 +191,31 @@ functions{ array[,] int filter_missing_indices(array[,] int missing_indices, array[] int idx_y) { int num_missing = dims(missing_indices)[1]; // Number of rows in missing_indices int num_idx_y = num_elements(idx_y); // Number of elements in idx_y - + // Use the count_filtered_indices function to get the number of filtered rows int num_filtered = count_filtered_indices(missing_indices, idx_y); - + // Allocate the output array with the determined size array[num_filtered, 2] int missing_indices_filtered; - + // Fill the output array with matching rows int count = 0; for (i in 1:num_missing) { for (j in 1:num_idx_y) { if (missing_indices[i, 1] == idx_y[j]) { count += 1; - + // Adjust the row index in the filtered array missing_indices_filtered[count, 1] = j; // Set to the relative position in idx_y missing_indices_filtered[count, 2] = missing_indices[i, 2]; // Keep the column index - + break; // Exit the inner loop once a match is found } } } - + return missing_indices_filtered; -} +} /** * Compute indices of non-missing elements in a matrix when flattened in column-major order. * (Existing function; included here for completeness) @@ -217,14 +223,14 @@ array[,] int filter_missing_indices(array[,] int missing_indices, array[] int id array[] int get_non_missing_indices(int n_rows, int n_cols, array[,] int missing_indices) { // Total number of elements in the matrix int N = n_rows * n_cols; - + // Number of missing elements int num_missing = dims(missing_indices)[1]; // Assuming missing_indices is [num_missing, 2] - + // Initialize a matrix to track missing data (0 = not missing, 1 = missing) array[n_rows, n_cols] int is_missing = rep_array(0, n_rows, n_cols); - - // + + // // Mark the missing positions in the is_missing matrix for (i in 1:num_missing) { int row = missing_indices[i, 1]; // Row index of missing element @@ -252,15 +258,13 @@ array[,] int filter_missing_indices(array[,] int missing_indices, array[] int id return non_missing_indices[1:count]; } - - } data{ int is_proportion; int N; int M; int C; - int A; // How many column in variability design\ + int A; // How many column in variability design int A_intercept_columns; // How many intercept column in varibility design int B_intercept_columns; // How many intercept column in varibility design int Ar; // Rows of unique variability design @@ -270,67 +274,67 @@ data{ matrix[N, C] X; matrix[Ar, A] XA; // The unique variability design matrix[N, A] Xa; // The variability design - + // Truncation int is_truncated; array[N,M] int truncation_up; array[N,M] int truncation_down; int TNS; // truncation_not_size array[TNS] int truncation_not_idx; - + int TNIM; // truncation_not_size array[TNIM,2] int truncation_not_idx_minimal; - + int is_vb; - + // Prior info array[2] real prior_prec_intercept; array[2] real prior_prec_slope; array[2] real prior_prec_sd; array[2] real prior_mean_intercept; array[2] real prior_mean_coefficients; - + // Exclude priors for testing purposes int exclude_priors; int bimodal_mean_variability_association; int use_data; - + // Parallel chain int grainsize; - + // Does the design icludes intercept int intercept_in_design; - + // Random intercept - + // Is the parameters in random effect matrix, minus ther sub to zero parameters, for example if I have four groups, this will be 3 int is_random_effect; - + // Is the parameters in random effect matrix array[2] int ncol_X_random_eff; matrix[N, ncol_X_random_eff[1]] X_random_effect; matrix[N, ncol_X_random_eff[2]] X_random_effect_2; - + // Covariance setup array[2] int n_groups; array[2] int how_many_factors_in_random_design; array[how_many_factors_in_random_design[1], n_groups[1]] int group_factor_indexes_for_covariance; array[how_many_factors_in_random_design[2], n_groups[2]] int group_factor_indexes_for_covariance_2; - + // LOO int enable_loo; - - + + } transformed data{ // EXCEPTION MADE FOR WINDOWS GENERATE QUANTITIES IF RANDOM EFFECT DO NOT EXIST int ncol_X_random_eff_WINDOWS_BUG_FIX = max(ncol_X_random_eff[1], 1); int ncol_X_random_eff_WINDOWS_BUG_FIX_2 = max(ncol_X_random_eff[2], 1); - + // For parallelisation array[N] int array_N; for(n in 1:N) array_N[n] = n; - + // Data vectorised // y_array = to_array_1d(y); // exposure_array = rep_each(exposure, M); @@ -340,65 +344,94 @@ parameters{ array[C] sum_to_zero_vector[M] beta_raw; // Each row is a sum_to_zero_vector of length M matrix[A, M] alpha; // Variability // To exclude - array[2] real prec_coeff; - real prec_sd; + // row 1: i1, row 2: s1, row 3: i2 + array[A * bimodal_mean_variability_association] ordered[2] intercept_pair; // i1, i2 + array[A * (1 - bimodal_mean_variability_association)] real intercept_single; + // Slopes: per-effect for bimodal, global for single + array[A * bimodal_mean_variability_association] real slope_1; + array[A * bimodal_mean_variability_association] real slope_2; + array[A * (1 - bimodal_mean_variability_association)] real slope_single; + real prec_sd_1; // c1 + array[bimodal_mean_variability_association] real prec_sd_2; // c2 real mix_p; - + // Random intercept // array of sum_to_zero_vector for each random effect array[ncol_X_random_eff[1] * (is_random_effect>0)] sum_to_zero_vector[M] random_effect_raw; array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] sum_to_zero_vector[M] random_effect_raw_2; - + // sd of random intercept array[2 * (is_random_effect>0)] real random_effect_sigma_mu; array[2 * (is_random_effect>0)] real random_effect_sigma_sigma; - + // Covariance array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma_raw; array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[1] * (is_random_effect>0)] sigma_correlation_factor; - + // Covariance array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_raw_2; array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[2] * (is_random_effect>0)] sigma_correlation_factor_2; - + // If I have just one group array[is_random_effect>0] real zero_random_effect; - - + + } transformed parameters{ - + // Initialisation matrix[C,M] beta; matrix[M, N] precision = (Xa * alpha)'; - + // Convert sum_to_zero_vector to regular matrix for(c in 1:C) { beta[c,] = to_row_vector(beta_raw[c]); } - + + // intercept_pair + slope_1/2 prec_coeff + matrix[bimodal_mean_variability_association == 1 ? 4 : 2, A] prec_coeff; + if(bimodal_mean_variability_association == 1){ + // Bimodal + for(a in 1:A){ + prec_coeff[1, a] = intercept_pair[a][1]; + prec_coeff[2, a] = slope_1[a]; + prec_coeff[3, a] = slope_2[a]; + prec_coeff[4, a] = intercept_pair[a][2]; + } +} else { + // Single + for(a in 1:A){ + prec_coeff[1, a] = intercept_single[a]; + prec_coeff[2, a] = slope_single[a]; // slope (global) + } +} + real prec_sd_2_scalar = bimodal_mean_variability_association == 1 ? prec_sd_2[1] : 0.0; + real mix_p_scalar = bimodal_mean_variability_association == 1 ? mix_p : 0.5; + // Non centered parameterisation SD of random effects array[M * (ncol_X_random_eff[1]> 0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma; if(ncol_X_random_eff[1]> 0) for(m in 1:(M)) random_effect_sigma[m] = random_effect_sigma_mu[1] + random_effect_sigma_sigma[1] * random_effect_sigma_raw[m]; if(ncol_X_random_eff[1]> 0) for(m in 1:(M)) random_effect_sigma[m] = exp(random_effect_sigma[m]/3.0); - + // Non centered parameterisation SD of random effects 2 array[M * (ncol_X_random_eff[2]> 0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_2; if(ncol_X_random_eff[2]> 0) for(m in 1:(M)) random_effect_sigma_2[m] = random_effect_sigma_mu[2] + random_effect_sigma_sigma[2] * random_effect_sigma_raw_2[m]; if(ncol_X_random_eff[2]> 0) for(m in 1:(M)) random_effect_sigma_2[m] = exp(random_effect_sigma_2[m]/3.0); - - - matrix[ncol_X_random_eff[1] * (is_random_effect>0), M] random_effect; - matrix[ncol_X_random_eff[2] * (is_random_effect>0), M] random_effect_2; - + + + // avoid 0 + matrix[ncol_X_random_eff_WINDOWS_BUG_FIX * (is_random_effect>0), M] random_effect; + matrix[ncol_X_random_eff_WINDOWS_BUG_FIX_2 * (is_random_effect>0), M] random_effect_2; + + // random intercept if(ncol_X_random_eff[1]> 0){ - + // Convert sum_to_zero_vector array to vector array for function call array[ncol_X_random_eff[1]] vector[M] random_effect_raw_vec; for(i in 1:ncol_X_random_eff[1]) { random_effect_raw_vec[i] = to_vector(random_effect_raw[i]); } - + // Covariate setup random_effect = get_random_effect_matrix( @@ -412,9 +445,9 @@ transformed parameters{ random_effect_sigma, sigma_correlation_factor ); - + } - + // random intercept if(ncol_X_random_eff[2]>0 ){ @@ -437,48 +470,44 @@ transformed parameters{ random_effect_sigma_2, sigma_correlation_factor_2 ); - } - } model{ - - // Fit main distribution if(use_data == 1){ - + target += reduce_sum( partial_sum_2_lupmf, array_N, grainsize, - + // General is_proportion, y, y_proportion, - exposure, - + exposure, + // Precision - Xa, + Xa, alpha, - + // Fixed effects - X, - beta, - M, - + X, + beta, + M, + // Random effects ncol_X_random_eff, - X_random_effect, - X_random_effect_2, + X_random_effect, + X_random_effect_2, random_effect, random_effect_2, - + //truncation truncation_not_idx_minimal - + ); - + // print("2---", reduce_sum( // partial_sum_lupmf, // y_array[truncation_not_idx], @@ -487,58 +516,103 @@ model{ // mu_array[truncation_not_idx], // precision_array[truncation_not_idx] // )); - - + + } - + // Priors + // per-effect regression if(exclude_priors == 0){ - - // If interceopt in design or I have complex variability design - // This would include the models - // composition ~ 1 + ...; composition ~ 0 + ...; - // variability ~ 1 - if(A == 1){ + for(a in 1:A){ + + if(bimodal_mean_variability_association == 1){ + // Bimodal model: use all 4 parameters + array[4] real prec_coeff_a; + prec_coeff_a[1] = prec_coeff[1, a]; // i1 + prec_coeff_a[2] = prec_coeff[2, a]; // s1 + prec_coeff_a[3] = prec_coeff[3, a]; // s2 + prec_coeff_a[4] = prec_coeff[4, a]; // i2 + target += abundance_variability_regression( - alpha[1], - beta[1], // average_by_col(beta[1:B_intercept_columns,]), - prec_coeff, - prec_sd, + alpha[a], + beta[a], + prec_coeff_a, + prec_sd_1, + prec_sd_2_scalar, bimodal_mean_variability_association, - mix_p - ); + mix_p_scalar + ); } else { - // Loop across the intercept columns in case of a intercept-less design (covariate are intercepts) - for(a in 1:A_intercept_columns) + // Single model: use only 2 parameters + array[2] real prec_coeff_a; + prec_coeff_a[1] = prec_coeff[1, a]; // intercept + prec_coeff_a[2] = prec_coeff[2, a]; // slope + target += abundance_variability_regression( alpha[a], beta[a], - prec_coeff, - prec_sd, + prec_coeff_a, + prec_sd_1, + prec_sd_2_scalar, bimodal_mean_variability_association, - mix_p - ); - - // Variability effect if the formula is more complex - if(A>A_intercept_columns) for(a in (A_intercept_columns+1):A) alpha[a] ~ normal(beta[a] * prec_coeff[2], 2 ); + mix_p_scalar + ); } - } - - // If I don't have priors for overdispersion - else{ - // Priors variability - if(intercept_in_design || A > 1){ - for(a in 1:A_intercept_columns) alpha[a] ~ normal( prec_coeff[1], prec_sd ); - if(A>A_intercept_columns) for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ normal ( 0, 2 ); - } - // if ~ 0 + covariuate - else { - alpha[1] ~ normal( prec_coeff[1], prec_sd ); - } + + if(bimodal_mean_variability_association == 1){ + // Bimodal-specific priors + mix_p ~ beta(1,5); + for(a in 1:A){ + prec_coeff[1, a] ~ student_t(3, -1, 2); // i1 + prec_coeff[4, a] ~ student_t(3, 0, 2); // i2 + prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // s1 + prec_coeff[3, a] ~ student_t(3, -0.5, 1.5); // s2 } - + prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; + prec_sd_2[1] ~ normal(0, prior_prec_sd[1] * 1.5) T[0,]; +} else { + mix_p ~ beta(1, 1); + // Single model priors (only 2 parameters) + for(a in 1:A){ + prec_coeff[1, a] ~ student_t(3, 0, 2); // intercept + prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // slope + } + prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; +} + } + else { + if(intercept_in_design || A > 1){ + for(a in 1:A_intercept_columns) alpha[a] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); + if(A > A_intercept_columns) + for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ normal(0, 2); + } else { + alpha[1] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); + } + // hyper prior + if(bimodal_mean_variability_association == 1){ + // Bimodal-specific priors + mix_p ~ beta(1, 5); + for(a in 1:A){ + prec_coeff[1, a] ~ student_t(3, -1, 2); // i1 + prec_coeff[4, a] ~ student_t(3, 0, 2); // i2 + prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // s1 + prec_coeff[3, a] ~ student_t(3, -0.5, 1.5); // s2 + } + prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; + prec_sd_2[1] ~ normal(0, prior_prec_sd[1] * 1.5) T[0,]; +} else { + mix_p ~ beta(1, 1); + // Single model priors (only 2 parameters) + for(a in 1:A){ + prec_coeff[1, a] ~ student_t(3, 0, 2); // intercept + prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // slope + } + prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; +} +} + // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); if(C>B_intercept_columns) for(c in (B_intercept_columns+1):C) beta_raw[c] ~ normal ( prior_mean_coefficients[1], prior_mean_coefficients[2] * inv(sqrt(1 - inv(M))) ); @@ -551,16 +625,17 @@ model{ // prec_coeff ~ std_normal(); // prior imposed again for prec_coeff, should delete this line, and maybe the comment below // Note: sum_to_zero_vector has built-in priors, no need for explicit std_normal() + // Random intercept if(is_random_effect>0){ - for(m in 1:M) random_effect_raw[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); + for(m in 1:M) random_effect_raw[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); for(m in 1:M) random_effect_sigma_raw[m] ~ std_normal(); for(m in 1:M) sigma_correlation_factor[m] ~ lkj_corr_cholesky(2); // LKJ prior for the correlation matrix random_effect_sigma_mu ~ std_normal(); random_effect_sigma_sigma ~ std_normal(); - + // If I have just one group zero_random_effect ~ std_normal(); } @@ -572,23 +647,11 @@ model{ } generated quantities { matrix[A, M] alpha_normalised = alpha; - - // // Rondom effect - // matrix[ncol_X_random_eff_WINDOWS_BUG_FIX, M] beta_random_effect; - // matrix[ncol_X_random_eff_WINDOWS_BUG_FIX_2, M] beta_random_effect_2; - + // LOO vector[TNS] log_lik = rep_vector(0, TNS); - - // These instructions regress out the effect of mean proportion to the overdispersion - // This adjustment provide A overdispersion value that can be tested for a hypotheses for example differences between two conditions - if(intercept_in_design){ - if(A > 1) for(a in 2:A) alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2] ); - } - else{ - for(a in 1:A) alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2] ); - } - + + // LOO if(enable_loo==1){ From d54417a09ce5ec6f23504fbc768035bddd041ee3 Mon Sep 17 00:00:00 2001 From: Lejing Li Date: Wed, 4 Mar 2026 00:37:29 +0800 Subject: [PATCH 02/68] fix unit test --- .gitignore | 2 +- R/model_fitting.R | 222 +++++++-------- R/plot.R | 101 +++---- inst/stan/common_functions.stan | 68 ++--- inst/stan/glm_multi_beta_binomial.stan | 11 + ...glm_multi_beta_binomial_generate_data.stan | 82 +++--- tests/testthat/test-plot.R | 255 ++++++++---------- 7 files changed, 374 insertions(+), 367 deletions(-) diff --git a/.gitignore b/.gitignore index 80fa8d64..b631b214 100644 --- a/.gitignore +++ b/.gitignore @@ -46,7 +46,7 @@ Rplot.pdf sccomp_draws_files .DS_Store docs - /.quarto/ **/*.quarto_ipynb .Renviron +*.exe diff --git a/R/model_fitting.R b/R/model_fitting.R index fcc1c9f4..58f45a61 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -2,34 +2,35 @@ fit_model = function( data_for_model, model_name, censoring_iteration = 1, cores = detectCores(), quantile = 0.95, warmup_samples = 300, approximate_posterior_inference = NULL, inference_method, verbose = TRUE, - seed , pars = c("beta", "alpha", "prec_coeff","prec_sd"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, + seed , pars = c("beta", "alpha", "prec_sd_1", "intercept_single", "slope_single", + "intercept_pair", "slope_1", "slope_2", "prec_sd_2"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, output_directory = "sccomp_draws_files", sig_figs = 9, cache_stan_model = sccomp_stan_models_cache_dir, ... ) { - + # # if analysis approximated # # If posterior analysis is approximated I just need enough # how_many_posterior_draws_practical = ifelse(approximate_posterior_analysis, 1000, how_many_posterior_draws) # additional_parameters_to_save = additional_parameters_to_save %>% c("lambda_log_param", "sigma_raw") %>% unique - - + + # Find number of draws draws_supporting_quantile = 50 if(is.null(output_samples)){ - + output_samples = (draws_supporting_quantile/((1-quantile)/2)) %>% # /2 because I have two tails - max(4000) - + max(4000) + if(output_samples > max_sampling_iterations) { # message("sccomp says: the number of draws used to defined quantiles of the posterior distribution is capped to 20K.") # This means that for very low probability threshold the quantile could become unreliable. We suggest to limit the probability threshold between 0.1 and 0.01") output_samples = max_sampling_iterations - + }} - + # Find optimal number of chains if(is.null(chains)) chains = @@ -39,61 +40,72 @@ fit_model = function( parallelisation_start_penalty = 100 ) %>% min(cores) - + # chains = 3 - - init_list=list( - prec_coeff = c(5,0), - prec_sd = 1, - alpha = matrix(c(rep(5, data_for_model$M), rep(0, (data_for_model$A-1) *data_for_model$M)), nrow = data_for_model$A, byrow = TRUE), - beta_raw = matrix(0, data_for_model$C , data_for_model$M) , - mix_p = 0.1 + + init_list = list( + alpha = matrix(c(rep(5, data_for_model$M), + rep(0, (data_for_model$A - 1) * data_for_model$M)), + nrow = data_for_model$A, byrow = TRUE), + beta_raw = matrix(0, data_for_model$C, data_for_model$M), + prec_sd_1 = 1, + mix_p = 0.1 ) - + + if (data_for_model$bimodal_mean_variability_association == 1) { + init_list$intercept_pair = replicate(data_for_model$A, c(-1, 3), simplify = FALSE) + init_list$slope_1 = rep(-0.5, data_for_model$A) + init_list$slope_2 = rep(-0.5, data_for_model$A) + init_list$prec_sd_2 = c(1) + } else { + init_list$intercept_single = rep(5, data_for_model$A) + init_list$slope_single = rep(-0.5, data_for_model$A) + } + if(data_for_model$n_random_eff>0){ init_list$random_effect_raw = matrix(0, data_for_model$ncol_X_random_eff[1] , data_for_model$M) init_list$random_effect_sigma_raw = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[1]) init_list$sigma_correlation_factor = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[1], + data_for_model$M, + data_for_model$how_many_factors_in_random_design[1], data_for_model$how_many_factors_in_random_design[1] )) - + # init_list$random_effect_sigma_mu = 0.5 |> as.array() # init_list$random_effect_sigma_sigma = 0.2 |> as.array() init_list$zero_random_effect = rep(0, size = 1) |> as.array() - - } - + + } + if(data_for_model$n_random_eff>1){ init_list$random_effect_raw_2 = matrix(0, data_for_model$ncol_X_random_eff[2] , data_for_model$M) init_list$random_effect_sigma_raw_2 = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[2]) init_list$sigma_correlation_factor_2 = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[2], + data_for_model$M, + data_for_model$how_many_factors_in_random_design[2], data_for_model$how_many_factors_in_random_design[2] )) - - } - + + } + init = map(1:chains, ~ init_list) %>% setNames(as.character(1:chains)) - + #output_directory = "sccomp_draws_files" dir.create(output_directory, showWarnings = FALSE) - + # Fit mod = load_model(model_name, threads = cores, cache_dir = cache_stan_model) - + # Avoid 0 proportions if(data_for_model$is_proportion && min(data_for_model$y_proportion)==0){ warning("sccomp says: your proportion values include 0. Assuming that 0s derive from a precision threshold (e.g. deconvolution), 0s are converted to the smaller non 0 proportion value.") data_for_model$y_proportion[data_for_model$y_proportion==0] = min(data_for_model$y_proportion[data_for_model$y_proportion>0]) } - + if(inference_method == "hmc"){ - + # tryCatch({ mod$sample( data = data_for_model , @@ -111,25 +123,25 @@ fit_model = function( sig_figs = sig_figs, show_exceptions = verbose, ... - ) - + ) + # }, # error = function(e) { - # + # # # I don't know why thi is needed nd why the model sometimes is not compliled correctly # if(e |> as.character() |> str_detect("Model not compiled")) # model = load_model(model_name, force=TRUE, threads = cores) # else # stop(e) - # + # # }) - + } else{ - + if(inference_method=="pathfinder") init = pf else if(inference_method=="variational") init = list(init_list) - + vb_iterative( mod, model_name = model_name, @@ -140,20 +152,20 @@ fit_model = function( seed = seed, output_dir = output_directory, init = init, - inference_method = inference_method, + inference_method = inference_method, cores = cores, - psis_resample = FALSE, + psis_resample = FALSE, verbose = verbose, sig_figs = sig_figs, cache_stan_model = cache_stan_model, show_exceptions = FALSE, ... - ) - + ) + } - - - + + + } get_model_from_data = function(file_compiled_model, model_code){ @@ -163,7 +175,7 @@ get_model_from_data = function(file_compiled_model, model_code){ model_generate = stan_model(model_code = model_code) model_generate %>% saveRDS(file_compiled_model) model_generate - + } } @@ -171,31 +183,31 @@ get_model_from_data = function(file_compiled_model, model_code){ #' #' This function attempts to load a precompiled Stan model using the `instantiate` package. #' If the model is not found in the cache or force recompilation is requested, it will locate -#' the Stan model file within the `sccomp` package, compile it using `cmdstanr`, and save the +#' the Stan model file within the `sccomp` package, compile it using `cmdstanr`, and save the #' compiled model to the cache directory for future use. #' #' @param name A character string representing the name of the Stan model (without the `.stan` extension). -#' @param cache_dir A character string representing the path to the cache directory where compiled models are saved. +#' @param cache_dir A character string representing the path to the cache directory where compiled models are saved. #' Defaults to `sccomp_stan_models_cache_dir`. -#' @param force A logical value. If `TRUE`, the model will be recompiled even if it exists in the cache. +#' @param force A logical value. If `TRUE`, the model will be recompiled even if it exists in the cache. #' Defaults to `FALSE`. -#' @param threads An integer specifying the number of threads to use for compilation. +#' @param threads An integer specifying the number of threads to use for compilation. #' Defaults to `1`. -# +# #' @return A compiled Stan model object from `cmdstanr`. -#' +#' #' @importFrom instantiate stan_package_model #' @importFrom instantiate stan_package_compile -#' +#' #' @noRd -#' +#' #' @examples #' \donttest{ #' model <- load_model("glm_multi_beta_binomial_", "~/cache", force = FALSE, threads = 1) #' } load_model <- function(name, cache_dir = sccomp_stan_models_cache_dir, force=FALSE, threads = 1) { - - + + # tryCatch({ # # Attempt to load a precompiled Stan model using the instantiate package # instantiate::stan_package_model( @@ -204,22 +216,22 @@ load_model <- function(name, cache_dir = sccomp_stan_models_cache_dir, force=FAL # ) # }, error = function(e) { # Try to load the model from cache - + # Handle cache directory - always add version to ensure version isolation sccomp_version <- as.character(packageVersion("sccomp")) cache_dir <- file.path(cache_dir, sccomp_version) - + # RDS compiled model cache_dir |> dir.create(showWarnings = FALSE, recursive = TRUE) cache_file <- file.path(cache_dir, paste0(name, ".rds")) - + # .STAN raw model stan_model_path <- system.file("stan", paste0(name, ".stan"), package = "sccomp") - + if (file.exists(cache_file) && !force) { mod <- readRDS(cache_file) stan_file <- tryCatch(mod$stan_file(), error = function(e) "") - + if (!is.null(stan_file) && nzchar(stan_file) && file.exists(stan_file)) { message("Loading model from cache...") return(mod) @@ -228,40 +240,40 @@ load_model <- function(name, cache_dir = sccomp_stan_models_cache_dir, force=FAL clear_stan_model_cache(cache_dir = cache_dir) } } - + # If loading the precompiled model fails, find the Stan model file within the package message("Precompiled model not found. Compiling the model...") - + # Compile the Stan model using cmdstanr with threading support enabled instantiate::stan_package_compile( - stan_model_path, + stan_model_path, cpp_options = list(stan_threads = TRUE), - force_recompile = TRUE, - threads = threads, + force_recompile = TRUE, + threads = threads, dir = system.file("stan", package = "sccomp") ) mod = instantiate::stan_package_model( - name = name, - package = "sccomp", + name = name, + package = "sccomp", compile = TRUE, cpp_options = list(stan_threads = TRUE) ) |> suppressWarnings() - + # Save the compiled model object to cache saveRDS(mod, file = cache_file) message("Model compiled and saved to cache successfully.") - + return(mod) # }) - + } #' Check and Install cmdstanr and CmdStan #' -#' This function checks if the `cmdstanr` package (version 0.9.0 or higher) and CmdStan are installed. +#' This function checks if the `cmdstanr` package (version 0.9.0 or higher) and CmdStan are installed. #' If they are not installed, it installs them automatically in non-interactive sessions #' or asks for permission to install them in interactive sessions. -#' +#' #' The function requires cmdstanr version 0.9.0 or higher for support of the new `sum_to_zero_vector` type. #' #' @importFrom instantiate stan_cmdstan_exists @@ -269,13 +281,13 @@ load_model <- function(name, cache_dir = sccomp_stan_models_cache_dir, force=FAL #' @importFrom rlang abort #' @importFrom rlang check_installed #' @return NULL -#' +#' #' @noRd check_and_install_cmdstanr <- function() { - + # Check if cmdstanr is installed # from https://github.com/wlandau/instantiate/blob/33989d74c26f349e292e5efc11c267b3a1b71d3f/R/utils_assert.R#L114 - + # tryCatch( rlang::check_installed( pkg = "cmdstanr", @@ -286,7 +298,7 @@ check_and_install_cmdstanr <- function() { "install.packages(pkgs = \"cmdstanr\",", "repos = c(\"https://mc-stan.org/r-packages/\", getOption(\"repos\"))" ), - + # I have to see if Bioconductor is compatible with this action = function(...) install.packages(..., repos = c('https://stan-dev.r-universe.dev', 'https://cloud.r-project.org')) ) @@ -300,9 +312,9 @@ check_and_install_cmdstanr <- function() { # Check if CmdStan is installed if (!stan_cmdstan_exists()) { - + clear_stan_model_cache() - + stop( "cmdstan is required to proceed.\n\n", "You can install CmdStan by running the following command:\n", @@ -342,10 +354,10 @@ vb_iterative = function(model, additional_parameters_to_save = c(), data, output_dir = output_dir, - seed, + seed, init = "random", inference_method, - cores = 1, + cores = 1, verbose = TRUE, psis_resample = FALSE, sig_figs = 9, @@ -355,9 +367,9 @@ vb_iterative = function(model, i = 0 while (is.null(res) & i < 5) { res = tryCatch({ - + if(inference_method=="pathfinder") - my_res = model |> + my_res = model |> sample_safe( pathfinder_fx, data = data, @@ -365,19 +377,19 @@ vb_iterative = function(model, output_dir = output_dir, seed = seed+i, # init = init, - num_paths=50, + num_paths=50, num_threads = cores, single_path_draws = output_samples / 50 , - max_lbfgs_iters=100, - history_size = 100, + max_lbfgs_iters=100, + history_size = 100, show_messages = verbose, psis_resample = psis_resample, sig_figs = sig_figs, ... ) - + else if(inference_method=="variational") - my_res = model |> + my_res = model |> sample_safe( variational_fx, data = data, @@ -392,7 +404,7 @@ vb_iterative = function(model, sig_figs = sig_figs, ... ) - + boolFalse <- TRUE return(my_res) }, @@ -401,17 +413,17 @@ vb_iterative = function(model, clear_stan_model_cache() model <<- load_model(model_name, force=TRUE, threads = cores, cache_dir = cache_stan_model) } - else writeLines(sprintf("Further attempt with Variational Bayes: %s", e)) - + else writeLines(sprintf("Further attempt with Variational Bayes: %s", e)) + return(NULL) }, finally = { }) i = i + 1 } - + if(is.null(res)) stop(sprintf("sccomp says: variational Bayes did not converge after %s attempts. Please use variational_inference = FALSE for a HMC fitting.", i)) - + return(res) } @@ -427,21 +439,21 @@ vb_iterative = function(model, #' @return A Stan fit object find_optimal_number_of_chains = function(how_many_posterior_draws = 100, max_number_to_check = 100, warmup = 200, parallelisation_start_penalty = 100) { - - - + + + # Define the variables as NULL to avoid CRAN NOTES chains <- NULL - - + + chains_df = tibble(chains = seq_len(max_number_to_check)) %>% mutate(tot = (how_many_posterior_draws / chains) + warmup + (parallelisation_start_penalty * chains)) - + d1 <- diff(chains_df$tot) / diff(seq_len(nrow(chains_df))) # first derivative abs(d1) %>% order() %>% .[1] # Find derivative == 0 - - + + } @@ -485,4 +497,4 @@ variational_fx <- function(model, ...) { generate_quantities_fx <- function(model, ...) { model$generate_quantities(...) -} \ No newline at end of file +} diff --git a/R/plot.R b/R/plot.R index 0747658f..4ed34c87 100644 --- a/R/plot.R +++ b/R/plot.R @@ -479,53 +479,61 @@ plot_2D_intervals <- function( cat("\n") } - # Create adjusted data based on model type - if (model_type == "single") { - .data_adjusted_list <- lapply(params_list, function(params) { - param_data <- .data %>% - filter(parameter == params$parameter) + # v_effect already comes from alpha_normalised (adjusted in Stan) + # "unadjusted" panel: ADD BACK entanglement to show raw alpha + # "adjusted" panel: USE v_effect AS-IS - param_data_adjusted <- param_data %>% + if (model_type == "single") { + .data_unadjusted_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% mutate( - v_effect = v_effect + params$slope * c_effect, - v_lower = v_lower + params$slope * c_effect, - v_upper = v_upper + params$slope * c_effect, - parameter = paste0(params$parameter, ", adjusted") + v_effect = v_effect - params$slope * c_effect, + v_lower = v_lower - params$slope * c_effect, + v_upper = v_upper - params$slope * c_effect, + parameter = paste0(params$parameter, ", unadjusted") ) - - return(param_data_adjusted) }) } else { - .data_adjusted_list <- lapply(params_list, function(params) { - param_data <- .data %>% - filter(parameter == params$parameter) - - param_data_adjusted <- param_data %>% + .data_unadjusted_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% rowwise() %>% mutate( - residual_comp1 = abs(v_effect - (-(params$intercept_1 + params$slope_1 * c_effect))), - residual_comp2 = abs(v_effect - (-(params$intercept_2 + params$slope_2 * c_effect))), - assigned_component = if_else(residual_comp1 < residual_comp2, 1, 2), + raw_v_comp1 = v_effect - params$slope_1 * c_effect, + raw_v_comp2 = v_effect - params$slope_2 * c_effect, + pred_comp1 = -(params$intercept_1 + params$slope_1 * c_effect), + pred_comp2 = -(params$intercept_2 + params$slope_2 * c_effect), + assigned_component = if_else( + abs(raw_v_comp1 - pred_comp1) < abs(raw_v_comp2 - pred_comp2), 1, 2 + ), slope_to_use = if_else(assigned_component == 1, params$slope_1, params$slope_2), - v_effect = v_effect + slope_to_use * c_effect, - v_lower = v_lower + slope_to_use * c_effect, - v_upper = v_upper + slope_to_use * c_effect, - parameter = paste0(params$parameter, ", adjusted") + v_effect = v_effect - slope_to_use * c_effect, + v_lower = v_lower - slope_to_use * c_effect, + v_upper = v_upper - slope_to_use * c_effect, + parameter = paste0(params$parameter, ", unadjusted") ) %>% ungroup() %>% - select(-residual_comp1, -residual_comp2, -slope_to_use) - - return(param_data_adjusted) + select(-raw_v_comp1, -raw_v_comp2, -pred_comp1, -pred_comp2, -slope_to_use) }) } + .data_unadjusted <- bind_rows(.data_unadjusted_list) + + # Adjusted panel: v_effect as-is (already from alpha_normalised) + .data_adjusted_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% + mutate(parameter = paste0(params$parameter, ", adjusted")) + }) .data_adjusted <- bind_rows(.data_adjusted_list) - .data_plot <- bind_rows(.data, .data_adjusted) + + .data_plot <- bind_rows(.data_unadjusted, .data_adjusted) # Set parameter factor levels param_order <- c() for(p in params_list) { - param_order <- c(param_order, p$parameter, paste0(p$parameter, ", adjusted")) + param_order <- c(param_order, paste0(p$parameter, ", unadjusted"), paste0(p$parameter, ", adjusted")) } .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) @@ -541,7 +549,7 @@ plot_2D_intervals <- function( cell_type_label = if_else( row_number() <= 3 & c_FDR < significance_threshold & - !str_detect(parameter, "adjusted"), + str_detect(parameter, "unadjusted"), !!sym(.cell_group), "" ) @@ -555,7 +563,8 @@ plot_2D_intervals <- function( cell_type_label = if_else( row_number() <= 3 & v_FDR < significance_threshold & - !str_detect(parameter, "adjusted") & + str_detect(parameter, "adjusted") & + !str_detect(parameter, "unadjusted") & cell_type_label == "", !!sym(.cell_group), cell_type_label @@ -567,13 +576,13 @@ plot_2D_intervals <- function( if (significance_statistic == "FDR") { color_c_aes <- aes( xmin = c_lower, xmax = c_upper, - color = c_FDR < significance_threshold & str_detect(parameter, "adjusted"), - alpha = c_FDR < significance_threshold & str_detect(parameter, "adjusted") + color = c_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted"), + alpha = c_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted") ) color_v_aes <- aes( ymin = v_lower, ymax = v_upper, - color = v_FDR < significance_threshold & str_detect(parameter, "adjusted"), - alpha = v_FDR < significance_threshold & str_detect(parameter, "adjusted") + color = v_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted"), + alpha = v_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted") ) color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) @@ -581,13 +590,13 @@ plot_2D_intervals <- function( } else { color_c_aes <- aes( xmin = c_lower, xmax = c_upper, - color = c_pH0 < significance_threshold & !str_detect(parameter, "adjusted"), - alpha = c_pH0 < significance_threshold & !str_detect(parameter, "adjusted") + color = c_pH0 < significance_threshold & str_detect(parameter, "unadjusted"), + alpha = c_pH0 < significance_threshold & str_detect(parameter, "unadjusted") ) color_v_aes <- aes( ymin = v_lower, ymax = v_upper, - color = v_pH0 < significance_threshold & !str_detect(parameter, "adjusted"), - alpha = v_pH0 < significance_threshold & !str_detect(parameter, "adjusted") + color = v_pH0 < significance_threshold & str_detect(parameter, "unadjusted"), + alpha = v_pH0 < significance_threshold & str_detect(parameter, "unadjusted") ) color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) @@ -597,7 +606,8 @@ plot_2D_intervals <- function( # Prepare regression line data based on model type if (model_type == "single") { regression_data_all <- lapply(params_list, function(params) { - param_data <- .data_plot %>% filter(parameter == params$parameter) + unadj_param <- paste0(params$parameter, ", unadjusted") + param_data <- .data_plot %>% filter(parameter == unadj_param) if(nrow(param_data) == 0) return(NULL) c_range <- range(param_data$c_effect, na.rm = TRUE) @@ -607,7 +617,7 @@ plot_2D_intervals <- function( data.frame( c_effect = c_seq, v_effect = v_pred, - parameter = params$parameter, + parameter = unadj_param, stringsAsFactors = FALSE ) }) %>% bind_rows() @@ -639,7 +649,8 @@ plot_2D_intervals <- function( } else { regression_data_all <- lapply(params_list, function(params) { - param_data <- .data_plot %>% filter(parameter == params$parameter) + unadj_param <- paste0(params$parameter, ", unadjusted") + param_data <- .data_plot %>% filter(parameter == unadj_param) if(nrow(param_data) == 0) return(NULL) c_range <- range(param_data$c_effect, na.rm = TRUE) @@ -651,11 +662,11 @@ plot_2D_intervals <- function( bind_rows( data.frame( c_effect = c_seq, v_effect = v_pred_1, - parameter = params$parameter, component = "Component 1" + parameter = unadj_param, component = "Component 1" ), data.frame( c_effect = c_seq, v_effect = v_pred_2, - parameter = params$parameter, component = "Component 2" + parameter = unadj_param, component = "Component 2" ) ) }) %>% bind_rows() @@ -929,7 +940,7 @@ plot_scatterplot = function( guides(color = guide_legend(title = legend_title), alpha = "none") # Add marginal density for adjusted panels (not Intercept) - if (str_detect(param, "adjusted") && !str_detect(param, "Intercept")) { + if (str_detect(param, "adjusted") && !str_detect(param, "unadjusted") && !str_detect(param, "Intercept")) { if (model_type == "single") { param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) diff --git a/inst/stan/common_functions.stan b/inst/stan/common_functions.stan index 69fef109..8f5f8a3d 100644 --- a/inst/stan/common_functions.stan +++ b/inst/stan/common_functions.stan @@ -8,19 +8,19 @@ // PIVOT WIDER // increase of one dimension array[cell_type] matrix[group, factor] array[M] matrix[how_many_factors_in_random_design, n_groups] matrix_of_random_effects_raw; - + for(m in 1:M) for(i in 1:n_groups) for(j in 1:how_many_factors_in_random_design) { - - // If I don't have the factor for one group + + // If I don't have the factor for one group if(group_factor_indexes_for_covariance[j,i] == 0) matrix_of_random_effects_raw[m, j,i] = 0; - else + else matrix_of_random_effects_raw[m, j,i] = input_matrix[group_factor_indexes_for_covariance[j,i], m]; } - + return matrix_of_random_effects_raw; } - + matrix reshape_to_2d_matrix( int M, int n_groups, @@ -30,18 +30,18 @@ int ncol_X_random_eff ) { matrix[ncol_X_random_eff , M] random_effect; - + // Pivot longer for(m in 1:M) for(i in 1:n_groups) for(j in 1:how_many_factors_in_random_design) { - - // If I don't have the factor for one group + + // If I don't have the factor for one group if(group_factor_indexes_for_covariance[j,i] > 0) random_effect[group_factor_indexes_for_covariance[j,i], m] = matrix_of_random_effects[m,j,i]; } - + return random_effect; } - + matrix get_random_effect_matrix( int M, // Number of categories/outcomes int n_groups, // Number of groups in the random effects design @@ -49,61 +49,61 @@ int is_random_effect, // Flag indicating if random effects are used (0/1) int ncol_X_random_eff, // Number of columns in the random effects design matrix array[,] int group_factor_indexes_for_covariance, // 2D array mapping factors to groups for covariance structure - + array[] vector random_effect_raw, // Raw random effects as vector array array[] vector random_effect_sigma, // Standard deviations for each random effect array[] matrix sigma_correlation_factor // Correlation matrices for random effects ){ - + // Convert vector array to matrix for processing matrix[ncol_X_random_eff, M] random_effect_matrix; for(i in 1:ncol_X_random_eff) { random_effect_matrix[i,] = to_row_vector(random_effect_raw[i]); } - + // PIVOT WIDER, as my columns should be covariates, not groups - array[M] matrix[how_many_factors_in_random_design, n_groups] matrix_of_random_effects_raw = + array[M] matrix[how_many_factors_in_random_design, n_groups] matrix_of_random_effects_raw = reshape_to_3d_matrix( - M, - n_groups, - how_many_factors_in_random_design, - random_effect_matrix, + M, + n_groups, + how_many_factors_in_random_design, + random_effect_matrix, group_factor_indexes_for_covariance ); - + // Design L array[M] matrix[how_many_factors_in_random_design, how_many_factors_in_random_design] L; array[M] matrix[how_many_factors_in_random_design, n_groups] matrix_of_random_effects; - + // print(random_effect_sigma); for(m in 1:M) L[m] = diag_pre_multiply(random_effect_sigma[m], sigma_correlation_factor[m]) ; for(m in 1:M) matrix_of_random_effects[m] = L[m] * matrix_of_random_effects_raw[m]; - - // PIVOT LONGER + + // PIVOT LONGER return reshape_to_2d_matrix( - M, - n_groups, - how_many_factors_in_random_design, - matrix_of_random_effects, + M, + n_groups, + how_many_factors_in_random_design, + matrix_of_random_effects, group_factor_indexes_for_covariance, ncol_X_random_eff ); } - + // QR-based sum-to-zero functions removed - now using sum_to_zero_vector[K] type - + row_vector average_by_col(matrix X) { int rows_X = rows(X); int cols_X = cols(X); row_vector[cols_X] means; - + for (j in 1:cols_X) { means[j] = mean(X[, j]); } - + return means; - - + + } // Normalize a vector to sum to zero @@ -115,4 +115,4 @@ vector normalize_sum_to_zero(vector x) { normalized[i] = x[i] - sum_x / n; } return normalized; -} \ No newline at end of file +} diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 3084660a..2806e983 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -648,6 +648,17 @@ model{ generated quantities { matrix[A, M] alpha_normalised = alpha; + // Entanglement adjustment + if(intercept_in_design){ + if(A > 1) + for(a in 2:A) + alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2, a]); + } + else{ + for(a in 1:A) + alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2, a]); + } + // LOO vector[TNS] log_lik = rep_vector(0, TNS); diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 70ca81f4..aba6e89b 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -1,9 +1,9 @@ functions{ #include common_functions.stan - + } data { - + int bimodal_mean_variability_association; int N; int N_original; int M; @@ -18,15 +18,15 @@ data { array[length_XA_which] int XA_which; matrix[N, length_X_which] X; matrix[N, length_XA_which] Xa; // The variability design - + matrix[N_original, C] X_original; int is_truncated; real truncation_ajustment; // Random intercept - + int is_random_effect; - + array[2] int length_X_random_effect_which; array[length_X_random_effect_which[1]] int X_random_effect_which; array[2] int ncol_X_random_eff; @@ -34,11 +34,11 @@ data { matrix[N, ncol_X_random_eff_new[1]] X_random_effect; matrix[N, ncol_X_random_eff_new[2]] X_random_effect_2; array[length_X_random_effect_which[2]] int X_random_effect_which_2; - + // Should I create intercept for generate quantities int create_intercept; int A_intercept_columns; - + // Covariance setup array[2] int n_groups; array[2] int how_many_factors_in_random_design; @@ -46,10 +46,10 @@ data { array[how_many_factors_in_random_design[2], n_groups[2]] int group_factor_indexes_for_covariance_2; array[2] int unknown_grouping; - + // Dimensions for unseen random effects array[2] int ncol_X_random_eff_unseen; - + // Matrix for unseen random effects matrix[N, ncol_X_random_eff_unseen[1]] X_random_effect_unseen; matrix[N, ncol_X_random_eff_unseen[2]] X_random_effect_2_unseen; @@ -57,11 +57,11 @@ data { transformed data{ // If needed recreate the intercept matrix[N,1] X_intercept; - + // EXCEPTION MADE FOR WINDOWS GENERATE QUANTITIES IF RANDOM EFFECT DO NOT EXIST int ncol_X_random_eff_WINDOWS_BUG_FIX = max(ncol_X_random_eff[1], 1); int ncol_X_random_eff_WINDOWS_BUG_FIX_2 = max(ncol_X_random_eff[2], 1); - + X_intercept = to_matrix(rep_vector(1, N)); } @@ -69,17 +69,21 @@ parameters { array[C] vector[M] beta_raw; // Each row is a vector of length M matrix[A, M] alpha; // Variability - // To exclude - array[2] real prec_coeff; - real prec_sd; + array[A * bimodal_mean_variability_association] ordered[2] intercept_pair; + array[A * (1 - bimodal_mean_variability_association)] real intercept_single; + array[A * bimodal_mean_variability_association] real slope_1; + array[A * bimodal_mean_variability_association] real slope_2; + array[A * (1 - bimodal_mean_variability_association)] real slope_single; + real prec_sd_1; + array[bimodal_mean_variability_association] real prec_sd_2; real mix_p; - + // Random intercept // Using regular vectors instead of sum_to_zero_vector to avoid floating-point precision issues // NOTE: Floating-point precision can cause sum_to_zero_vector to fail the strict sum-to-zero constraint // We use regular vectors and apply the constraint manually where needed array[ncol_X_random_eff[1] * (is_random_effect>0)] vector[M] random_effect_raw; array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] vector[M] random_effect_raw_2; - + // sd of random intercept array[2 * (is_random_effect>0)] real random_effect_sigma_mu; array[2 * (is_random_effect>0)] real random_effect_sigma_sigma; @@ -94,7 +98,7 @@ parameters { // If I have just one group array[is_random_effect>0] real zero_random_effect; - + } generated quantities{ @@ -108,7 +112,7 @@ generated quantities{ array[N] real generated_exposure; matrix[C,M] beta; - + // Convert vectors to matrix and apply sum-to-zero constraint manually for(c in 1:C) { vector[M] temp_beta = beta_raw[c]; @@ -117,14 +121,14 @@ generated quantities{ temp_beta = normalize_sum_to_zero(temp_beta); beta[c,] = to_row_vector(temp_beta); } - + // Subset for mean and deviation matrix[length_X_which,M] my_beta = beta[X_which,]; matrix[length_XA_which,M] my_alpha = alpha[XA_which,]; - + matrix[M,N] mu; matrix[M,N] precision; - + // If needed recreate the intercept if(create_intercept == 1){ @@ -164,16 +168,16 @@ generated quantities{ array[M * (ncol_X_random_eff[1]> 0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma; if(ncol_X_random_eff[1]> 0) for(m in 1:M) random_effect_sigma[m] = random_effect_sigma_mu[1] + random_effect_sigma_sigma[1] * random_effect_sigma_raw[m]; if(ncol_X_random_eff[1]> 0) for(m in 1:M) random_effect_sigma[m] = exp(random_effect_sigma[m]/3.0); - + // Non centered parameterisation SD of random effects 2 array[M * (ncol_X_random_eff[2]> 0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_2; if(ncol_X_random_eff[2]> 0) for(m in 1:M) random_effect_sigma_2[m] = random_effect_sigma_mu[2] + random_effect_sigma_sigma[2] * random_effect_sigma_raw_2[m]; if(ncol_X_random_eff[2]> 0) for(m in 1:M) random_effect_sigma_2[m] = exp(random_effect_sigma_2[m]/3.0); - + // Random intercept - matrix[ncol_X_random_eff[1] * (is_random_effect>0), M] random_effect; - matrix[ncol_X_random_eff[2] * (is_random_effect>0), M] random_effect_2; - + matrix[ncol_X_random_eff[1] * (is_random_effect>0), M] random_effect; + matrix[ncol_X_random_eff[2] * (is_random_effect>0), M] random_effect_2; + // For first random effect if(length_X_random_effect_which[1]>0) { @@ -184,7 +188,7 @@ generated quantities{ } // Generate random effects matrix - either from fitted effects or random draws - + // Get transformed random effects random_effect = get_random_effect_matrix( M, @@ -197,24 +201,24 @@ generated quantities{ random_effect_sigma, sigma_correlation_factor ); - + // Apply random effects mu = mu + (X_random_effect * random_effect[X_random_effect_which,])'; - + // Add random effects for unseen groups if they exist if(ncol_X_random_eff_unseen[1] > 0) { - matrix[ncol_X_random_eff_unseen[1], M] unseen_random_effect = + matrix[ncol_X_random_eff_unseen[1], M] unseen_random_effect = to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[1] * M), ncol_X_random_eff_unseen[1], M); - + // Apply sum-to-zero constraint to unseen random effects for(i in 1:ncol_X_random_eff_unseen[1]) { unseen_random_effect[i,] = to_row_vector(normalize_sum_to_zero(to_vector(unseen_random_effect[i,]))); } - + mu = mu + (X_random_effect_unseen * unseen_random_effect)'; } } - + // For second random effect if(length_X_random_effect_which[2]>0) { @@ -224,7 +228,7 @@ generated quantities{ random_effect_raw_2_vec[i] = normalize_sum_to_zero(random_effect_raw_2[i]); } // Generate random effects matrix - either from fitted effects or random draws - + // Get transformed random effects random_effect_2 = get_random_effect_matrix( M, @@ -237,20 +241,20 @@ generated quantities{ random_effect_sigma_2, sigma_correlation_factor_2 ); - + // Apply random effects mu = mu + (X_random_effect_2 * random_effect_2[X_random_effect_which_2,])'; - + // Add random effects for unseen groups if they exist if(ncol_X_random_eff_unseen[2] > 0) { - matrix[ncol_X_random_eff_unseen[2], M] unseen_random_effect_2 = + matrix[ncol_X_random_eff_unseen[2], M] unseen_random_effect_2 = to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[2] * M), ncol_X_random_eff_unseen[2], M); - + // Apply sum-to-zero constraint to unseen random effects for(i in 1:ncol_X_random_eff_unseen[2]) { unseen_random_effect_2[i,] = to_row_vector(normalize_sum_to_zero(to_vector(unseen_random_effect_2[i,]))); } - + mu = mu + (X_random_effect_2_unseen * unseen_random_effect_2)'; } } diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 6b05a12e..66e0ec27 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -6,37 +6,37 @@ data("seurat_obj") data("sce_obj") data("counts_obj") -counts_obj = +counts_obj = counts_obj |> - mutate(count = count+1) |> - with_groups("sample", ~ .x |> mutate(proportion = count/sum(count))) + mutate(count = count+1) |> + with_groups("sample", ~ .x |> mutate(proportion = count/sum(count))) set.seed(42) n_iterations = 1000 if (instantiate::stan_cmdstan_exists()){ - - my_estimate = + + my_estimate = seurat_obj |> sccomp_estimate( formula_composition = ~ continuous_covariate * type , formula_variability = ~ 1, "sample", "cell_group", - - cores = 1, + + cores = 1, inference_method = "pathfinder", max_sampling_iterations = n_iterations, verbose=FALSE ) - - my_estimate_with_variance = + + my_estimate_with_variance = seurat_obj |> sccomp_estimate( formula_composition = ~ type, formula_variability = ~ type, "sample", "cell_group", - - cores = 1, + + cores = 1, inference_method = "pathfinder", max_sampling_iterations = n_iterations, verbose=FALSE ) @@ -45,51 +45,51 @@ if (instantiate::stan_cmdstan_exists()){ # Test for plot_1d_intervals function test_that("plot_1d_intervals function works correctly", { skip_cmdstan() - - my_estimate |> - sccomp_test() |> + + my_estimate |> + sccomp_test() |> plot_1D_intervals( significance_threshold = 0.025 - ) |> + ) |> expect_s3_class("patchwork") }) # Test for plot_2d_intervals function test_that("plot_2d_intervals function works correctly", { skip_cmdstan() - - my_estimate_with_variance |> - sccomp_test() |> + + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals( significance_threshold = 0.025 ) |> - expect_s3_class("ggplot") + expect_s3_class("patchwork") }) # Test for show_fdr_message parameter in plot functions test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { skip_cmdstan() - + # Test with show_fdr_message = TRUE (default) - plot_with_message <- my_estimate |> - sccomp_test() |> + plot_with_message <- my_estimate |> + sccomp_test() |> plot_1D_intervals( significance_threshold = 0.025, show_fdr_message = TRUE ) - + expect_s3_class(plot_with_message, "patchwork") - + # Test with show_fdr_message = FALSE - plot_without_message <- my_estimate |> - sccomp_test() |> + plot_without_message <- my_estimate |> + sccomp_test() |> plot_1D_intervals( significance_threshold = 0.025, show_fdr_message = FALSE ) - + expect_s3_class(plot_without_message, "patchwork") - + # Verify that both plots are created successfully (no errors) expect_no_error(plot_with_message) expect_no_error(plot_without_message) @@ -97,27 +97,27 @@ test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { test_that("show_fdr_message parameter works correctly in plot_2D_intervals", { skip_cmdstan() - + # Test with show_fdr_message = TRUE (default) - plot_with_message <- my_estimate_with_variance |> - sccomp_test() |> + plot_with_message <- my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals( significance_threshold = 0.025, show_fdr_message = TRUE ) - - expect_s3_class(plot_with_message, "ggplot") - + + expect_s3_class(plot_with_message, "patchwork") + # Test with show_fdr_message = FALSE - plot_without_message <- my_estimate_with_variance |> - sccomp_test() |> + plot_without_message <- my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals( significance_threshold = 0.025, show_fdr_message = FALSE ) - - expect_s3_class(plot_without_message, "ggplot") - + + expect_s3_class(plot_without_message, "patchwork") + # Verify that both plots are created successfully (no errors) expect_no_error(plot_with_message) expect_no_error(plot_without_message) @@ -125,77 +125,77 @@ test_that("show_fdr_message parameter works correctly in plot_2D_intervals", { test_that("show_fdr_message parameter accepts logical values", { skip_cmdstan() - + # Test with TRUE expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(show_fdr_message = TRUE) ) - + # Test with FALSE expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(show_fdr_message = FALSE) ) - + # Test with TRUE for 2D plots expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(show_fdr_message = TRUE) ) - + # Test with FALSE for 2D plots expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(show_fdr_message = FALSE) ) }) test_that("plot functions work with different significance thresholds", { skip_cmdstan() - + # Test plot_1D_intervals with different thresholds expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_threshold = 0.01) ) - + expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_threshold = 0.1) ) - + # Test plot_2D_intervals with different thresholds expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_threshold = 0.01) ) - + expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_threshold = 0.1) ) }) test_that("significance_statistic argument works for plot_1D_intervals", { skip_cmdstan() - + expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_statistic = "FDR") ) expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_statistic = "pH0") ) }) @@ -203,13 +203,13 @@ test_that("significance_statistic argument works for plot_1D_intervals", { test_that("significance_statistic argument works for plot_2D_intervals", { skip_cmdstan() expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_statistic = "FDR") ) expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_statistic = "pH0") ) }) @@ -217,23 +217,23 @@ test_that("significance_statistic argument works for plot_2D_intervals", { test_that("show_fdr_message argument works for plot_1D_intervals and plot_2D_intervals", { skip_cmdstan() expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_statistic = "FDR", show_fdr_message = TRUE) ) expect_no_error( - my_estimate |> - sccomp_test() |> + my_estimate |> + sccomp_test() |> plot_1D_intervals(significance_statistic = "FDR", show_fdr_message = FALSE) ) expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_statistic = "FDR", show_fdr_message = TRUE) ) expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> + my_estimate_with_variance |> + sccomp_test() |> plot_2D_intervals(significance_statistic = "FDR", show_fdr_message = FALSE) ) }) @@ -283,90 +283,59 @@ test_that("significance_statistic and show_fdr_message work via plot() S3 method expect_true(grepl("Bayesian FDR", fdr_plot$labels$caption)) expect_true(is.null(ph0_plot$labels$caption) || !grepl("Bayesian FDR", ph0_plot$labels$caption)) }) - test_that("plot_2D_intervals includes regression line from prec_coeff parameters", { - skip_cmdstan() - - # Create a 2D plot and check that it has the regression line - plot_2d <- my_estimate_with_variance |> - sccomp_test() |> - plot_2D_intervals( - significance_threshold = 0.025 - ) - - # Check that the plot is created successfully - expect_s3_class(plot_2d, "ggplot") - - # Extract the fitted model to verify prec_coeff parameters exist + skip_cmdstan() + + plot_2d <- my_estimate_with_variance |> + sccomp_test() |> + plot_2D_intervals(significance_threshold = 0.025) + + expect_s3_class(plot_2d, "patchwork") + fit <- attr(my_estimate_with_variance |> sccomp_test(), "fit") prec_coeff_summary <- fit$summary("prec_coeff") - - # Verify that prec_coeff parameters are available + expect_true(nrow(prec_coeff_summary) >= 2) - expect_true(all(c("prec_coeff[1]", "prec_coeff[2]") %in% prec_coeff_summary$variable)) - - # Check that the plot data includes the regression line - plot_data <- ggplot_build(plot_2d)$data - - # Look for the red line in the plot data - has_correct_line_color <- FALSE - for (layer_data in plot_data) { - if ("colour" %in% names(layer_data)) { - if (any(layer_data$colour == "#0072B2")) { - has_correct_line_color <- TRUE - break - } - } - } - - # The regression line should be present - expect_true(has_correct_line_color) - - # Test that the plot works with different significance statistics + expect_true(all(c("prec_coeff[1,1]", "prec_coeff[2,1]") %in% prec_coeff_summary$variable)) + expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> - plot_2D_intervals( - significance_threshold = 0.025, - significance_statistic = "pH0" - ) + my_estimate_with_variance |> + sccomp_test() |> + plot_2D_intervals(significance_threshold = 0.025, significance_statistic = "pH0") ) - + expect_no_error( - my_estimate_with_variance |> - sccomp_test() |> - plot_2D_intervals( - significance_threshold = 0.025, - show_fdr_message = FALSE - ) + my_estimate_with_variance |> + sccomp_test() |> + plot_2D_intervals(significance_threshold = 0.025, show_fdr_message = FALSE) ) -}) +}) test_that("sccomp_boxplot can accept additional ggplot layers", { skip_cmdstan() - + # Test that we can add layers to the boxplot - plot_with_label <- my_estimate |> - sccomp_test() |> + plot_with_label <- my_estimate |> + sccomp_test() |> sccomp_boxplot("type", significance_threshold = 0.025) + geom_label(aes(label = c_FDR), x = 1, y = 0.5) - + expect_s3_class(plot_with_label, "ggplot") - + # Test with geom_text - plot_with_text <- my_estimate |> - sccomp_test() |> + plot_with_text <- my_estimate |> + sccomp_test() |> sccomp_boxplot("type", significance_threshold = 0.025) + geom_text(aes(label = c_FDR), x = 1, y = 0.3) - + expect_s3_class(plot_with_text, "ggplot") - + # Test with theme modifications - plot_with_theme <- my_estimate |> - sccomp_test() |> + plot_with_theme <- my_estimate |> + sccomp_test() |> sccomp_boxplot("type", significance_threshold = 0.025) + theme(plot.title = element_text(color = "red")) - + expect_s3_class(plot_with_theme, "ggplot") }) @@ -462,4 +431,4 @@ test_that("sccomp_remove_outliers output exposes outliers attr and red boxplot p expect_true(any(jitter_layer$colour == "#e11f28", na.rm = TRUE)) -}) \ No newline at end of file +}) From 20fed9230c1a492b2d46f42c9921f6d4bbf1ee4d Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:41:05 +1100 Subject: [PATCH 03/68] limit prec_sd to one parameter for both modes --- inst/stan/glm_multi_beta_binomial.stan | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 2806e983..fb53f845 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -18,26 +18,27 @@ functions{ } - real abundance_variability_regression(row_vector variability, row_vector abundance, array[] real prec_coeff, real prec_sd_1, real prec_sd_2, int bimodal_mean_variability_association, real mix_p){ + real abundance_variability_regression(row_vector variability, row_vector abundance, array[] real prec_coeff, real prec_sd, int bimodal_mean_variability_association, real mix_p){ real lp = 0; - int nu = 3; // df + int nu = 3; // If mean-variability association is bimodal such as for single-cell RNA use mixed model if(bimodal_mean_variability_association == 1){ for(m in 1:cols(variability)) lp += log_mix(mix_p, student_t_lpdf(variability[m] | nu, abundance[m] * prec_coeff[2] + prec_coeff[1], - prec_sd_1), // c1 + prec_sd), student_t_lpdf(variability[m] | nu, abundance[m] * prec_coeff[3] + prec_coeff[4], - prec_sd_2) // c2 // -0.73074903 is what we observe in single-cell dataset Therefore it is safe to fix it for this mixture model as it just want to capture few possible outlier in the association + prec_sd) ); // If no bimodal } else { - lp = student_t_lpdf(variability | nu, - abundance * prec_coeff[2] + prec_coeff[1], prec_sd_1); + lp = student_t_lpdf(variability | nu, + abundance * prec_coeff[2] + prec_coeff[1], + prec_sd); } return(lp); @@ -351,8 +352,7 @@ parameters{ array[A * bimodal_mean_variability_association] real slope_1; array[A * bimodal_mean_variability_association] real slope_2; array[A * (1 - bimodal_mean_variability_association)] real slope_single; - real prec_sd_1; // c1 - array[bimodal_mean_variability_association] real prec_sd_2; // c2 + real prec_sd_1; // residual scale for mean–variability association (single or bimodal) real mix_p; // Random intercept // array of sum_to_zero_vector for each random effect From 1c450b3faf54b4e2f9bd0e992008c374cb028781 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:42:01 +1100 Subject: [PATCH 04/68] simplify stan code --- inst/stan/glm_multi_beta_binomial.stan | 129 +++++++++---------------- 1 file changed, 43 insertions(+), 86 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index fb53f845..ae992cbe 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -387,24 +387,21 @@ transformed parameters{ beta[c,] = to_row_vector(beta_raw[c]); } - // intercept_pair + slope_1/2 prec_coeff - matrix[bimodal_mean_variability_association == 1 ? 4 : 2, A] prec_coeff; - if(bimodal_mean_variability_association == 1){ - // Bimodal + // Unified prec_coeff for likelihood / priors / generated quantities. Cannot be + // declared as a single matrix in parameters: bimodal needs ordered[2] (i1, which do not map to one unconstrained matrix. + matrix[4, A] prec_coeff = rep_matrix(0, 4, A); for(a in 1:A){ - prec_coeff[1, a] = intercept_pair[a][1]; - prec_coeff[2, a] = slope_1[a]; - prec_coeff[3, a] = slope_2[a]; - prec_coeff[4, a] = intercept_pair[a][2]; - } -} else { - // Single - for(a in 1:A){ - prec_coeff[1, a] = intercept_single[a]; - prec_coeff[2, a] = slope_single[a]; // slope (global) + if(bimodal_mean_variability_association == 1){ + prec_coeff[1, a] = intercept_pair[a][1]; + prec_coeff[2, a] = slope_1[a]; + prec_coeff[3, a] = slope_2[a]; + prec_coeff[4, a] = intercept_pair[a][2]; + } else { + prec_coeff[1, a] = intercept_single[a]; + prec_coeff[2, a] = slope_single[a]; + } } -} - real prec_sd_2_scalar = bimodal_mean_variability_association == 1 ? prec_sd_2[1] : 0.0; real mix_p_scalar = bimodal_mean_variability_association == 1 ? mix_p : 0.5; // Non centered parameterisation SD of random effects @@ -521,93 +518,53 @@ model{ } // Priors - // per-effect regression + // Per-effect regression (optional for testing) if(exclude_priors == 0){ - for(a in 1:A){ - - if(bimodal_mean_variability_association == 1){ - // Bimodal model: use all 4 parameters + for(a in 1:A){ array[4] real prec_coeff_a; - prec_coeff_a[1] = prec_coeff[1, a]; // i1 - prec_coeff_a[2] = prec_coeff[2, a]; // s1 - prec_coeff_a[3] = prec_coeff[3, a]; // s2 - prec_coeff_a[4] = prec_coeff[4, a]; // i2 + prec_coeff_a[1] = prec_coeff[1, a]; + prec_coeff_a[2] = prec_coeff[2, a]; + if(bimodal_mean_variability_association == 1){ + prec_coeff_a[3] = prec_coeff[3, a]; + prec_coeff_a[4] = prec_coeff[4, a]; + } else { + // Unused in single-mode branch inside abundance_variability_regression(). + prec_coeff_a[3] = 0; + prec_coeff_a[4] = 0; + } target += abundance_variability_regression( alpha[a], beta[a], prec_coeff_a, prec_sd_1, - prec_sd_2_scalar, bimodal_mean_variability_association, mix_p_scalar ); } - else { - // Single model: use only 2 parameters - array[2] real prec_coeff_a; - prec_coeff_a[1] = prec_coeff[1, a]; // intercept - prec_coeff_a[2] = prec_coeff[2, a]; // slope - - target += abundance_variability_regression( - alpha[a], - beta[a], - prec_coeff_a, - prec_sd_1, - prec_sd_2_scalar, - bimodal_mean_variability_association, - mix_p_scalar - ); + } else { + if(intercept_in_design || A > 1){ + for(a in 1:A_intercept_columns) alpha[a] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); + if(A > A_intercept_columns) + for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ normal(0, 2); + } else { + alpha[1] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); } } - if(bimodal_mean_variability_association == 1){ - // Bimodal-specific priors - mix_p ~ beta(1,5); - for(a in 1:A){ - prec_coeff[1, a] ~ student_t(3, -1, 2); // i1 - prec_coeff[4, a] ~ student_t(3, 0, 2); // i2 - prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // s1 - prec_coeff[3, a] ~ student_t(3, -0.5, 1.5); // s2 - } - prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; - prec_sd_2[1] ~ normal(0, prior_prec_sd[1] * 1.5) T[0,]; -} else { - mix_p ~ beta(1, 1); - // Single model priors (only 2 parameters) - for(a in 1:A){ - prec_coeff[1, a] ~ student_t(3, 0, 2); // intercept - prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // slope - } - prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; -} - } - else { - if(intercept_in_design || A > 1){ - for(a in 1:A_intercept_columns) alpha[a] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); - if(A > A_intercept_columns) - for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ normal(0, 2); - } else { - alpha[1] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); - } - // hyper prior - if(bimodal_mean_variability_association == 1){ - // Bimodal-specific priors + // Hyper priors: i1/s1 (and prec_sd_1) shared; bimodal adds i2/s2 and mix_p shape + if(bimodal_mean_variability_association == 1) mix_p ~ beta(1, 5); + else + mix_p ~ beta(1, 1); + for(a in 1:A){ - prec_coeff[1, a] ~ student_t(3, -1, 2); // i1 - prec_coeff[4, a] ~ student_t(3, 0, 2); // i2 - prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // s1 - prec_coeff[3, a] ~ student_t(3, -0.5, 1.5); // s2 - } - prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; - prec_sd_2[1] ~ normal(0, prior_prec_sd[1] * 1.5) T[0,]; -} else { - mix_p ~ beta(1, 1); - // Single model priors (only 2 parameters) - for(a in 1:A){ - prec_coeff[1, a] ~ student_t(3, 0, 2); // intercept - prec_coeff[2, a] ~ student_t(3, -0.5, 1.5); // slope + prec_coeff[1, a] ~ student_t(3, 4, 2); // i1 + prec_coeff[2, a] ~ student_t(3, 0, 2); // s1 + if(bimodal_mean_variability_association == 1){ + prec_coeff[4, a] ~ student_t(3, 4, 2); // i2 + prec_coeff[3, a] ~ student_t(3, 0, 2); // s2 + } } prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; } From fc2aa1a2ce7a6f1e42ad9f250f5c0edcc733e19e Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:42:20 +1100 Subject: [PATCH 05/68] prec_sd with sd of 1 --- inst/stan/glm_multi_beta_binomial.stan | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index ae992cbe..3321be7e 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -566,9 +566,7 @@ model{ prec_coeff[3, a] ~ student_t(3, 0, 2); // s2 } } - prec_sd_1 ~ normal(0, prior_prec_sd[1]) T[0,]; -} -} + prec_sd_1 ~ normal(0, 1) T[0,]; // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); From 40dfc238156657da19ab222e150fccee0f983c42 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:43:02 +1100 Subject: [PATCH 06/68] normalise all alphas including intercept the 2D plot will take the raw parameters for the non normalised --- inst/stan/glm_multi_beta_binomial.stan | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 3321be7e..299b01e4 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -603,16 +603,11 @@ model{ generated quantities { matrix[A, M] alpha_normalised = alpha; - // Entanglement adjustment - if(intercept_in_design){ - if(A > 1) - for(a in 2:A) - alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2, a]); - } - else{ +// Entanglement adjustment + for(a in 1:A) alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2, a]); - } + // LOO vector[TNS] log_lik = rep_vector(0, TNS); From 1e135737cd3a67bdfa7bf8c3ce07a688eaf347c7 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:45:47 +1100 Subject: [PATCH 07/68] update model fitting to 1 prec_sd --- R/model_fitting.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/model_fitting.R b/R/model_fitting.R index 58f45a61..0283268d 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -3,7 +3,7 @@ fit_model = function( data_for_model, model_name, censoring_iteration = 1, cores = detectCores(), quantile = 0.95, warmup_samples = 300, approximate_posterior_inference = NULL, inference_method, verbose = TRUE, seed , pars = c("beta", "alpha", "prec_sd_1", "intercept_single", "slope_single", - "intercept_pair", "slope_1", "slope_2", "prec_sd_2"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, + "intercept_pair", "slope_1", "slope_2"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, output_directory = "sccomp_draws_files", sig_figs = 9, cache_stan_model = sccomp_stan_models_cache_dir, @@ -56,7 +56,6 @@ fit_model = function( init_list$intercept_pair = replicate(data_for_model$A, c(-1, 3), simplify = FALSE) init_list$slope_1 = rep(-0.5, data_for_model$A) init_list$slope_2 = rep(-0.5, data_for_model$A) - init_list$prec_sd_2 = c(1) } else { init_list$intercept_single = rep(5, data_for_model$A) init_list$slope_single = rep(-0.5, data_for_model$A) From 9e1ec960822509da1436b412ffd29fa535e3172e Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:58:08 +1100 Subject: [PATCH 08/68] update plot to accept intercept only model --- R/plot.R | 3 +-- man/plot.sccomp_tbl.Rd | 15 ++++++++++----- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/R/plot.R b/R/plot.R index 4ed34c87..e46f8236 100644 --- a/R/plot.R +++ b/R/plot.R @@ -231,7 +231,6 @@ plot_1D_intervals = function( plot_list = .data |> - filter(parameter != "(Intercept)") |> # Reshape data select(-contains("n_eff"), -contains("R_k_hat"), -contains("_ess"), -contains("_rhat")) |> @@ -285,7 +284,7 @@ plot_1D_intervals = function( geom_errorbar(color_aes) + geom_point() + color_scale + - xlab("Credible interval of the slope") + + xlab("Credible interval of the effect") + ylab("Cell group") + ggtitle(sprintf("%s %s", plot_which, plot_param)) + sccomp_theme() + diff --git a/man/plot.sccomp_tbl.Rd b/man/plot.sccomp_tbl.Rd index a79188b7..51a73605 100644 --- a/man/plot.sccomp_tbl.Rd +++ b/man/plot.sccomp_tbl.Rd @@ -7,17 +7,19 @@ \method{plot}{sccomp_tbl}( x, significance_threshold = 0.05, - test_composition_above_logit_fold_change = attr(.data, + test_composition_above_logit_fold_change = attr(x, "test_composition_above_logit_fold_change"), significance_statistic = c("pH0", "FDR"), show_fdr_message = TRUE, + add_marginal_density = TRUE, + sort_by = c("none", "effect", "significance", "alphabetical"), ... ) } \arguments{ \item{x}{A tibble including a cell_group name column | sample name column | read counts column | factor columns | Pvalue column | a significance column} -\item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.025.} +\item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.05.} \item{test_composition_above_logit_fold_change}{A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10\% for a cell type with baseline proportion of 50\%. That is, a cell type goes from 45\% to 50\%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale.} @@ -25,10 +27,12 @@ \item{show_fdr_message}{Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE.} +\item{add_marginal_density}{Logical. Whether to add marginal density plots on adjusted panels in 2D intervals. Default is TRUE.} + \item{...}{For internal use} } \value{ -A \code{ggplot} +A list containing ggplot objects } \description{ This function plots a summary of the results of the model. @@ -47,9 +51,10 @@ print("cmdstanr is needed to run this example.") counts_obj, ~ type, ~1, "sample", "cell_group", "count", cores = 1 - ) + ) |> + sccomp_test() - # estimate |> plot() + plots = estimate |> plot() } } From 2f95cdd803e5c4cdf578e30774187311d99c171e Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:58:24 +1100 Subject: [PATCH 09/68] add unit test for plotting intercept-only fit --- tests/testthat/test-plot.R | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 66e0ec27..c7c8dac3 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -40,6 +40,18 @@ if (instantiate::stan_cmdstan_exists()){ inference_method = "pathfinder", max_sampling_iterations = n_iterations, verbose=FALSE ) + + my_estimate_intercept_only = + seurat_obj |> + sccomp_estimate( + formula_composition = ~ 1, + formula_variability = ~ 1, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + verbose = FALSE + ) } # Test for plot_1d_intervals function @@ -54,6 +66,15 @@ test_that("plot_1d_intervals function works correctly", { expect_s3_class("patchwork") }) +test_that("plot_1D_intervals works with intercept-only composition", { + skip_cmdstan() + + my_estimate_intercept_only |> + sccomp_test() |> + plot_1D_intervals() |> + expect_s3_class("patchwork") +}) + # Test for plot_2d_intervals function test_that("plot_2d_intervals function works correctly", { skip_cmdstan() From a5498b7284695dad49e71d68c4685bc66dd85dc7 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:58:43 +1100 Subject: [PATCH 10/68] update docs --- man/plot_1D_intervals.Rd | 12 ++++++++---- man/plot_2D_intervals.Rd | 26 ++++++++++++++++--------- man/plot_scatterplot.Rd | 41 ---------------------------------------- 3 files changed, 25 insertions(+), 54 deletions(-) delete mode 100644 man/plot_scatterplot.Rd diff --git a/man/plot_1D_intervals.Rd b/man/plot_1D_intervals.Rd index f444003a..5ab7ae52 100644 --- a/man/plot_1D_intervals.Rd +++ b/man/plot_1D_intervals.Rd @@ -11,6 +11,7 @@ plot_1D_intervals( "test_composition_above_logit_fold_change"), show_fdr_message = TRUE, significance_statistic = c("pH0", "FDR") + sort_by = c("none", "effect", "significance", "alphabetical") ) } \arguments{ @@ -22,7 +23,10 @@ plot_1D_intervals( \item{show_fdr_message}{Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE.} + \item{significance_statistic}{Character vector indicating which statistic to highlight. Default is "pH0".} + +\item{sort_by}{Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical".} } \value{ A combined plot of 1D interval plots. @@ -46,12 +50,12 @@ print("cmdstanr is needed to run this example.") "cell_group", "count", cores = 1 - ) |> + ) |> sccomp_test() - + # Example usage: - my_plot = plot_1D_intervals(estimate) - + my_plot = plot_1D_intervals(estimate, sort_by = "effect") + } } diff --git a/man/plot_2D_intervals.Rd b/man/plot_2D_intervals.Rd index 5ba6f86d..dd1b0524 100644 --- a/man/plot_2D_intervals.Rd +++ b/man/plot_2D_intervals.Rd @@ -11,24 +11,31 @@ plot_2D_intervals( "test_composition_above_logit_fold_change"), show_fdr_message = TRUE, significance_statistic = c("pH0", "FDR") + model_type = NULL, + add_marginal_density = TRUE ) } \arguments{ \item{.data}{Data frame containing the main data.} -\item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.025.} +\item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.05.} -\item{test_composition_above_logit_fold_change}{A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10\% for a cell type with baseline proportion of 50\%. That is, a cell type goes from 45\% to 50\%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale.} +\item{test_composition_above_logit_fold_change}{A positive integer. It is the effect threshold used for the hypothesis test.} \item{show_fdr_message}{Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE.} \item{significance_statistic}{Character vector indicating which statistic to highlight. Default is "pH0".} + +\item{model_type}{Character indicating "single" or "bimodal" model type. If NULL, will be auto-detected from prec_coeff dimensions.} + +\item{add_marginal_density}{Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE.} } \value{ A ggplot object representing the 2D interval plot. } \description{ -This function creates a 2D interval plot for mean-variance association, highlighting significant differences based on a given significance threshold. +This function creates a 2D interval plot for mean-variance association, handling both single and bimodal models. +It highlights significant differences based on a given significance threshold. } \examples{ @@ -45,13 +52,14 @@ print("cmdstanr is needed to run this example.") "sample", "cell_group", "count", - cores = 1 - ) |> + cores = 1, + bimodal_mean_variability_association = TRUE + ) |> sccomp_test() - - # Example usage: - my_plot = plot_2D_intervals(estimate) - + + # Example usage: + my_plot = plot_2D_intervals(estimate) + } } diff --git a/man/plot_scatterplot.Rd b/man/plot_scatterplot.Rd deleted file mode 100644 index 5740c38a..00000000 --- a/man/plot_scatterplot.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{plot_scatterplot} -\alias{plot_scatterplot} -\title{Plot Scatterplot of Cell-group Proportion} -\usage{ -plot_scatterplot( - .data, - data_proportion, - factor_of_interest, - .cell_group, - .sample, - significance_threshold = 0.05, - my_theme -) -} -\arguments{ -\item{.data}{Data frame containing the main data.} - -\item{data_proportion}{Data frame containing proportions of cell groups.} - -\item{factor_of_interest}{A factor indicating the biological condition of interest.} - -\item{.cell_group}{The cell group to be analysed.} - -\item{.sample}{The sample identifier.} - -\item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.025.} - -\item{my_theme}{A ggplot2 theme object to be applied to the plot.} -} -\value{ -A ggplot object representing the scatterplot. -} -\description{ -This function creates a scatterplot of cell-group proportions, optionally highlighting significant differences based on a given significance threshold. -} -\examples{ -# Example usage: -# plot_scatterplot(.data, data_proportion, "condition", "cell_group", "sample", 0.025, theme_minimal()) -} From 814dcf8ad53561b97ab5a8c2cdeece2264048f22 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:59:01 +1100 Subject: [PATCH 11/68] drop prec_sd_2 from stan generation --- inst/stan/glm_multi_beta_binomial_generate_data.stan | 1 - 1 file changed, 1 deletion(-) diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index aba6e89b..47ae97d6 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -75,7 +75,6 @@ parameters { array[A * bimodal_mean_variability_association] real slope_2; array[A * (1 - bimodal_mean_variability_association)] real slope_single; real prec_sd_1; - array[bimodal_mean_variability_association] real prec_sd_2; real mix_p; // Random intercept // Using regular vectors instead of sum_to_zero_vector to avoid floating-point precision issues From 3570e02ed6e22dd8a2a6f2ab4159b4b09d350301 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 12:59:45 +1100 Subject: [PATCH 12/68] update NAMESPACE --- NAMESPACE | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 206c10fe..43392df1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,7 @@ importFrom(dplyr,all_of) importFrom(dplyr,any_of) importFrom(dplyr,arrange) importFrom(dplyr,as_tibble) +importFrom(dplyr,bind_rows) importFrom(dplyr,c_across) importFrom(dplyr,count) importFrom(dplyr,cummean) @@ -62,19 +63,35 @@ importFrom(dplyr,rename) importFrom(dplyr,row_number) importFrom(dplyr,rowwise) importFrom(dplyr,select) +importFrom(dplyr,slice) importFrom(dplyr,summarise) importFrom(dplyr,where) importFrom(dplyr,with_groups) importFrom(forcats,fct_relevel) importFrom(forcats,fct_reorder) importFrom(ggplot2,aes) -importFrom(ggplot2,annotate) +importFrom(ggplot2,coord_flip) +importFrom(ggplot2,element_rect) +importFrom(ggplot2,element_text) importFrom(ggplot2,facet_wrap) +importFrom(ggplot2,geom_area) importFrom(ggplot2,geom_errorbar) importFrom(ggplot2,geom_hline) +importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_point) importFrom(ggplot2,geom_vline) importFrom(ggplot2,ggplot) +importFrom(ggplot2,guide_legend) +importFrom(ggplot2,guides) +importFrom(ggplot2,labs) +importFrom(ggplot2,margin) +importFrom(ggplot2,scale_alpha_manual) +importFrom(ggplot2,scale_color_manual) +importFrom(ggplot2,scale_fill_manual) +importFrom(ggplot2,scale_y_continuous) +importFrom(ggplot2,theme) +importFrom(ggplot2,theme_bw) +importFrom(ggplot2,theme_void) importFrom(ggrepel,geom_text_repel) importFrom(glue,glue) importFrom(instantiate,stan_cmdstan_exists) @@ -90,6 +107,8 @@ importFrom(magrittr,multiply_by) importFrom(magrittr,not) importFrom(magrittr,subtract) importFrom(parallel,detectCores) +importFrom(patchwork,plot_annotation) +importFrom(patchwork,plot_layout) importFrom(patchwork,wrap_plots) importFrom(purrr,as_mapper) importFrom(purrr,map) From e51de8a1cd00c96aab56bc78fb0994a0faaf8856 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 14:33:09 +1100 Subject: [PATCH 13/68] Refactor model fitting and plotting to use new parameter structure for mean-variability regression. Replace 'prec_coeff' with 'prec_intercept' and 'prec_slope' parameters across relevant functions and Stan models. Update tests to reflect changes in parameter names and ensure compatibility with new structure. --- R/model_fitting.R | 19 +++-- R/plot.R | 67 +++++++-------- R/sccomp_estimate.R | 8 +- R/sccomp_remove_outliers.R | 12 ++- R/utilities.R | 5 +- inst/stan/glm_multi_beta_binomial.stan | 82 ++++++++----------- ...glm_multi_beta_binomial_generate_data.stan | 11 ++- tests/testthat/test-incorporate-parameters.R | 2 +- tests/testthat/test-plot.R | 11 ++- 9 files changed, 110 insertions(+), 107 deletions(-) diff --git a/R/model_fitting.R b/R/model_fitting.R index 0283268d..5dfe9615 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -2,8 +2,8 @@ fit_model = function( data_for_model, model_name, censoring_iteration = 1, cores = detectCores(), quantile = 0.95, warmup_samples = 300, approximate_posterior_inference = NULL, inference_method, verbose = TRUE, - seed , pars = c("beta", "alpha", "prec_sd_1", "intercept_single", "slope_single", - "intercept_pair", "slope_1", "slope_2"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, + seed , pars = c("beta", "alpha", "prec_sd", "prec_intercept_1", "prec_slope_1", + "prec_intercept_2", "prec_slope_2"), output_samples = NULL, chains=NULL, max_sampling_iterations = 20000, output_directory = "sccomp_draws_files", sig_figs = 9, cache_stan_model = sccomp_stan_models_cache_dir, @@ -48,17 +48,20 @@ fit_model = function( rep(0, (data_for_model$A - 1) * data_for_model$M)), nrow = data_for_model$A, byrow = TRUE), beta_raw = matrix(0, data_for_model$C, data_for_model$M), - prec_sd_1 = 1, + prec_sd = 1, mix_p = 0.1 ) + # Mean-variability regression: prec_coeff[1|4,a] ~ student_t(3, 4, 2), prec_coeff[2|3,a] ~ student_t(3, 0, 2). + # Intercepts are modelled as prec_intercept_1 (always) and prec_intercept_2 (bimodal only). if (data_for_model$bimodal_mean_variability_association == 1) { - init_list$intercept_pair = replicate(data_for_model$A, c(-1, 3), simplify = FALSE) - init_list$slope_1 = rep(-0.5, data_for_model$A) - init_list$slope_2 = rep(-0.5, data_for_model$A) + init_list$prec_intercept_1 = rep(3, data_for_model$A) + init_list$prec_intercept_2 = rep(5, data_for_model$A) + init_list$prec_slope_1 = rep(0, data_for_model$A) + init_list$prec_slope_2 = rep(0, data_for_model$A) } else { - init_list$intercept_single = rep(5, data_for_model$A) - init_list$slope_single = rep(-0.5, data_for_model$A) + init_list$prec_intercept_1 = rep(4, data_for_model$A) + init_list$prec_slope_1 = rep(0, data_for_model$A) } if(data_for_model$n_random_eff>0){ diff --git a/R/plot.R b/R/plot.R index e46f8236..0db8f379 100644 --- a/R/plot.R +++ b/R/plot.R @@ -326,7 +326,6 @@ plot_1D_intervals = function( #' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". -#' @param model_type Character indicating "single" or "bimodal" model type. If NULL, will be auto-detected from prec_coeff dimensions. #' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. #' #' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups @@ -371,8 +370,7 @@ plot_2D_intervals <- function( test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR"), - model_type = NULL, + significance_statistic = c("pH0", "FDR"), add_marginal_density = TRUE ) { @@ -402,9 +400,18 @@ plot_2D_intervals <- function( if(.data |> select(ends_with("FDR")) |> ncol() == 0) stop("sccomp says: you need to run sccomp_test() first.") - # Extract fitted model and prec_coeff + # Extract fitted model and mean-variability regression coefficients fit <- attr(.data, "fit") - prec_coeff_summary <- fit$summary("prec_coeff") + prec_intercept_1_summary <- fit$summary("prec_intercept_1") + prec_slope_1_summary <- fit$summary("prec_slope_1") + prec_intercept_2_summary <- tryCatch( + fit$summary("prec_intercept_2"), + error = function(e) tibble() + ) + prec_slope_2_summary <- tryCatch( + fit$summary("prec_slope_2"), + error = function(e) tibble() + ) # Get number of parameters (effects) n_params <- .data |> @@ -412,32 +419,25 @@ plot_2D_intervals <- function( distinct(parameter) |> nrow() - # Auto-detect model type if not specified - if (is.null(model_type)) { - n_prec_coeff <- nrow(prec_coeff_summary) - if (n_prec_coeff == 2 * n_params) { - model_type <- "single" - } else if (n_prec_coeff == 4 * n_params) { - model_type <- "bimodal" - } else { - stop("Cannot auto-detect model type from prec_coeff dimensions") - } + # Derive model type from stored model metadata + bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association + if (is.null(bimodal_flag)) { + stop("sccomp says: cannot infer model type because `bimodal_mean_variability_association` is missing from model metadata.") } + bimodal_flag <- isTRUE(as.logical(bimodal_flag)) # Extract parameters based on model type - if (model_type == "single") { + if (!bimodal_flag) { params_list <- lapply(1:n_params, function(a) { param_name <- .data |> filter(!is.na(v_effect)) |> distinct(parameter) |> slice(a) |> pull(parameter) - intercept_idx <- 2 * (a - 1) + 1 - slope_idx <- 2 * (a - 1) + 2 list( parameter = param_name, - intercept = prec_coeff_summary$mean[intercept_idx], - slope = prec_coeff_summary$mean[slope_idx] + intercept = prec_intercept_1_summary$mean[a], + slope = prec_slope_1_summary$mean[a] ) }) @@ -461,10 +461,10 @@ plot_2D_intervals <- function( list( parameter = param_name, - intercept_1 = prec_coeff_summary$mean[1 + (a-1)*4], - slope_1 = prec_coeff_summary$mean[2 + (a-1)*4], - slope_2 = prec_coeff_summary$mean[3 + (a-1)*4], - intercept_2 = prec_coeff_summary$mean[4 + (a-1)*4] + intercept_1 = prec_intercept_1_summary$mean[a], + slope_1 = prec_slope_1_summary$mean[a], + slope_2 = prec_slope_2_summary$mean[a], + intercept_2 = prec_intercept_2_summary$mean[a] ) }) @@ -482,7 +482,7 @@ plot_2D_intervals <- function( # "unadjusted" panel: ADD BACK entanglement to show raw alpha # "adjusted" panel: USE v_effect AS-IS - if (model_type == "single") { + if (!bimodal_flag) { .data_unadjusted_list <- lapply(params_list, function(params) { .data %>% filter(parameter == params$parameter) %>% @@ -603,7 +603,7 @@ plot_2D_intervals <- function( } # Prepare regression line data based on model type - if (model_type == "single") { + if (!bimodal_flag) { regression_data_all <- lapply(params_list, function(params) { unadj_param <- paste0(params$parameter, ", unadjusted") param_data <- .data_plot %>% filter(parameter == unadj_param) @@ -698,6 +698,7 @@ plot_2D_intervals <- function( # Add caption based on model type if (significance_statistic == "FDR" && show_fdr_message) { + plot <- plot + ggplot2::labs(caption = caption_text) plot <- plot + theme(plot.caption = ggplot2::element_text(hjust = 0)) } @@ -822,7 +823,7 @@ plot_scatterplot = function( inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group, !!.sample)) , color="blue", fill="blue", span = 1 - ) + ) } if( @@ -875,7 +876,7 @@ plot_scatterplot = function( ) # Add regression lines - if (model_type == "single") { + if (!bimodal_flag) { reg_data <- regression_data_all %>% filter(parameter == param) if(!is.null(reg_data) && nrow(reg_data) > 0) { p_param <- p_param + @@ -941,11 +942,11 @@ plot_scatterplot = function( # Add marginal density for adjusted panels (not Intercept) if (str_detect(param, "adjusted") && !str_detect(param, "unadjusted") && !str_detect(param, "Intercept")) { - if (model_type == "single") { + if (!bimodal_flag) { param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) if (length(param_idx) > 0) { - intercept_var_name <- paste0("prec_coeff[1,", param_idx, "]") + intercept_var_name <- paste0("prec_intercept_1[", param_idx, "]") tryCatch({ intercept_draws <- fit$draws(variables = intercept_var_name, format = "draws_df") @@ -984,8 +985,8 @@ plot_scatterplot = function( param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) if (length(param_idx) > 0) { - intercept1_var_name <- paste0("prec_coeff[1,", param_idx, "]") - intercept2_var_name <- paste0("prec_coeff[4,", param_idx, "]") + intercept1_var_name <- paste0("prec_intercept_1[", param_idx, "]") + intercept2_var_name <- paste0("prec_intercept_2[", param_idx, "]") tryCatch({ intercept1_draws <- fit$draws(variables = intercept1_var_name, format = "draws_df") @@ -1062,7 +1063,7 @@ plot_scatterplot = function( ) # Add regression lines - if (model_type == "single") { + if (!bimodal_flag) { if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { p <- p + geom_line(data = regression_data_all, mapping = aes(c_effect, v_effect), color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index 9a716d5e..a4406dbd 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -1062,9 +1062,11 @@ sccomp_glm_data_frame_counts = function(.data, seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, pars = c( - "beta", "alpha", "prec_coeff","prec_sd", "alpha_normalised", - "random_effect", "random_effect_2", - "random_effect_sigma", "random_effect_sigma_2", + "beta", "alpha", + "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", + "prec_sd", "alpha_normalised", + "random_effect", "random_effect_2", + "random_effect_sigma", "random_effect_sigma_2", "log_lik" ), sig_figs = sig_figs, diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index e9971b78..afd19458 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -329,7 +329,11 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, verbose = verbose, seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, - pars = c("beta", "alpha", "prec_coeff", "prec_sd", "alpha_normalised", "random_effect", "random_effect_2"), + pars = c( + "beta", "alpha", + "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", + "alpha_normalised", "random_effect", "random_effect_2" + ), sig_figs = sig_figs, cache_stan_model = cache_stan_model, ... @@ -461,7 +465,11 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, verbose = verbose, seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, - pars = c("beta", "alpha", "prec_coeff","prec_sd", "alpha_normalised", "random_effect", "random_effect_2", "log_lik"), + pars = c( + "beta", "alpha", + "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", + "alpha_normalised", "random_effect", "random_effect_2", "log_lik" + ), cache_stan_model = cache_stan_model, ... ) diff --git a/R/utilities.R b/R/utilities.R index 5e033aae..4d6b6dc0 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -76,7 +76,10 @@ incorporate_parameters_into_fit_object = function(fit) { # Parameters block "beta_raw", "alpha", - "prec_coeff", + "prec_intercept_1", + "prec_slope_1", + "prec_intercept_2", + "prec_slope_2", "prec_sd", "mix_p", "random_effect_raw", diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 299b01e4..ce72b7f7 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -18,7 +18,17 @@ functions{ } - real abundance_variability_regression(row_vector variability, row_vector abundance, array[] real prec_coeff, real prec_sd, int bimodal_mean_variability_association, real mix_p){ + real abundance_variability_regression( + row_vector variability, + row_vector abundance, + real prec_intercept_1, + real prec_slope_1, + real prec_slope_2, + real prec_intercept_2, + real prec_sd, + int bimodal_mean_variability_association, + real mix_p + ){ real lp = 0; int nu = 3; @@ -27,17 +37,17 @@ functions{ for(m in 1:cols(variability)) lp += log_mix(mix_p, student_t_lpdf(variability[m] | nu, - abundance[m] * prec_coeff[2] + prec_coeff[1], + abundance[m] * prec_slope_1 + prec_intercept_1, prec_sd), student_t_lpdf(variability[m] | nu, - abundance[m] * prec_coeff[3] + prec_coeff[4], + abundance[m] * prec_slope_2 + prec_intercept_2, prec_sd) ); // If no bimodal } else { lp = student_t_lpdf(variability | nu, - abundance * prec_coeff[2] + prec_coeff[1], + abundance * prec_slope_1 + prec_intercept_1, prec_sd); } @@ -344,15 +354,13 @@ parameters{ // Use the new sum_to_zero_vector type instead of QR decomposition array[C] sum_to_zero_vector[M] beta_raw; // Each row is a sum_to_zero_vector of length M matrix[A, M] alpha; // Variability - // To exclude - // row 1: i1, row 2: s1, row 3: i2 - array[A * bimodal_mean_variability_association] ordered[2] intercept_pair; // i1, i2 - array[A * (1 - bimodal_mean_variability_association)] real intercept_single; - // Slopes: per-effect for bimodal, global for single - array[A * bimodal_mean_variability_association] real slope_1; - array[A * bimodal_mean_variability_association] real slope_2; - array[A * (1 - bimodal_mean_variability_association)] real slope_single; - real prec_sd_1; // residual scale for mean–variability association (single or bimodal) + // Mean-variability intercepts + array[A] real prec_intercept_1; // i1, always present + array[A * bimodal_mean_variability_association] real prec_intercept_2; // i2, only for bimodal + // Mean-variability slopes + array[A] real prec_slope_1; // s1, always present + array[A * bimodal_mean_variability_association] real prec_slope_2; // s2, only for bimodal + real prec_sd; // residual scale for mean–variability association (single or bimodal) real mix_p; // Random intercept // array of sum_to_zero_vector for each random effect @@ -387,21 +395,6 @@ transformed parameters{ beta[c,] = to_row_vector(beta_raw[c]); } - // Unified prec_coeff for likelihood / priors / generated quantities. Cannot be - // declared as a single matrix in parameters: bimodal needs ordered[2] (i1, which do not map to one unconstrained matrix. - matrix[4, A] prec_coeff = rep_matrix(0, 4, A); - for(a in 1:A){ - if(bimodal_mean_variability_association == 1){ - prec_coeff[1, a] = intercept_pair[a][1]; - prec_coeff[2, a] = slope_1[a]; - prec_coeff[3, a] = slope_2[a]; - prec_coeff[4, a] = intercept_pair[a][2]; - } else { - prec_coeff[1, a] = intercept_single[a]; - prec_coeff[2, a] = slope_single[a]; - } - } real mix_p_scalar = bimodal_mean_variability_association == 1 ? mix_p : 0.5; // Non centered parameterisation SD of random effects @@ -521,23 +514,14 @@ model{ // Per-effect regression (optional for testing) if(exclude_priors == 0){ for(a in 1:A){ - array[4] real prec_coeff_a; - prec_coeff_a[1] = prec_coeff[1, a]; - prec_coeff_a[2] = prec_coeff[2, a]; - if(bimodal_mean_variability_association == 1){ - prec_coeff_a[3] = prec_coeff[3, a]; - prec_coeff_a[4] = prec_coeff[4, a]; - } else { - // Unused in single-mode branch inside abundance_variability_regression(). - prec_coeff_a[3] = 0; - prec_coeff_a[4] = 0; - } - target += abundance_variability_regression( alpha[a], beta[a], - prec_coeff_a, - prec_sd_1, + prec_intercept_1[a], + prec_slope_1[a], + bimodal_mean_variability_association == 1 ? prec_slope_2[a] : 0, + bimodal_mean_variability_association == 1 ? prec_intercept_2[a] : 0, + prec_sd, bimodal_mean_variability_association, mix_p_scalar ); @@ -552,21 +536,21 @@ model{ } } - // Hyper priors: i1/s1 (and prec_sd_1) shared; bimodal adds i2/s2 and mix_p shape + // Hyper priors: i1/s1 (and prec_sd) shared; bimodal adds i2/s2 and mix_p shape if(bimodal_mean_variability_association == 1) mix_p ~ beta(1, 5); else mix_p ~ beta(1, 1); for(a in 1:A){ - prec_coeff[1, a] ~ student_t(3, 4, 2); // i1 - prec_coeff[2, a] ~ student_t(3, 0, 2); // s1 + prec_intercept_1[a] ~ student_t(3, 4, 2); // i1 + prec_slope_1[a] ~ student_t(3, 0, 2); // s1 if(bimodal_mean_variability_association == 1){ - prec_coeff[4, a] ~ student_t(3, 4, 2); // i2 - prec_coeff[3, a] ~ student_t(3, 0, 2); // s2 + prec_intercept_2[a] ~ student_t(3, 4, 2); // i2 + prec_slope_2[a] ~ student_t(3, 0, 2); // s2 } } - prec_sd_1 ~ normal(0, 1) T[0,]; + prec_sd ~ normal(0, 1) T[0,]; // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); @@ -606,7 +590,7 @@ generated quantities { // Entanglement adjustment for(a in 1:A) - alpha_normalised[a] = alpha[a] - (beta[a] * prec_coeff[2, a]); + alpha_normalised[a] = alpha[a] - (beta[a] * prec_slope_1[a]); // LOO diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 47ae97d6..01c18cf1 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -69,12 +69,11 @@ parameters { array[C] vector[M] beta_raw; // Each row is a vector of length M matrix[A, M] alpha; // Variability - array[A * bimodal_mean_variability_association] ordered[2] intercept_pair; - array[A * (1 - bimodal_mean_variability_association)] real intercept_single; - array[A * bimodal_mean_variability_association] real slope_1; - array[A * bimodal_mean_variability_association] real slope_2; - array[A * (1 - bimodal_mean_variability_association)] real slope_single; - real prec_sd_1; + array[A] real prec_intercept_1; + array[A * bimodal_mean_variability_association] real prec_intercept_2; + array[A] real prec_slope_1; + array[A * bimodal_mean_variability_association] real prec_slope_2; + real prec_sd; real mix_p; // Random intercept // Using regular vectors instead of sum_to_zero_vector to avoid floating-point precision issues diff --git a/tests/testthat/test-incorporate-parameters.R b/tests/testthat/test-incorporate-parameters.R index 8ce3dabe..f04902d4 100644 --- a/tests/testthat/test-incorporate-parameters.R +++ b/tests/testthat/test-incorporate-parameters.R @@ -50,7 +50,7 @@ test_that("incorporate_parameters_into_fit_object loads all parameters", { }) expect_no_error({ - prec_coeff_draws <- fit$draws(variables = "prec_coeff", format = "draws_df") + prec_intercept_draws <- fit$draws(variables = "prec_intercept_1", format = "draws_df") }) # Now delete the CSV files to simulate cleanup diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index c7c8dac3..17a06b12 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -304,7 +304,7 @@ test_that("significance_statistic and show_fdr_message work via plot() S3 method expect_true(grepl("Bayesian FDR", fdr_plot$labels$caption)) expect_true(is.null(ph0_plot$labels$caption) || !grepl("Bayesian FDR", ph0_plot$labels$caption)) }) -test_that("plot_2D_intervals includes regression line from prec_coeff parameters", { +test_that("plot_2D_intervals includes regression line from prec parameters", { skip_cmdstan() plot_2d <- my_estimate_with_variance |> @@ -314,10 +314,13 @@ test_that("plot_2D_intervals includes regression line from prec_coeff parameters expect_s3_class(plot_2d, "patchwork") fit <- attr(my_estimate_with_variance |> sccomp_test(), "fit") - prec_coeff_summary <- fit$summary("prec_coeff") + prec_intercept_summary <- fit$summary("prec_intercept_1") + prec_slope_summary <- fit$summary("prec_slope_1") - expect_true(nrow(prec_coeff_summary) >= 2) - expect_true(all(c("prec_coeff[1,1]", "prec_coeff[2,1]") %in% prec_coeff_summary$variable)) + expect_true(nrow(prec_intercept_summary) >= 1) + expect_true(nrow(prec_slope_summary) >= 1) + expect_true(any(grepl("^prec_intercept_1\\[1\\]$", prec_intercept_summary$variable))) + expect_true(any(grepl("^prec_slope_1\\[1\\]$", prec_slope_summary$variable))) expect_no_error( my_estimate_with_variance |> From 6a9fd3c028ad6b22cf7bff93d08af3a7ebaa35c4 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 14:43:05 +1100 Subject: [PATCH 14/68] Enhance model fitting by introducing conditional initialization for intercept parameters based on design specifications. Update Stan model to reflect intercept-centered priors for the first column and zero-centered priors for others, improving flexibility in handling variability associations. --- R/model_fitting.R | 14 +++++++++++--- inst/stan/glm_multi_beta_binomial.stan | 12 ++++++++++-- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/R/model_fitting.R b/R/model_fitting.R index 5dfe9615..05224889 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -54,13 +54,21 @@ fit_model = function( # Mean-variability regression: prec_coeff[1|4,a] ~ student_t(3, 4, 2), prec_coeff[2|3,a] ~ student_t(3, 0, 2). # Intercepts are modelled as prec_intercept_1 (always) and prec_intercept_2 (bimodal only). + has_variability_intercept <- isTRUE(as.logical(data_for_model$intercept_in_design)) + if (has_variability_intercept && data_for_model$A > 1) { + init_prec_intercept_1 <- c(4, rep(0, data_for_model$A - 1)) + init_prec_intercept_2 <- c(5, rep(0, data_for_model$A - 1)) + } else { + init_prec_intercept_1 <- rep(4, data_for_model$A) + init_prec_intercept_2 <- rep(5, data_for_model$A) + } if (data_for_model$bimodal_mean_variability_association == 1) { - init_list$prec_intercept_1 = rep(3, data_for_model$A) - init_list$prec_intercept_2 = rep(5, data_for_model$A) + init_list$prec_intercept_1 = init_prec_intercept_1 + init_list$prec_intercept_2 = init_prec_intercept_2 init_list$prec_slope_1 = rep(0, data_for_model$A) init_list$prec_slope_2 = rep(0, data_for_model$A) } else { - init_list$prec_intercept_1 = rep(4, data_for_model$A) + init_list$prec_intercept_1 = init_prec_intercept_1 init_list$prec_slope_1 = rep(0, data_for_model$A) } diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index ce72b7f7..683e4bf3 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -543,10 +543,18 @@ model{ mix_p ~ beta(1, 1); for(a in 1:A){ - prec_intercept_1[a] ~ student_t(3, 4, 2); // i1 + // If design has intercept, first column gets intercept-centred prior, others are centred at 0. + if(intercept_in_design == 1 && a == 1){ + prec_intercept_1[a] ~ student_t(3, 4, 2); // i1, intercept column + if(bimodal_mean_variability_association == 1) + prec_intercept_2[a] ~ student_t(3, 4, 2); // i2, intercept column + } else { + prec_intercept_1[a] ~ student_t(3, 0, 2); // i1, non-intercept columns + if(bimodal_mean_variability_association == 1) + prec_intercept_2[a] ~ student_t(3, 0, 2); // i2, non-intercept columns + } prec_slope_1[a] ~ student_t(3, 0, 2); // s1 if(bimodal_mean_variability_association == 1){ - prec_intercept_2[a] ~ student_t(3, 4, 2); // i2 prec_slope_2[a] ~ student_t(3, 0, 2); // s2 } } From 2c0e74908105b0571922a027042ce572a172e37d Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 15:12:06 +1100 Subject: [PATCH 15/68] Update documentation for plotting functions and residuals calculation. Added missing commas in `plot_1D_intervals` and `plot_2D_intervals` documentation. Clarified description of `residuals_unconstrained` in `sccomp_calculate_residuals` to specify the calculation method and added details on residuals computation on both proportion and unconstrained scales. --- man/plot_1D_intervals.Rd | 3 +-- man/plot_2D_intervals.Rd | 5 +---- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/man/plot_1D_intervals.Rd b/man/plot_1D_intervals.Rd index 5ab7ae52..e92135a2 100644 --- a/man/plot_1D_intervals.Rd +++ b/man/plot_1D_intervals.Rd @@ -10,7 +10,7 @@ plot_1D_intervals( test_composition_above_logit_fold_change = attr(.data, "test_composition_above_logit_fold_change"), show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR") + significance_statistic = c("pH0", "FDR"), sort_by = c("none", "effect", "significance", "alphabetical") ) } @@ -23,7 +23,6 @@ plot_1D_intervals( \item{show_fdr_message}{Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE.} - \item{significance_statistic}{Character vector indicating which statistic to highlight. Default is "pH0".} \item{sort_by}{Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical".} diff --git a/man/plot_2D_intervals.Rd b/man/plot_2D_intervals.Rd index dd1b0524..f745b6b2 100644 --- a/man/plot_2D_intervals.Rd +++ b/man/plot_2D_intervals.Rd @@ -10,8 +10,7 @@ plot_2D_intervals( test_composition_above_logit_fold_change = attr(.data, "test_composition_above_logit_fold_change"), show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR") - model_type = NULL, + significance_statistic = c("pH0", "FDR"), add_marginal_density = TRUE ) } @@ -26,8 +25,6 @@ plot_2D_intervals( \item{significance_statistic}{Character vector indicating which statistic to highlight. Default is "pH0".} -\item{model_type}{Character indicating "single" or "bimodal" model type. If NULL, will be auto-detected from prec_coeff dimensions.} - \item{add_marginal_density}{Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE.} } \value{ From 57a3d8a5144b0e28cbc7b8cb9778ab6c420252f3 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 15:19:27 +1100 Subject: [PATCH 16/68] Remove hyper priors from the Stan model for multi beta-binomial regression, streamlining the parameterization and reducing complexity in the model specification. --- inst/stan/glm_multi_beta_binomial.stan | 9 --------- 1 file changed, 9 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 683e4bf3..51645a12 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -564,15 +564,6 @@ model{ for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); if(C>B_intercept_columns) for(c in (B_intercept_columns+1):C) beta_raw[c] ~ normal ( prior_mean_coefficients[1], prior_mean_coefficients[2] * inv(sqrt(1 - inv(M))) ); - // Hyper priors - mix_p ~ beta(1,5); - prec_coeff[1] ~ normal(prior_prec_intercept[1], prior_prec_intercept[2]); - prec_coeff[2] ~ normal(prior_prec_slope[1],prior_prec_slope[2]); - prec_sd ~ gamma(prior_prec_sd[1],prior_prec_sd[2]); - // prec_coeff ~ std_normal(); // prior imposed again for prec_coeff, should delete this line, and maybe the comment below - // Note: sum_to_zero_vector has built-in priors, no need for explicit std_normal() - - // Random intercept if(is_random_effect>0){ From 78313bc25b2529f9c633f0c240d1606827dd2a38 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 18:32:16 +1100 Subject: [PATCH 17/68] Refactor Stan model parameters for mean-variability regression by consolidating intercepts into a single array structure. Update initialization logic in model fitting to accommodate bimodal associations and streamline loading of Stan models by preferring local sources. Enhance documentation for model loading function to clarify parameter usage. --- R/model_fitting.R | 28 +++++++++---------- inst/stan/glm_multi_beta_binomial.stan | 21 +++++++++----- ...glm_multi_beta_binomial_generate_data.stan | 13 +++++++-- 3 files changed, 39 insertions(+), 23 deletions(-) diff --git a/R/model_fitting.R b/R/model_fitting.R index 05224889..21b2f513 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -52,24 +52,24 @@ fit_model = function( mix_p = 0.1 ) - # Mean-variability regression: prec_coeff[1|4,a] ~ student_t(3, 4, 2), prec_coeff[2|3,a] ~ student_t(3, 0, 2). - # Intercepts are modelled as prec_intercept_1 (always) and prec_intercept_2 (bimodal only). has_variability_intercept <- isTRUE(as.logical(data_for_model$intercept_in_design)) - if (has_variability_intercept && data_for_model$A > 1) { - init_prec_intercept_1 <- c(4, rep(0, data_for_model$A - 1)) - init_prec_intercept_2 <- c(5, rep(0, data_for_model$A - 1)) - } else { - init_prec_intercept_1 <- rep(4, data_for_model$A) - init_prec_intercept_2 <- rep(5, data_for_model$A) + bimodal <- data_for_model$bimodal_mean_variability_association == 1L + init_list$prec_intercept <- vector("list", data_for_model$A) + for (a in seq_len(data_for_model$A)) { + intercept_col <- has_variability_intercept && a == 1L + init_list$prec_intercept[[a]] <- if (bimodal) { + if (intercept_col) c(4, 5) + else if (has_variability_intercept) c(0, 1) + else c(4, 5) + } else { + if (intercept_col) c(4) + else if (has_variability_intercept) c(0) + else c(4) + } } + init_list$prec_slope_1 = rep(0, data_for_model$A) if (data_for_model$bimodal_mean_variability_association == 1) { - init_list$prec_intercept_1 = init_prec_intercept_1 - init_list$prec_intercept_2 = init_prec_intercept_2 - init_list$prec_slope_1 = rep(0, data_for_model$A) init_list$prec_slope_2 = rep(0, data_for_model$A) - } else { - init_list$prec_intercept_1 = init_prec_intercept_1 - init_list$prec_slope_1 = rep(0, data_for_model$A) } if(data_for_model$n_random_eff>0){ diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 51645a12..1aaace7c 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -354,9 +354,8 @@ parameters{ // Use the new sum_to_zero_vector type instead of QR decomposition array[C] sum_to_zero_vector[M] beta_raw; // Each row is a sum_to_zero_vector of length M matrix[A, M] alpha; // Variability - // Mean-variability intercepts - array[A] real prec_intercept_1; // i1, always present - array[A * bimodal_mean_variability_association] real prec_intercept_2; // i2, only for bimodal + // Mean-variability intercepts: length 1 if unimodal, length 2 (strictly increasing) if bimodal. + array[A] ordered[1 + bimodal_mean_variability_association] prec_intercept; // Mean-variability slopes array[A] real prec_slope_1; // s1, always present array[A * bimodal_mean_variability_association] real prec_slope_2; // s2, only for bimodal @@ -386,6 +385,14 @@ parameters{ } transformed parameters{ + array[A] real prec_intercept_1; + array[A * bimodal_mean_variability_association] real prec_intercept_2; + for (a in 1:A) { + prec_intercept_1[a] = prec_intercept[a][1]; + if (bimodal_mean_variability_association == 1) + prec_intercept_2[a] = prec_intercept[a][2]; + } + // Initialisation matrix[C,M] beta; matrix[M, N] precision = (Xa * alpha)'; @@ -545,13 +552,13 @@ model{ for(a in 1:A){ // If design has intercept, first column gets intercept-centred prior, others are centred at 0. if(intercept_in_design == 1 && a == 1){ - prec_intercept_1[a] ~ student_t(3, 4, 2); // i1, intercept column + prec_intercept[a][1] ~ student_t(3, 4, 2); if(bimodal_mean_variability_association == 1) - prec_intercept_2[a] ~ student_t(3, 4, 2); // i2, intercept column + prec_intercept[a][2] ~ student_t(3, 4, 2); } else { - prec_intercept_1[a] ~ student_t(3, 0, 2); // i1, non-intercept columns + prec_intercept[a][1] ~ student_t(3, 0, 2); if(bimodal_mean_variability_association == 1) - prec_intercept_2[a] ~ student_t(3, 0, 2); // i2, non-intercept columns + prec_intercept[a][2] ~ student_t(3, 0, 2); } prec_slope_1[a] ~ student_t(3, 0, 2); // s1 if(bimodal_mean_variability_association == 1){ diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 01c18cf1..2fb9d966 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -69,8 +69,7 @@ parameters { array[C] vector[M] beta_raw; // Each row is a vector of length M matrix[A, M] alpha; // Variability - array[A] real prec_intercept_1; - array[A * bimodal_mean_variability_association] real prec_intercept_2; + array[A] ordered[1 + bimodal_mean_variability_association] prec_intercept; array[A] real prec_slope_1; array[A * bimodal_mean_variability_association] real prec_slope_2; real prec_sd; @@ -99,6 +98,16 @@ parameters { } +transformed parameters { + array[A] real prec_intercept_1; + array[A * bimodal_mean_variability_association] real prec_intercept_2; + for (a in 1:A) { + prec_intercept_1[a] = prec_intercept[a][1]; + if (bimodal_mean_variability_association == 1) + prec_intercept_2[a] = prec_intercept[a][2]; + } +} + generated quantities{ array[N, M] int counts_uncorrected; From 57a0b1e63513025e108a5aeecf065c08ce930552 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 18:32:43 +1100 Subject: [PATCH 18/68] Enhance plotting functionality by introducing a new `plot_scatterplot` function for visualizing cell-group proportions. Update `plot.sccomp_tbl` to utilize quosures for improved data handling and streamline the integration of significance thresholds in scatterplots. Add detailed documentation for the new plotting function, including parameters and return values. --- R/plot.R | 199 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 193 insertions(+), 6 deletions(-) diff --git a/R/plot.R b/R/plot.R index 0db8f379..36a358d9 100644 --- a/R/plot.R +++ b/R/plot.R @@ -55,6 +55,11 @@ plot.sccomp_tbl <- function( significance_statistic <- match.arg(significance_statistic) sort_by <- match.arg(sort_by) + # Quosures from estimate (same names as legacy `.cell_group` args; stored on tbl attributes) + .sample <- attr(x, ".sample") + .cell_group <- attr(x, ".cell_group") + .count <- attr(x, ".count") + # Define the variables as NULL to avoid CRAN NOTES v_effect <- NULL @@ -72,7 +77,8 @@ plot.sccomp_tbl <- function( pivot_wider(names_from = parameter, values_from = c(contains("c_"), contains("v_"))) |> left_join( - count_data, by = join_by(!!.cell_group) + attr(x, "count_data"), + by = join_by(!!.cell_group) ) |> with_groups(!!.sample, ~ mutate(.x, proportion = (!!.count)/sum(!!.count)) ) @@ -106,15 +112,13 @@ plot.sccomp_tbl <- function( # If variable is continuous if(data_proportion |> select(all_of(.x)) |> pull(1) |> is("numeric")) - my_plot = + my_plot = plot_scatterplot( .data = x, data_proportion = data_proportion, factor_of_interest = .x, - .cell_group = !!.cell_group, - .sample = !!.sample, - my_theme = sccomp_theme(), - significance_threshold = significance_threshold + significance_threshold = significance_threshold, + my_theme = sccomp_theme() ) # If discrete @@ -1125,3 +1129,186 @@ plot_scatterplot = function( return(p) } } + +#' Plot Scatterplot of Cell-group Proportion +#' +#' This function creates a scatterplot of cell-group proportions, optionally +#' highlighting significant differences based on a given significance threshold. +#' +#' @param .data Data frame containing the main data. +#' @param data_proportion Data frame containing proportions of cell groups. +#' @param factor_of_interest A factor indicating the biological condition of interest. +#' @param significance_threshold Numeric value specifying the significance threshold +#' for highlighting differences. Default is 0.05. +#' @param my_theme A ggplot2 theme object to be applied to the plot. +#' @importFrom scales trans_new +#' @importFrom stringr str_replace str_detect +#' +#' @return A ggplot object representing the scatterplot. +#' +#' @noRd +plot_scatterplot = function( + .data, data_proportion, factor_of_interest, + significance_threshold = 0.05, my_theme +){ + + # Define the variables as NULL to avoid CRAN NOTES + stats_name <- NULL + parameter <- NULL + stats_value <- NULL + count_data <- NULL + generated_proportions <- NULL + proportion <- NULL + name <- NULL + outlier <- NULL + + # Function to remove leading zero from labels + dropLeadingZero <- function(l){ stringr::str_replace(l, '0(?=.)', '') } + + # Define square root transformation and its inverse + S_sqrt <- function(x){sign(x)*sqrt(abs(x))} + IS_sqrt <- function(x){x^2*sign(x)} + S_sqrt_trans <- function() scales::trans_new("S_sqrt",S_sqrt,IS_sqrt) + + .cell_group = attr(.data, ".cell_group") + .count = attr(.data, ".count") + .sample = attr(.data, ".sample") + + # Prepare significance colors + significance_colors = + .data %>% + pivot_longer( + c(contains("c_"), contains("v_")), + names_pattern = "([cv])_([a-zA-Z0-9]+)", + names_to = c("which", "stats_name"), + values_to = "stats_value" + ) %>% + filter(stats_name == "FDR") %>% + filter(parameter != "(Intercept)") %>% + filter(stats_value < significance_threshold) %>% + filter(`factor` == factor_of_interest) + + if(nrow(significance_colors) > 0){ + + if(.data |> attr("contrasts") |> is.null()) + significance_colors = + significance_colors %>% + unite("name", c(which, parameter), remove = FALSE) %>% + distinct() %>% + + # Get clean parameter + mutate(!!as.symbol(factor_of_interest) := str_replace(parameter, sprintf("^%s", `factor`), "")) %>% + with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) + else + significance_colors = + significance_colors |> + mutate( + factor_values = attr(.data, "count_data") |> + select(all_of(factor_of_interest)) |> + distinct() |> + pull(all_of(factor_of_interest)) + ) |> + unnest(factor_values) |> + + # Filter relevant parameters + mutate( !!as.symbol(factor_of_interest) := as.character(factor_values) ) |> + filter(str_detect(parameter, !!as.symbol(factor_of_interest) )) |> + + # Rename + select(!!.cell_group, !!as.symbol(factor_of_interest), name = parameter) |> + + # Merge contrasts + with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) + } + + my_scatterplot = ggplot() + + if("fit" %in% names(attributes(.data))){ + + simulated_proportion = + .data |> + sccomp_replicate(number_of_draws = 1000) |> + left_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.sample, !!.cell_group)) + + my_scatterplot = + my_scatterplot + + + # Add smoothed line for simulated proportions + geom_smooth( + aes(!!as.symbol(factor_of_interest), (generated_proportions)), + lwd=0.2, + data = + simulated_proportion %>% + inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group, !!.sample)) , + color="blue", fill="blue", + span = 1 + ) + } + + if( + nrow(significance_colors)==0 || + + significance_colors |> + pull(!!as.symbol(factor_of_interest)) |> + intersect( + data_proportion |> + pull(!!as.symbol(factor_of_interest)) + ) |> + length() |> + equals(0) + ) { + + my_scatterplot= + my_scatterplot + + + # Add smoothed line without significance colors + geom_smooth( + aes(!!as.symbol(factor_of_interest), proportion, fill = NULL), + data = + data_proportion , + lwd=0.5, + color = "black", + span = 1 + ) + } else { + my_scatterplot= + my_scatterplot + + + # Add smoothed line with significance colors + geom_smooth( + aes(!!as.symbol(factor_of_interest), proportion, fill = name), + data = data_proportion , + fatten = 0.5, + lwd=0.5, + color = "black", + span = 1 + ) + } + + my_scatterplot + + + # Add jittered points for individual data + geom_point( + aes(!!as.symbol(factor_of_interest), proportion, shape=outlier, color=outlier), + data = data_proportion, + position=position_jitterdodge(jitter.height = 0, jitter.width = 0.2), + size = 0.5 + ) + + + # Facet wrap by cell group + facet_wrap( + vars(!!.cell_group), + scales = "free_y", + nrow = 4 + ) + + scale_color_manual(values = c("black", "#e11f28")) + + scale_y_continuous(trans=S_sqrt_trans(), labels = dropLeadingZero) + + scale_fill_discrete(na.value = "white") + + xlab("Biological condition") + + ylab("Cell-group proportion") + + guides(color="none", alpha="none", size="none") + + labs(fill="Significant difference") + + ggtitle("Note: Be careful judging significance (or outliers) visually for lowly abundant cell groups. \nVisualising proportion hides the uncertainty characteristic of count data, that a count-based statistical model can estimate.") + + my_theme + + theme(axis.text.x = element_text(angle=20, hjust = 1), title = element_text(size = 3)) +} From 2e66340466aa7c0f488ac7fbc260350c534a8321 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 18:33:03 +1100 Subject: [PATCH 19/68] Enhance test coverage for plotting functions by updating significance checks in `test-plot.R`. Introduce a new helper function to correctly extract captions from patchwork plots, ensuring accurate validation of Bayesian FDR labels in plot outputs. --- tests/testthat/test-plot.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 17a06b12..8092a9f7 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -300,9 +300,16 @@ test_that("significance_statistic and show_fdr_message work via plot() S3 method significance_statistic = "pH0", show_fdr_message = TRUE ) - - expect_true(grepl("Bayesian FDR", fdr_plot$labels$caption)) - expect_true(is.null(ph0_plot$labels$caption) || !grepl("Bayesian FDR", ph0_plot$labels$caption)) + + # patchwork::plot_annotation caption is not in ggplot $labels + patchwork_caption <- function(p) { + ann <- p$patches$annotation$caption + if (!is.null(ann) && length(ann) && nzchar(ann)) return(ann) + lab <- p$labels$caption + if (is.null(lab)) "" else lab + } + expect_true(grepl("Bayesian FDR", patchwork_caption(fdr_plot))) + expect_true(!grepl("Bayesian FDR", patchwork_caption(ph0_plot))) }) test_that("plot_2D_intervals includes regression line from prec parameters", { skip_cmdstan() From 1240b63281a59e74c75ad34b2ddba43b76617513 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 18:42:04 +1100 Subject: [PATCH 20/68] Refactor plot_2D_intervals function to replace "unadjusted" terminology with "raw" for clarity. Update data handling and parameter filtering to reflect this change, ensuring consistency across plotting outputs and significance checks. --- R/plot.R | 53 ++++++++++++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/R/plot.R b/R/plot.R index 36a358d9..f2d9a3b3 100644 --- a/R/plot.R +++ b/R/plot.R @@ -483,22 +483,22 @@ plot_2D_intervals <- function( } # v_effect already comes from alpha_normalised (adjusted in Stan) - # "unadjusted" panel: ADD BACK entanglement to show raw alpha + # "raw" panel: ADD BACK entanglement to show raw alpha # "adjusted" panel: USE v_effect AS-IS if (!bimodal_flag) { - .data_unadjusted_list <- lapply(params_list, function(params) { + .data_raw_list <- lapply(params_list, function(params) { .data %>% filter(parameter == params$parameter) %>% mutate( v_effect = v_effect - params$slope * c_effect, v_lower = v_lower - params$slope * c_effect, v_upper = v_upper - params$slope * c_effect, - parameter = paste0(params$parameter, ", unadjusted") + parameter = paste0(params$parameter, ", raw") ) }) } else { - .data_unadjusted_list <- lapply(params_list, function(params) { + .data_raw_list <- lapply(params_list, function(params) { .data %>% filter(parameter == params$parameter) %>% rowwise() %>% @@ -514,14 +514,14 @@ plot_2D_intervals <- function( v_effect = v_effect - slope_to_use * c_effect, v_lower = v_lower - slope_to_use * c_effect, v_upper = v_upper - slope_to_use * c_effect, - parameter = paste0(params$parameter, ", unadjusted") + parameter = paste0(params$parameter, ", raw") ) %>% ungroup() %>% select(-raw_v_comp1, -raw_v_comp2, -pred_comp1, -pred_comp2, -slope_to_use) }) } - .data_unadjusted <- bind_rows(.data_unadjusted_list) + .data_raw <- bind_rows(.data_raw_list) # Adjusted panel: v_effect as-is (already from alpha_normalised) .data_adjusted_list <- lapply(params_list, function(params) { @@ -531,12 +531,12 @@ plot_2D_intervals <- function( }) .data_adjusted <- bind_rows(.data_adjusted_list) - .data_plot <- bind_rows(.data_unadjusted, .data_adjusted) + .data_plot <- bind_rows(.data_raw, .data_adjusted) # Set parameter factor levels param_order <- c() for(p in params_list) { - param_order <- c(param_order, paste0(p$parameter, ", unadjusted"), paste0(p$parameter, ", adjusted")) + param_order <- c(param_order, paste0(p$parameter, ", raw"), paste0(p$parameter, ", adjusted")) } .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) @@ -552,7 +552,7 @@ plot_2D_intervals <- function( cell_type_label = if_else( row_number() <= 3 & c_FDR < significance_threshold & - str_detect(parameter, "unadjusted"), + str_detect(parameter, ", adjusted$"), !!sym(.cell_group), "" ) @@ -566,8 +566,7 @@ plot_2D_intervals <- function( cell_type_label = if_else( row_number() <= 3 & v_FDR < significance_threshold & - str_detect(parameter, "adjusted") & - !str_detect(parameter, "unadjusted") & + str_detect(parameter, ", adjusted$") & cell_type_label == "", !!sym(.cell_group), cell_type_label @@ -579,13 +578,13 @@ plot_2D_intervals <- function( if (significance_statistic == "FDR") { color_c_aes <- aes( xmin = c_lower, xmax = c_upper, - color = c_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted"), - alpha = c_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted") + color = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$") ) color_v_aes <- aes( ymin = v_lower, ymax = v_upper, - color = v_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted"), - alpha = v_FDR < significance_threshold & str_detect(parameter, "adjusted") & !str_detect(parameter, "unadjusted") + color = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$") ) color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) @@ -593,13 +592,13 @@ plot_2D_intervals <- function( } else { color_c_aes <- aes( xmin = c_lower, xmax = c_upper, - color = c_pH0 < significance_threshold & str_detect(parameter, "unadjusted"), - alpha = c_pH0 < significance_threshold & str_detect(parameter, "unadjusted") + color = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") ) color_v_aes <- aes( ymin = v_lower, ymax = v_upper, - color = v_pH0 < significance_threshold & str_detect(parameter, "unadjusted"), - alpha = v_pH0 < significance_threshold & str_detect(parameter, "unadjusted") + color = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") ) color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) @@ -609,8 +608,8 @@ plot_2D_intervals <- function( # Prepare regression line data based on model type if (!bimodal_flag) { regression_data_all <- lapply(params_list, function(params) { - unadj_param <- paste0(params$parameter, ", unadjusted") - param_data <- .data_plot %>% filter(parameter == unadj_param) + raw_param <- paste0(params$parameter, ", raw") + param_data <- .data_plot %>% filter(parameter == raw_param) if(nrow(param_data) == 0) return(NULL) c_range <- range(param_data$c_effect, na.rm = TRUE) @@ -620,7 +619,7 @@ plot_2D_intervals <- function( data.frame( c_effect = c_seq, v_effect = v_pred, - parameter = unadj_param, + parameter = raw_param, stringsAsFactors = FALSE ) }) %>% bind_rows() @@ -652,8 +651,8 @@ plot_2D_intervals <- function( } else { regression_data_all <- lapply(params_list, function(params) { - unadj_param <- paste0(params$parameter, ", unadjusted") - param_data <- .data_plot %>% filter(parameter == unadj_param) + raw_param <- paste0(params$parameter, ", raw") + param_data <- .data_plot %>% filter(parameter == raw_param) if(nrow(param_data) == 0) return(NULL) c_range <- range(param_data$c_effect, na.rm = TRUE) @@ -665,11 +664,11 @@ plot_2D_intervals <- function( bind_rows( data.frame( c_effect = c_seq, v_effect = v_pred_1, - parameter = unadj_param, component = "Component 1" + parameter = raw_param, component = "Component 1" ), data.frame( c_effect = c_seq, v_effect = v_pred_2, - parameter = unadj_param, component = "Component 2" + parameter = raw_param, component = "Component 2" ) ) }) %>% bind_rows() @@ -944,7 +943,7 @@ plot_scatterplot = function( guides(color = guide_legend(title = legend_title), alpha = "none") # Add marginal density for adjusted panels (not Intercept) - if (str_detect(param, "adjusted") && !str_detect(param, "unadjusted") && !str_detect(param, "Intercept")) { + if (str_detect(param, ", adjusted$") && !str_detect(param, "Intercept")) { if (!bimodal_flag) { param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) From 80c69e04857d3604c15e80419f1114bd57a44fbe Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 31 Mar 2026 23:21:45 +1030 Subject: [PATCH 21/68] Add variability to composition mapping functionality Introduce a new internal function `get_variability_to_composition_map` to match variability design columns to composition design columns based on their names. Implement error handling for missing terms in the mapping. Update the Stan model to incorporate the new mapping and adjust the model calculations accordingly. Add comprehensive tests to validate the mapping functionality and ensure robustness against missing terms. --- R/utilities.R | 31 +++++ inst/stan/glm_multi_beta_binomial.stan | 5 +- .../test-variability-design-mapping.R | 113 ++++++++++++++++++ 3 files changed, 147 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-variability-design-mapping.R diff --git a/R/utilities.R b/R/utilities.R index 4d6b6dc0..d50ada4d 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -706,6 +706,34 @@ calculate_na_fraction_contribution = function(my_design_matrix, na_cols, design_ #' @importFrom purrr reduce #' @importFrom purrr map_int #' @importFrom stats as.formula +#' +#' Match variability to composition design columns +#' +#' @param X Composition design matrix +#' @param Xa Variability design matrix +#' +#' @return Integer vector indexing composition columns for each variability column +#' @keywords internal +#' @noRd +get_variability_to_composition_map = function(X, Xa) { + variability_to_composition_map = match(colnames(Xa), colnames(X)) + + if (any(is.na(variability_to_composition_map))) { + missing_terms = colnames(Xa)[is.na(variability_to_composition_map)] + stop( + sprintf( + paste0( + "sccomp says: every variability design term must also be present ", + "in the composition design matrix. Missing terms: %s" + ), + paste(missing_terms, collapse = ", ") + ) + ) + } + + as.integer(variability_to_composition_map) +} + #' #' @keywords internal #' @noRd @@ -774,6 +802,8 @@ data_spread_to_model_input = !!.sample, accept_NA_as_average_effect = accept_NA_as_average_effect ) + + variability_to_composition_map = get_variability_to_composition_map(X, Xa) XA = Xa %>% as_tibble() %>% @@ -914,6 +944,7 @@ data_spread_to_model_input = X = X, XA = XA, Xa = Xa, + variability_to_composition_map = variability_to_composition_map, C = ncol(X), A = A, Ar = Ar, diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 1aaace7c..a54bf160 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -285,6 +285,7 @@ data{ matrix[N, C] X; matrix[Ar, A] XA; // The unique variability design matrix[N, A] Xa; // The variability design + array[A] int variability_to_composition_map; // Truncation int is_truncated; @@ -523,7 +524,7 @@ model{ for(a in 1:A){ target += abundance_variability_regression( alpha[a], - beta[a], + beta[variability_to_composition_map[a]], prec_intercept_1[a], prec_slope_1[a], bimodal_mean_variability_association == 1 ? prec_slope_2[a] : 0, @@ -596,7 +597,7 @@ generated quantities { // Entanglement adjustment for(a in 1:A) - alpha_normalised[a] = alpha[a] - (beta[a] * prec_slope_1[a]); + alpha_normalised[a] = alpha[a] - (beta[variability_to_composition_map[a]] * prec_slope_1[a]); // LOO diff --git a/tests/testthat/test-variability-design-mapping.R b/tests/testthat/test-variability-design-mapping.R new file mode 100644 index 00000000..37da0ef4 --- /dev/null +++ b/tests/testthat/test-variability-design-mapping.R @@ -0,0 +1,113 @@ +library(testthat) +library(dplyr) +library(sccomp) + +test_that("get_variability_to_composition_map matches by column name", { + X <- matrix(0, nrow = 2, ncol = 4) + colnames(X) <- c("(Intercept)", "typehealthy", "phenotypep2", "phenotypep3") + + Xa <- matrix(0, nrow = 2, ncol = 4) + colnames(Xa) <- c("(Intercept)", "phenotypep2", "phenotypep3", "typehealthy") + + expect_equal( + sccomp:::get_variability_to_composition_map(X, Xa), + c(1L, 3L, 4L, 2L) + ) +}) + +test_that("get_variability_to_composition_map errors on missing terms", { + X <- matrix(0, nrow = 2, ncol = 2) + colnames(X) <- c("(Intercept)", "typehealthy") + + Xa <- matrix(0, nrow = 2, ncol = 3) + colnames(Xa) <- c("(Intercept)", "typehealthy", "phenotypep2") + + expect_error( + sccomp:::get_variability_to_composition_map(X, Xa), + "every variability design term must also be present in the composition design matrix" + ) + + expect_error( + sccomp:::get_variability_to_composition_map(X, Xa), + "Missing terms: phenotypep2" + ) +}) + +test_that("variability design maps to composition design by name", { + test_counts <- tibble::tibble( + sample = rep(c("s1", "s2", "s3", "s4"), each = 2), + type = rep(c("healthy", "healthy", "cancer", "cancer"), each = 2), + phenotype = rep(c("p1", "p2", "p1", "p2"), each = 2), + cell_group = rep(c("cg1", "cg2"), times = 4), + count = c(10L, 20L, 12L, 18L, 22L, 9L, 19L, 13L) + ) + + formula_composition <- ~ type + phenotype + formula_variability <- ~ phenotype + type + + model_input <- + test_counts |> + mutate(random_effect = "1") |> + sccomp:::data_to_spread( + formula = formula_composition, + .sample = !!quo(sample), + .cell_group = !!quo(cell_group), + .count = !!quo(count), + .grouping_for_random_effect = "random_effect" + ) |> + sccomp:::data_spread_to_model_input( + formula = formula_composition, + .sample = !!quo(sample), + .cell_group = !!quo(cell_group), + .count = !!quo(count), + truncation_ajustment = 1.1, + approximate_posterior_inference = FALSE, + formula_variability = formula_variability, + contrasts = NULL, + bimodal_mean_variability_association = FALSE, + use_data = TRUE, + random_effect_elements = tibble(factor = character(), grouping = character()) + ) + + expected_map <- match(colnames(model_input$Xa), colnames(model_input$X)) + expect_equal(model_input$variability_to_composition_map, expected_map) +}) + +test_that("variability design terms must exist in composition design", { + test_counts <- tibble::tibble( + sample = rep(c("s1", "s2", "s3", "s4"), each = 2), + type = rep(c("healthy", "healthy", "cancer", "cancer"), each = 2), + phenotype = rep(c("p1", "p2", "p1", "p2"), each = 2), + cell_group = rep(c("cg1", "cg2"), times = 4), + count = c(10L, 20L, 12L, 18L, 22L, 9L, 19L, 13L) + ) + + formula_composition <- ~ type + phenotype + formula_variability <- ~ type * phenotype + + expect_error( + test_counts |> + mutate(random_effect = "1") |> + sccomp:::data_to_spread( + formula = formula_composition, + .sample = !!quo(sample), + .cell_group = !!quo(cell_group), + .count = !!quo(count), + .grouping_for_random_effect = "random_effect" + ) |> + sccomp:::data_spread_to_model_input( + formula = formula_composition, + .sample = !!quo(sample), + .cell_group = !!quo(cell_group), + .count = !!quo(count), + truncation_ajustment = 1.1, + approximate_posterior_inference = FALSE, + formula_variability = formula_variability, + contrasts = NULL, + bimodal_mean_variability_association = FALSE, + use_data = TRUE, + random_effect_elements = tibble(factor = character(), grouping = character()) + ), + "every variability design term must also be present in the composition design matrix" + ) +}) From 53d543d3bb04387ed09fe1bdbf7f76f89e158350 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Fri, 3 Apr 2026 13:18:20 +1030 Subject: [PATCH 22/68] Add factor argument to plotting functions and implement subsetting by factor Enhance `plot_1D_intervals` and `plot_2D_intervals` functions to accept an optional `factor` argument, allowing users to restrict plots to specific model factors. Introduce a new internal function `subset_results_by_factor` to filter results based on the selected factor, improving data handling in plotting. Update documentation and tests to reflect these changes, ensuring robust functionality and error handling for invalid factors. --- R/plot.R | 48 +++++++++++++++----------- R/sccomp_boxplot.R | 6 ++-- R/utilities.R | 42 ++++++++++++++++++++++ inst/stan/glm_multi_beta_binomial.stan | 6 ++-- man/plot_1D_intervals.Rd | 3 ++ man/plot_2D_intervals.Rd | 3 ++ tests/testthat/test-plot.R | 34 ++++++++++++++++++ 7 files changed, 116 insertions(+), 26 deletions(-) diff --git a/R/plot.R b/R/plot.R index f2d9a3b3..b319dcf4 100644 --- a/R/plot.R +++ b/R/plot.R @@ -174,6 +174,7 @@ plot.sccomp_tbl <- function( #' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". +#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. #' @param sort_by Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical". #' @importFrom patchwork wrap_plots #' @importFrom forcats fct_reorder @@ -210,6 +211,7 @@ plot.sccomp_tbl <- function( #' plot_1D_intervals = function( .data, + factor = NULL, significance_threshold = 0.05, test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), show_fdr_message = TRUE, @@ -233,6 +235,8 @@ plot_1D_intervals = function( if(.data |> select(ends_with("FDR")) |> ncol() |> equals(0)) stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") + .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) + plot_list = .data |> @@ -330,6 +334,7 @@ plot_1D_intervals = function( #' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". +#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. #' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. #' #' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups @@ -370,6 +375,7 @@ plot_1D_intervals = function( #' plot_2D_intervals <- function( .data, + factor = NULL, significance_threshold = 0.05, test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), @@ -404,6 +410,8 @@ plot_2D_intervals <- function( if(.data |> select(ends_with("FDR")) |> ncol() == 0) stop("sccomp says: you need to run sccomp_test() first.") + .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) + # Extract fitted model and mean-variability regression coefficients fit <- attr(.data, "fit") prec_intercept_1_summary <- fit$summary("prec_intercept_1") @@ -417,11 +425,15 @@ plot_2D_intervals <- function( error = function(e) tibble() ) - # Get number of parameters (effects) - n_params <- .data |> + param_names <- .data |> filter(!is.na(v_effect)) |> distinct(parameter) |> - nrow() + pull(parameter) + + param_idx <- match(param_names, colnames(attr(.data, "model_input")$Xa)) + if (any(is.na(param_idx))) { + stop("sccomp says: could not map selected parameters to model coefficients.") + } # Derive model type from stored model metadata bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association @@ -432,16 +444,13 @@ plot_2D_intervals <- function( # Extract parameters based on model type if (!bimodal_flag) { - params_list <- lapply(1:n_params, function(a) { - param_name <- .data |> - filter(!is.na(v_effect)) |> - distinct(parameter) |> - slice(a) |> - pull(parameter) + params_list <- lapply(seq_along(param_names), function(a) { + param_name <- param_names[a] + idx <- param_idx[a] list( parameter = param_name, - intercept = prec_intercept_1_summary$mean[a], - slope = prec_slope_1_summary$mean[a] + intercept = prec_intercept_1_summary$mean[idx], + slope = prec_slope_1_summary$mean[idx] ) }) @@ -456,19 +465,16 @@ plot_2D_intervals <- function( } else { mix_p <- fit$summary("mix_p") |> pull(mean) - params_list <- lapply(1:n_params, function(a) { - param_name <- .data |> - filter(!is.na(v_effect)) |> - distinct(parameter) |> - slice(a) |> - pull(parameter) + params_list <- lapply(seq_along(param_names), function(a) { + param_name <- param_names[a] + idx <- param_idx[a] list( parameter = param_name, - intercept_1 = prec_intercept_1_summary$mean[a], - slope_1 = prec_slope_1_summary$mean[a], - slope_2 = prec_slope_2_summary$mean[a], - intercept_2 = prec_intercept_2_summary$mean[a] + intercept_1 = prec_intercept_1_summary$mean[idx], + slope_1 = prec_slope_1_summary$mean[idx], + slope_2 = prec_slope_2_summary$mean[idx], + intercept_2 = prec_intercept_2_summary$mean[idx] ) }) diff --git a/R/sccomp_boxplot.R b/R/sccomp_boxplot.R index df1b645b..bf9d0a24 100644 --- a/R/sccomp_boxplot.R +++ b/R/sccomp_boxplot.R @@ -71,11 +71,13 @@ sccomp_boxplot = function( if(.data |> select(any_of(c(paste0("c_", selected_statistic), paste0("v_", selected_statistic)))) |> ncol() |> equals(0)) stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") + .data_filtered = + subset_results_by_factor(.data, factor, keep_intercept = FALSE) + data_proportion = - .data |> + .data_filtered |> # Otherwise does not work - filter(factor == !!factor) |> select(-`factor`) data_proportion = diff --git a/R/utilities.R b/R/utilities.R index d50ada4d..724ff581 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -48,6 +48,48 @@ add_attr = function(var, attribute, name) { var } +#' Subset results by model factor +#' +#' @param .data A sccomp results tibble +#' @param factor Optional character scalar factor name +#' @param keep_intercept Logical; keep `(Intercept)` rows when subsetting +#' +#' @return Filtered results tibble +#' @keywords internal +#' @noRd +subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE) { + # Define variables to avoid CRAN NOTES + parameter <- NULL + + if (is.null(factor)) return(.data) + + if (!is.character(factor) || length(factor) != 1 || is.na(factor)) { + stop("sccomp says: `factor` must be a single character string.") + } + + available_factors = .data |> + filter(!is.na(`factor`)) |> + distinct(`factor`) |> + pull(`factor`) + + if (!(factor %in% available_factors)) { + stop( + sprintf( + "sccomp says: factor `%s` is not among model factors: %s", + factor, + paste(available_factors, collapse = ", ") + ) + ) + } + + if (keep_intercept) + .data |> + filter(`factor` == factor | parameter == "(Intercept)") + else + .data |> + filter(`factor` == factor) +} + #' Incorporate all Stan model parameters into fit object #' #' @description diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index a54bf160..9b150403 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -536,11 +536,11 @@ model{ } } else { if(intercept_in_design || A > 1){ - for(a in 1:A_intercept_columns) alpha[a] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); + for(a in 1:A_intercept_columns) alpha[a] ~ student_t( 3, prior_prec_intercept[1], prec_sd[a] ); if(A > A_intercept_columns) - for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ normal(0, 2); + for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ student_t(3, 0, prec_sd[a]); } else { - alpha[1] ~ normal( prior_prec_intercept[1], prior_prec_intercept[2] ); + alpha[1] ~ student_t( 3, prior_prec_intercept[1], prec_sd[a] ); } } diff --git a/man/plot_1D_intervals.Rd b/man/plot_1D_intervals.Rd index e92135a2..fe466ec0 100644 --- a/man/plot_1D_intervals.Rd +++ b/man/plot_1D_intervals.Rd @@ -6,6 +6,7 @@ \usage{ plot_1D_intervals( .data, + factor = NULL, significance_threshold = 0.05, test_composition_above_logit_fold_change = attr(.data, "test_composition_above_logit_fold_change"), @@ -17,6 +18,8 @@ plot_1D_intervals( \arguments{ \item{.data}{Data frame containing the main data.} +\item{factor}{Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus \code{(Intercept)}.} + \item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences.} \item{test_composition_above_logit_fold_change}{A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10\% for a cell type with baseline proportion of 50\%. That is, a cell type goes from 45\% to 50\%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale.} diff --git a/man/plot_2D_intervals.Rd b/man/plot_2D_intervals.Rd index f745b6b2..13b68270 100644 --- a/man/plot_2D_intervals.Rd +++ b/man/plot_2D_intervals.Rd @@ -6,6 +6,7 @@ \usage{ plot_2D_intervals( .data, + factor = NULL, significance_threshold = 0.05, test_composition_above_logit_fold_change = attr(.data, "test_composition_above_logit_fold_change"), @@ -17,6 +18,8 @@ plot_2D_intervals( \arguments{ \item{.data}{Data frame containing the main data.} +\item{factor}{Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus \code{(Intercept)}.} + \item{significance_threshold}{Numeric value specifying the significance threshold for highlighting differences. Default is 0.05.} \item{test_composition_above_logit_fold_change}{A positive integer. It is the effect threshold used for the hypothesis test.} diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 8092a9f7..e0823fb7 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -87,6 +87,40 @@ test_that("plot_2d_intervals function works correctly", { expect_s3_class("patchwork") }) +test_that("plot_1D_intervals accepts factor argument", { + skip_cmdstan() + + expect_no_error( + my_estimate |> + sccomp_test() |> + plot_1D_intervals(factor = "type") + ) + + expect_error( + my_estimate |> + sccomp_test() |> + plot_1D_intervals(factor = "not_a_factor"), + "is not among model factors" + ) +}) + +test_that("plot_2D_intervals accepts factor argument", { + skip_cmdstan() + + expect_no_error( + my_estimate_with_variance |> + sccomp_test() |> + plot_2D_intervals(factor = "type") + ) + + expect_error( + my_estimate_with_variance |> + sccomp_test() |> + plot_2D_intervals(factor = "not_a_factor"), + "is not among model factors" + ) +}) + # Test for show_fdr_message parameter in plot functions test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { skip_cmdstan() From 2c83149f36c0824fb707a53ad7d657750b832e50 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Fri, 3 Apr 2026 16:42:49 +1030 Subject: [PATCH 23/68] Refactor plotting functions to use new naming conventions and enhance functionality Update `plot_1D_intervals` and `plot_2D_intervals` to `sccomp_plot_intervals_1D` and `sccomp_plot_intervals_2D`, respectively, for consistency with new naming standards. Introduce new plotting functions that improve data handling and visualization of cell-group effects. Update documentation and tests to reflect these changes, ensuring robust functionality and adherence to the new naming conventions. --- NAMESPACE | 5 +- R/model_fitting.R | 2 +- R/plot.R | 5 +- R/plot_scatterplot.R | 183 ++++ R/sccomp-package.R | 2 +- R/sccomp_estimate.R | 8 +- R/sccomp_plot_intervals.R | 834 ++++++++++++++++++ R/sccomp_remove_outliers.R | 10 +- README.md | 4 +- inst/stan/glm_multi_beta_binomial.stan | 10 +- ...glm_multi_beta_binomial_generate_data.stan | 2 +- man/sccomp-package.Rd | 2 +- ...tervals.Rd => sccomp_plot_intervals_1D.Rd} | 10 +- ...tervals.Rd => sccomp_plot_intervals_2D.Rd} | 10 +- tests/testthat/test-plot.R | 86 +- vignettes/introduction.Rmd | 4 +- 16 files changed, 1095 insertions(+), 82 deletions(-) create mode 100644 R/plot_scatterplot.R create mode 100644 R/sccomp_plot_intervals.R rename man/{plot_1D_intervals.Rd => sccomp_plot_intervals_1D.Rd} (90%) rename man/{plot_2D_intervals.Rd => sccomp_plot_intervals_2D.Rd} (90%) diff --git a/NAMESPACE b/NAMESPACE index 43392df1..1167d30b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,8 @@ export(plot_2D_intervals) export(sccomp_boxplot) export(sccomp_calculate_residuals) export(sccomp_estimate) +export(sccomp_plot_intervals_1D) +export(sccomp_plot_intervals_2D) export(sccomp_predict) export(sccomp_proportional_fold_change) export(sccomp_remove_outliers) @@ -95,8 +97,7 @@ importFrom(ggplot2,theme_void) importFrom(ggrepel,geom_text_repel) importFrom(glue,glue) importFrom(instantiate,stan_cmdstan_exists) -importFrom(instantiate,stan_package_compile) -importFrom(instantiate,stan_package_model) +importFrom(lifecycle,deprecate_soft) importFrom(lifecycle,deprecate_warn) importFrom(lifecycle,is_present) importFrom(magrittr,"%$%") diff --git a/R/model_fitting.R b/R/model_fitting.R index 21b2f513..5c850c78 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -48,7 +48,7 @@ fit_model = function( rep(0, (data_for_model$A - 1) * data_for_model$M)), nrow = data_for_model$A, byrow = TRUE), beta_raw = matrix(0, data_for_model$C, data_for_model$M), - prec_sd = 1, + prec_sd = rep(1, data_for_model$A), mix_p = 0.1 ) diff --git a/R/plot.R b/R/plot.R index b319dcf4..80cccc4e 100644 --- a/R/plot.R +++ b/R/plot.R @@ -140,7 +140,7 @@ plot.sccomp_tbl <- function( # 1D intervals - plots$credible_intervals_1D = plot_1D_intervals( + plots$credible_intervals_1D = sccomp_plot_intervals_1D( .data = x, significance_threshold = significance_threshold, test_composition_above_logit_fold_change = test_composition_above_logit_fold_change, @@ -151,7 +151,7 @@ plot.sccomp_tbl <- function( # 2D intervals (only if variance effects exist) if("v_effect" %in% colnames(x) && (x |> filter(!is.na(v_effect)) |> nrow()) > 0) { - plots$credible_intervals_2D = plot_2D_intervals( + plots$credible_intervals_2D = sccomp_plot_intervals_2D( .data = x, significance_threshold = significance_threshold, test_composition_above_logit_fold_change = test_composition_above_logit_fold_change, @@ -1317,3 +1317,4 @@ plot_scatterplot = function( my_theme + theme(axis.text.x = element_text(angle=20, hjust = 1), title = element_text(size = 3)) } + diff --git a/R/plot_scatterplot.R b/R/plot_scatterplot.R new file mode 100644 index 00000000..32e24502 --- /dev/null +++ b/R/plot_scatterplot.R @@ -0,0 +1,183 @@ + +#' Plot Scatterplot of Cell-group Proportion +#' +#' This function creates a scatterplot of cell-group proportions, optionally +#' highlighting significant differences based on a given significance threshold. +#' +#' @param .data Data frame containing the main data. +#' @param data_proportion Data frame containing proportions of cell groups. +#' @param factor_of_interest A factor indicating the biological condition of interest. +#' @param significance_threshold Numeric value specifying the significance threshold +#' for highlighting differences. Default is 0.05. +#' @param my_theme A ggplot2 theme object to be applied to the plot. +#' @importFrom scales trans_new +#' @importFrom stringr str_replace str_detect +#' +#' @return A ggplot object representing the scatterplot. +#' +#' @noRd +plot_scatterplot = function( + .data, data_proportion, factor_of_interest, + significance_threshold = 0.05, my_theme +){ + + # Define the variables as NULL to avoid CRAN NOTES + stats_name <- NULL + parameter <- NULL + stats_value <- NULL + count_data <- NULL + generated_proportions <- NULL + proportion <- NULL + name <- NULL + outlier <- NULL + + # Function to remove leading zero from labels + dropLeadingZero <- function(l){ stringr::str_replace(l, '0(?=.)', '') } + + # Define square root transformation and its inverse + S_sqrt <- function(x){sign(x)*sqrt(abs(x))} + IS_sqrt <- function(x){x^2*sign(x)} + S_sqrt_trans <- function() scales::trans_new("S_sqrt",S_sqrt,IS_sqrt) + + .cell_group = attr(.data, ".cell_group") + .count = attr(.data, ".count") + .sample = attr(.data, ".sample") + + # Prepare significance colors + significance_colors = + .data %>% + pivot_longer( + c(contains("c_"), contains("v_")), + names_pattern = "([cv])_([a-zA-Z0-9]+)", + names_to = c("which", "stats_name"), + values_to = "stats_value" + ) %>% + filter(stats_name == "FDR") %>% + filter(parameter != "(Intercept)") %>% + filter(stats_value < significance_threshold) %>% + filter(`factor` == factor_of_interest) + + if(nrow(significance_colors) > 0){ + + if(.data |> attr("contrasts") |> is.null()) + significance_colors = + significance_colors %>% + unite("name", c(which, parameter), remove = FALSE) %>% + distinct() %>% + + # Get clean parameter + mutate(!!as.symbol(factor_of_interest) := str_replace(parameter, sprintf("^%s", `factor`), "")) %>% + with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) + else + significance_colors = + significance_colors |> + mutate( + factor_values = attr(.data, "count_data") |> + select(all_of(factor_of_interest)) |> + distinct() |> + pull(all_of(factor_of_interest)) + ) |> + unnest(factor_values) |> + + # Filter relevant parameters + mutate( !!as.symbol(factor_of_interest) := as.character(factor_values) ) |> + filter(str_detect(parameter, !!as.symbol(factor_of_interest) )) |> + + # Rename + select(!!.cell_group, !!as.symbol(factor_of_interest), name = parameter) |> + + # Merge contrasts + with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) + } + + my_scatterplot = ggplot() + + if("fit" %in% names(attributes(.data))){ + + simulated_proportion = + .data |> + sccomp_replicate(number_of_draws = 1000) |> + left_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.sample, !!.cell_group)) + + my_scatterplot = + my_scatterplot + + + # Add smoothed line for simulated proportions + geom_smooth( + aes(!!as.symbol(factor_of_interest), (generated_proportions)), + lwd=0.2, + data = + simulated_proportion %>% + inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group, !!.sample)) , + color="blue", fill="blue", + span = 1 + ) + } + + if( + nrow(significance_colors)==0 || + + significance_colors |> + pull(!!as.symbol(factor_of_interest)) |> + intersect( + data_proportion |> + pull(!!as.symbol(factor_of_interest)) + ) |> + length() |> + equals(0) + ) { + + my_scatterplot= + my_scatterplot + + + # Add smoothed line without significance colors + geom_smooth( + aes(!!as.symbol(factor_of_interest), proportion, fill = NULL), + data = + data_proportion , + lwd=0.5, + color = "black", + span = 1 + ) + } else { + my_scatterplot= + my_scatterplot + + + # Add smoothed line with significance colors + geom_smooth( + aes(!!as.symbol(factor_of_interest), proportion, fill = name), + data = data_proportion , + fatten = 0.5, + lwd=0.5, + color = "black", + span = 1 + ) + } + + my_scatterplot + + + # Add jittered points for individual data + geom_point( + aes(!!as.symbol(factor_of_interest), proportion, shape=outlier, color=outlier), + data = data_proportion, + position=position_jitterdodge(jitter.height = 0, jitter.width = 0.2), + size = 0.5 + ) + + + # Facet wrap by cell group + facet_wrap( + vars(!!.cell_group), + scales = "free_y", + nrow = 4 + ) + + scale_color_manual(values = c("black", "#e11f28")) + + scale_y_continuous(trans=S_sqrt_trans(), labels = dropLeadingZero) + + scale_fill_discrete(na.value = "white") + + xlab("Biological condition") + + ylab("Cell-group proportion") + + guides(color="none", alpha="none", size="none") + + labs(fill="Significant difference") + + ggtitle("Note: Be careful judging significance (or outliers) visually for lowly abundant cell groups. \nVisualising proportion hides the uncertainty characteristic of count data, that a count-based statistical model can estimate.") + + my_theme + + theme(axis.text.x = element_text(angle=20, hjust = 1), title = element_text(size = 3)) +} diff --git a/R/sccomp-package.R b/R/sccomp-package.R index 31493fbb..ab6af3fd 100644 --- a/R/sccomp-package.R +++ b/R/sccomp-package.R @@ -19,7 +19,7 @@ #' \item \code{\link{sccomp_predict}} - Predict cell type proportions for new samples #' \item \code{\link{sccomp_remove_unwanted_effects}} - Remove unwanted variation from data #' \item \code{\link{sccomp_proportional_fold_change}} - Calculate proportional fold changes -#' \item Plotting functions: \code{\link{plot.sccomp_tbl}}, \code{\link{sccomp_boxplot}}, \code{\link{plot_1D_intervals}}, \code{\link{plot_2D_intervals}} +#' \item Plotting functions: \code{\link{plot.sccomp_tbl}}, \code{\link{sccomp_boxplot}}, \code{\link{sccomp_plot_intervals_1D}}, \code{\link{sccomp_plot_intervals_2D}} #' } #' #' For detailed information on usage, see the package vignettes: diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index a4406dbd..ae96ad24 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -724,13 +724,9 @@ sccomp_estimate.data.frame <- function(.data, if (dir.exists(output_directory)) { files_deleted <- attr(res, "fit")$output_files(include_failed = TRUE) - files_deleted <- files_deleted[file.exists(files_deleted)] if (length(files_deleted) > 0) { - file.remove(files_deleted) - if (verbose) { - message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", - length(files_deleted), output_directory)) - } + suppressWarnings(unlink(files_deleted, force = TRUE)) + message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", length(files_deleted), output_directory)) } } } diff --git a/R/sccomp_plot_intervals.R b/R/sccomp_plot_intervals.R new file mode 100644 index 00000000..84ebc6b2 --- /dev/null +++ b/R/sccomp_plot_intervals.R @@ -0,0 +1,834 @@ + +#' Plot 1D Intervals for Cell-group Effects +#' +#' This function creates a series of 1D interval plots for cell-group effects, highlighting significant differences based on a given significance threshold. +#' +#' @param .data Data frame containing the main data. +#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. +#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. +#' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. +#' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". +#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. +#' @param sort_by Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical". +#' @importFrom patchwork wrap_plots +#' @importFrom forcats fct_reorder +#' @importFrom tidyr drop_na +#' +#' @export +#' +#' @return A combined plot of 1D interval plots. +#' @examples +#' +#' print("cmdstanr is needed to run this example.") +#' +#' \donttest{ +#' if (instantiate::stan_cmdstan_exists()) { +#' data("counts_obj") +#' +#' estimate <- sccomp_estimate( +#' counts_obj, +#' ~ type, +#' ~1, +#' "sample", +#' "cell_group", +#' "count", +#' cores = 1 +#' ) |> +#' sccomp_test() +#' +#' # Example usage: +#' my_plot = sccomp_plot_intervals_1D(estimate, sort_by = "effect") +#' +#' } +#' } +#' +#' +sccomp_plot_intervals_1D = function( + .data, + factor = NULL, + significance_threshold = 0.05, + test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), + show_fdr_message = TRUE, + significance_statistic = c("pH0", "FDR"), + sort_by = c("none", "effect", "significance", "alphabetical") +) { + significance_statistic <- match.arg(significance_statistic) + sort_by <- match.arg(sort_by) + + # Define the variables as NULL to avoid CRAN NOTES + parameter <- NULL + estimate <- NULL + value <- NULL + pH0 <- NULL + FDR <- NULL + effect <- NULL + + .cell_group = attr(.data, ".cell_group") + + # Check if test have been done + if(.data |> select(ends_with("FDR")) |> ncol() |> equals(0)) + stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") + + .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) + + plot_list = + .data |> + + # Reshape data + select(-contains("n_eff"), -contains("R_k_hat"), -contains("_ess"), -contains("_rhat")) |> + pivot_longer(c(contains("c_"), contains("v_")), names_sep = "_", names_to = c("which", "estimate")) |> + pivot_wider(names_from = estimate, values_from = value) |> + + # Nest data by parameter and which + nest(data = -c(parameter, which)) |> + mutate(plot = pmap( + list(data, which, parameter), + function(plot_data, plot_which, plot_param) { + # Check if there are any statistics to plot + if(plot_data |> filter(!is.na(effect)) |> nrow() |> equals(0)) + return(NA) + + # Choose color variable and legend + if (significance_statistic == "FDR") { + color_aes <- aes(xmin = lower, xmax = upper, color = FDR < significance_threshold) + color_scale <- scale_color_manual(values = c("grey40", "red")) + legend_title <- "FDR < significance_threshold" + } else { + color_aes <- aes(xmin = lower, xmax = upper, color = pH0 < significance_threshold) + color_scale <- scale_color_manual(values = c("grey40", "red")) + legend_title <- "pH0 < significance_threshold" + } + + # Determine y-axis variable based on sort_by + # Use string-based column selection instead of NSE + if (sort_by == "none") { + # No sorting + plot_data$y_var <- plot_data[[.cell_group]] + } else if (sort_by == "effect") { + # Sort by absolute effect size + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], abs(plot_data$effect)) + } else if (sort_by == "significance") { + # Sort by significance + if (significance_statistic == "FDR") { + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$FDR, .desc = TRUE) + } else { + plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$pH0, .desc = TRUE) + } + } else if (sort_by == "alphabetical") { + # Alphabetical sorting + plot_data <- plot_data %>% arrange(.data[[.cell_group]]) + plot_data$y_var <- fct_inorder(plot_data[[.cell_group]]) + } + + ggplot(plot_data, aes(x = effect, y = y_var)) + + geom_vline(xintercept = test_composition_above_logit_fold_change, colour = "grey") + + geom_vline(xintercept = -test_composition_above_logit_fold_change, colour = "grey") + + geom_errorbar(color_aes) + + geom_point() + + color_scale + + xlab("Credible interval of the effect") + + ylab("Cell group") + + ggtitle(sprintf("%s %s", plot_which, plot_param)) + + sccomp_theme() + + theme(legend.position = "bottom") + + guides(color = guide_legend(title = legend_title)) + } + )) %>% + + # Filter out NA plots + filter(!is.na(plot)) |> + pull(plot) + + # Combine all individual plots into one plot + combined_plot <- plot_list |> + wrap_plots(ncol = plot_list |> length() |> sqrt() |> ceiling()) + + # Only show the FDR message if significance_statistic == "FDR" and show_fdr_message is TRUE + if (significance_statistic == "FDR" && show_fdr_message) { + combined_plot <- combined_plot + theme(plot.caption = ggplot2::element_text(hjust = 0)) + combined_plot <- combined_plot + patchwork::plot_annotation( + caption = paste( + "Bayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", + "\nFDR-significant populations may cross fold change thresholds because Bayesian FDR considers posterior probabilities rather than p-values.", + "\nThe method sorts null hypothesis probabilities in ascending order and calculates cumulative averages for robust false discovery control.", + sep = "" + ) + ) + } + combined_plot +} + +#' Plot 2D Intervals for Mean-Variance Association +#' +#' This function creates a 2D interval plot for mean-variance association, handling both single and bimodal models. +#' It highlights significant differences based on a given significance threshold. +#' +#' @param .data Data frame containing the main data. +#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.05. +#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. +#' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. +#' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". +#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. +#' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. +#' +#' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups +#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point geom_line geom_area aes facet_wrap theme_bw theme labs guides guide_legend scale_color_manual scale_alpha_manual scale_fill_manual scale_y_continuous coord_flip theme_void element_rect element_text margin +#' @importFrom ggrepel geom_text_repel +#' @importFrom stringr str_detect +#' @importFrom patchwork plot_annotation wrap_plots plot_layout +#' +#' @export +#' +#' @return A ggplot object representing the 2D interval plot. +#' +#' @examples +#' +#' print("cmdstanr is needed to run this example.") +#' +#' \donttest{ +#' if (instantiate::stan_cmdstan_exists()) { +#' data("counts_obj") +#' +#' estimate <- sccomp_estimate( +#' counts_obj, +#' ~ type, +#' ~type, +#' "sample", +#' "cell_group", +#' "count", +#' cores = 1, +#' bimodal_mean_variability_association = TRUE +#' ) |> +#' sccomp_test() +#' +#' # Example usage: +#' my_plot = sccomp_plot_intervals_2D(estimate) +#' +#' } +#' } +#' +sccomp_plot_intervals_2D <- function( + .data, + factor = NULL, + significance_threshold = 0.05, + test_composition_above_logit_fold_change = + .data |> attr("test_composition_above_logit_fold_change"), + show_fdr_message = TRUE, + significance_statistic = c("pH0", "FDR"), + add_marginal_density = TRUE +) { + + significance_statistic <- match.arg(significance_statistic) + + # Define variables to avoid CRAN NOTES + v_effect <- NULL + parameter <- NULL + c_effect <- NULL + c_lower <- NULL + c_upper <- NULL + c_FDR <- NULL + v_lower <- NULL + v_upper <- NULL + v_FDR <- NULL + cell_type_label <- NULL + pH0 <- NULL + FDR <- NULL + c_pH0 <- NULL + v_pH0 <- NULL + component <- NULL + assigned_component <- NULL + + .cell_group <- attr(.data, ".cell_group") + + # Check if test has been done + if(.data |> select(ends_with("FDR")) |> ncol() == 0) + stop("sccomp says: you need to run sccomp_test() first.") + + .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) + + # Extract fitted model and mean-variability regression coefficients + fit <- attr(.data, "fit") + prec_intercept_1_summary <- fit$summary("prec_intercept_1") + prec_slope_1_summary <- fit$summary("prec_slope_1") + prec_intercept_2_summary <- tryCatch( + fit$summary("prec_intercept_2"), + error = function(e) tibble() + ) + prec_slope_2_summary <- tryCatch( + fit$summary("prec_slope_2"), + error = function(e) tibble() + ) + + param_names <- .data |> + filter(!is.na(v_effect)) |> + distinct(parameter) |> + pull(parameter) + + param_idx <- match(param_names, colnames(attr(.data, "model_input")$Xa)) + if (any(is.na(param_idx))) { + stop("sccomp says: could not map selected parameters to model coefficients.") + } + + # Derive model type from stored model metadata + bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association + if (is.null(bimodal_flag)) { + stop("sccomp says: cannot infer model type because `bimodal_mean_variability_association` is missing from model metadata.") + } + bimodal_flag <- isTRUE(as.logical(bimodal_flag)) + + # Extract parameters based on model type + if (!bimodal_flag) { + params_list <- lapply(seq_along(param_names), function(a) { + param_name <- param_names[a] + idx <- param_idx[a] + list( + parameter = param_name, + intercept = prec_intercept_1_summary$mean[idx], + slope = prec_slope_1_summary$mean[idx] + ) + }) + + cat("=== Single Model Parameters ===\n") + for(i in 1:length(params_list)) { + p <- params_list[[i]] + cat(sprintf("\n%s:\n", p$parameter)) + cat(sprintf(" v = -(%.3f + %.3f × c)\n", p$intercept, p$slope)) + } + cat("\n") + + } else { + mix_p <- fit$summary("mix_p") |> pull(mean) + + params_list <- lapply(seq_along(param_names), function(a) { + param_name <- param_names[a] + idx <- param_idx[a] + + list( + parameter = param_name, + intercept_1 = prec_intercept_1_summary$mean[idx], + slope_1 = prec_slope_1_summary$mean[idx], + slope_2 = prec_slope_2_summary$mean[idx], + intercept_2 = prec_intercept_2_summary$mean[idx] + ) + }) + + cat("=== Bimodal Model Parameters ===\n") + for(i in 1:length(params_list)) { + p <- params_list[[i]] + cat(sprintf("\n%s:\n", p$parameter)) + cat(sprintf(" Component 1: v = -(%.3f + %.3f × c)\n", p$intercept_1, p$slope_1)) + cat(sprintf(" Component 2: v = -(%.3f + %.3f × c)\n", p$intercept_2, p$slope_2)) + } + cat("\n") + } + + # v_effect already comes from alpha_normalised (adjusted in Stan) + # "raw" panel: ADD BACK entanglement to show raw alpha + # "adjusted" panel: USE v_effect AS-IS + + if (!bimodal_flag) { + .data_raw_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% + mutate( + v_effect = v_effect - params$slope * c_effect, + v_lower = v_lower - params$slope * c_effect, + v_upper = v_upper - params$slope * c_effect, + parameter = paste0(params$parameter, ", raw") + ) + }) + } else { + .data_raw_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% + rowwise() %>% + mutate( + raw_v_comp1 = v_effect - params$slope_1 * c_effect, + raw_v_comp2 = v_effect - params$slope_2 * c_effect, + pred_comp1 = -(params$intercept_1 + params$slope_1 * c_effect), + pred_comp2 = -(params$intercept_2 + params$slope_2 * c_effect), + assigned_component = if_else( + abs(raw_v_comp1 - pred_comp1) < abs(raw_v_comp2 - pred_comp2), 1, 2 + ), + slope_to_use = if_else(assigned_component == 1, params$slope_1, params$slope_2), + v_effect = v_effect - slope_to_use * c_effect, + v_lower = v_lower - slope_to_use * c_effect, + v_upper = v_upper - slope_to_use * c_effect, + parameter = paste0(params$parameter, ", raw") + ) %>% + ungroup() %>% + select(-raw_v_comp1, -raw_v_comp2, -pred_comp1, -pred_comp2, -slope_to_use) + }) + } + + .data_raw <- bind_rows(.data_raw_list) + + # Adjusted panel: v_effect as-is (already from alpha_normalised) + .data_adjusted_list <- lapply(params_list, function(params) { + .data %>% + filter(parameter == params$parameter) %>% + mutate(parameter = paste0(params$parameter, ", adjusted")) + }) + .data_adjusted <- bind_rows(.data_adjusted_list) + + .data_plot <- bind_rows(.data_raw, .data_adjusted) + + # Set parameter factor levels + param_order <- c() + for(p in params_list) { + param_order <- c(param_order, paste0(p$parameter, ", raw"), paste0(p$parameter, ", adjusted")) + } + + .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) + + # Add labels for significant cell groups + .data_plot <- .data_plot %>% + filter(!is.na(v_effect)) %>% + with_groups( + parameter, + ~ .x %>% + arrange(c_FDR) %>% + mutate( + cell_type_label = if_else( + row_number() <= 3 & + c_FDR < significance_threshold & + str_detect(parameter, ", adjusted$"), + !!sym(.cell_group), + "" + ) + ) + ) %>% + with_groups( + parameter, + ~ .x %>% + arrange(v_FDR) %>% + mutate( + cell_type_label = if_else( + row_number() <= 3 & + v_FDR < significance_threshold & + str_detect(parameter, ", adjusted$") & + cell_type_label == "", + !!sym(.cell_group), + cell_type_label + ) + ) + ) + + # Choose color aesthetics based on significance statistic + if (significance_statistic == "FDR") { + color_c_aes <- aes( + xmin = c_lower, xmax = c_upper, + color = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$") + ) + color_v_aes <- aes( + ymin = v_lower, ymax = v_upper, + color = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$") + ) + color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) + alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) + legend_title <- "FDR < significance_threshold" + } else { + color_c_aes <- aes( + xmin = c_lower, xmax = c_upper, + color = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") + ) + color_v_aes <- aes( + ymin = v_lower, ymax = v_upper, + color = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), + alpha = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") + ) + color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) + alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) + legend_title <- "pH0 < significance_threshold" + } + + # Prepare regression line data based on model type + if (!bimodal_flag) { + regression_data_all <- lapply(params_list, function(params) { + raw_param <- paste0(params$parameter, ", raw") + param_data <- .data_plot %>% filter(parameter == raw_param) + if(nrow(param_data) == 0) return(NULL) + + c_range <- range(param_data$c_effect, na.rm = TRUE) + c_seq <- seq(c_range[1], c_range[2], length.out = 100) + v_pred <- -(params$intercept + params$slope * c_seq) + + data.frame( + c_effect = c_seq, + v_effect = v_pred, + parameter = raw_param, + stringsAsFactors = FALSE + ) + }) %>% bind_rows() + + adjusted_lines_all <- lapply(params_list, function(params) { + adj_param <- paste0(params$parameter, ", adjusted") + adj_data <- .data_plot %>% filter(parameter == adj_param) + if(nrow(adj_data) == 0) return(NULL) + + c_range_adj <- range(adj_data$c_effect, na.rm = TRUE) + mean_adj <- mean(adj_data$v_effect, na.rm = TRUE) + + data.frame( + c_effect = c_range_adj, + v_effect = rep(mean_adj, 2), + parameter = adj_param, + stringsAsFactors = FALSE + ) + }) %>% bind_rows() + + } else { + regression_data_all <- lapply(params_list, function(params) { + raw_param <- paste0(params$parameter, ", raw") + param_data <- .data_plot %>% filter(parameter == raw_param) + if(nrow(param_data) == 0) return(NULL) + + c_range <- range(param_data$c_effect, na.rm = TRUE) + c_seq <- seq(c_range[1], c_range[2], length.out = 100) + + v_pred_1 <- -(params$intercept_1 + params$slope_1 * c_seq) + v_pred_2 <- -(params$intercept_2 + params$slope_2 * c_seq) + + bind_rows( + data.frame( + c_effect = c_seq, v_effect = v_pred_1, + parameter = raw_param, component = "Component 1" + ), + data.frame( + c_effect = c_seq, v_effect = v_pred_2, + parameter = raw_param, component = "Component 2" + ) + ) + }) %>% bind_rows() + + adjusted_lines_all <- lapply(params_list, function(params) { + adj_param <- paste0(params$parameter, ", adjusted") + c_range_adj <- range(.data_plot$c_effect[.data_plot$parameter == adj_param], na.rm = TRUE) + + bind_rows( + data.frame( + c_effect = c_range_adj, v_effect = rep(-params$intercept_1, 2), + parameter = adj_param, component = "Component 1" + ), + data.frame( + c_effect = c_range_adj, v_effect = rep(-params$intercept_2, 2), + parameter = adj_param, component = "Component 2" + ) + ) + }) %>% bind_rows() + } + + # Add caption based on model type + if (significance_statistic == "FDR" && show_fdr_message) { + if (!bimodal_flag) { + caption_text <- paste( + "Single model with parameter-specific slopes", + "\nBlue line shows mean-variability relationship for each parameter", + "\n'Adjusted' panels show variability after removing parameter-specific mean-variability association", + "\nMarginal density shows posterior distribution of variability intercept parameters", + "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", + sep = "" + ) + } else { + caption_text <- paste( + sprintf("Bimodal model: mix_p = %.3f (Component 1 weight)", mix_p), + "\nSolid blue line = Component 1 | Dashed orange line = Component 2", + "\n'Adjusted' panels show variability after removing mean-variability association", + "\nMarginal density shows posterior distribution of variability intercept parameters", + "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", + sep = "" + ) + } + } else { + caption_text <- NULL + } + + # Add marginal density plots if requested + if (add_marginal_density) { + + plot_list <- lapply(param_order, function(param) { + + param_data <- .data_plot %>% filter(parameter == param) + if(nrow(param_data) == 0) return(NULL) + + # Create main plot + p_param <- ggplot(param_data, aes(c_effect, v_effect)) + + geom_vline( + xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + geom_hline( + yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + # Add regression lines + if (!bimodal_flag) { + reg_data <- regression_data_all %>% filter(parameter == param) + if(!is.null(reg_data) && nrow(reg_data) > 0) { + p_param <- p_param + + geom_line(data = reg_data, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + + adj_line <- adjusted_lines_all %>% filter(parameter == param) + if(!is.null(adj_line) && nrow(adj_line) > 0) { + p_param <- p_param + + geom_line(data = adj_line, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + + } else { + reg_data <- regression_data_all %>% filter(parameter == param) + if(!is.null(reg_data) && nrow(reg_data) > 0) { + p_param <- p_param + + geom_line(data = reg_data %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = reg_data %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + + adj_line <- adjusted_lines_all %>% filter(parameter == param) + if(!is.null(adj_line) && nrow(adj_line) > 0) { + p_param <- p_param + + geom_line(data = adj_line %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = adj_line %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + } + + # Add error bars, points, and labels + p_param <- p_param + + geom_errorbar(color_c_aes, linewidth = 0.2) + + geom_errorbar(color_v_aes, linewidth = 0.2) + + geom_point(size = 0.2) + + geom_text_repel( + aes(c_effect, -v_effect, label = cell_type_label), + size = 2.5, + data = param_data %>% filter(cell_type_label != ""), + max.overlaps = 20 + ) + + color_scale + + alpha_scale + + xlab("c_effect (Abundance effect)") + + ylab("v_effect (Variability effect)") + + ggtitle(param) + + theme_bw() + + theme( + legend.position = "bottom", + strip.background = element_rect(fill = "white"), + panel.grid.minor = element_blank() + ) + + guides(color = guide_legend(title = legend_title), alpha = "none") + + # Add marginal density for adjusted panels (not Intercept) + if (str_detect(param, ", adjusted$") && !str_detect(param, "Intercept")) { + + if (!bimodal_flag) { + param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) + + if (length(param_idx) > 0) { + intercept_var_name <- paste0("prec_intercept_1[", param_idx, "]") + + tryCatch({ + intercept_draws <- fit$draws(variables = intercept_var_name, format = "draws_df") + intercept_values <- as.vector(intercept_draws[[intercept_var_name]]) + + dens <- density(-intercept_values, na.rm = TRUE) + dens_df <- data.frame(x = dens$x, y = dens$y) + + + y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range + + p_density <- ggplot(dens_df, aes(x = x, y = y)) + + geom_area(alpha = 0.5, position = "identity") + + geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + + coord_flip(xlim = y_range) + + scale_y_continuous(expand = c(0, 0)) + + xlab("Posterior Probability") + + theme_void() + + theme( + plot.margin = margin(t = 0, r = 0, b = 0, l = 6), + axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) + ) + + p_combined <- p_param + p_density + + plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & + theme(legend.position = "bottom") + + return(p_combined) + }, error = function(e) { + warning(sprintf("Could not extract intercept draws for %s: %s", intercept_var_name, e$message)) + return(p_param) + }) + } + + } else { + param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) + + if (length(param_idx) > 0) { + intercept1_var_name <- paste0("prec_intercept_1[", param_idx, "]") + intercept2_var_name <- paste0("prec_intercept_2[", param_idx, "]") + + tryCatch({ + intercept1_draws <- fit$draws(variables = intercept1_var_name, format = "draws_df") + intercept2_draws <- fit$draws(variables = intercept2_var_name, format = "draws_df") + + intercept1_values <- as.vector(intercept1_draws[[intercept1_var_name]]) + intercept2_values <- as.vector(intercept2_draws[[intercept2_var_name]]) + + dens1 <- density(-intercept1_values, na.rm = TRUE) + dens2 <- density(-intercept2_values, na.rm = TRUE) + + dens_df <- bind_rows( + data.frame(x = dens1$x, y = dens1$y, component = "Component 1"), + data.frame(x = dens2$x, y = dens2$y, component = "Component 2") + ) + + + y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range + + p_density <- ggplot(dens_df, aes(x = x, y = y, fill = component)) + + geom_area(alpha = 0.5, position = "identity") + + geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + + scale_fill_manual(values = c("Component 1" = "#0072B2", "Component 2" = "#D55E00")) + + coord_flip(xlim = y_range) + + scale_y_continuous(expand = c(0, 0)) + + xlab("Posterior Probability") + + theme_void() + + theme( + plot.margin = margin(t = 0, r = 0, b = 0, l = 5), + legend.position = "none", + axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) + ) + + p_combined <- p_param + p_density + + plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & + theme(legend.position = "bottom") + + return(p_combined) + }, error = function(e) { + warning(sprintf("Could not extract intercept draws: %s", e$message)) + return(p_param) + }) + } + } + } + + return(p_param) + }) + + + plot_list <- plot_list[!sapply(plot_list, is.null)] + combined_plot <- patchwork::wrap_plots(plot_list, ncol = 2) + + if (!is.null(caption_text)) { + combined_plot <- combined_plot + + plot_annotation( + caption = caption_text, + theme = theme(plot.caption = element_text(hjust = 0, size = 9)) + ) + } + + return(combined_plot) + + } else { + # Return faceted plot without marginal densities + p <- ggplot(.data_plot, aes(c_effect, v_effect)) + + geom_vline( + xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + geom_hline( + yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), + colour = "grey", linetype = "dashed", linewidth = 0.3 + ) + + # Add regression lines + if (!bimodal_flag) { + if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { + p <- p + geom_line(data = regression_data_all, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { + p <- p + geom_line(data = adjusted_lines_all, mapping = aes(c_effect, v_effect), + color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + } + } else { + if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { + p <- p + + geom_line(data = regression_data_all %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = regression_data_all %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { + p <- p + + geom_line(data = adjusted_lines_all %>% filter(component == "Component 1"), + mapping = aes(c_effect, v_effect), color = "#0072B2", + linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + + geom_line(data = adjusted_lines_all %>% filter(component == "Component 2"), + mapping = aes(c_effect, v_effect), color = "#D55E00", + linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) + } + } + + p <- p + + geom_errorbar(color_c_aes, linewidth = 0.2) + + geom_errorbar(color_v_aes, linewidth = 0.2) + + geom_point(size = 0.2) + + geom_text_repel( + aes(c_effect, -v_effect, label = cell_type_label), + size = 2.5, + data = .data_plot %>% filter(cell_type_label != ""), + max.overlaps = 20 + ) + + color_scale + + alpha_scale + + facet_wrap(~ parameter, scales = "free", ncol = 2) + + xlab("c_effect (Abundance effect)") + + ylab("v_effect (Variability effect)") + + theme_bw() + + theme( + legend.position = "bottom", + strip.background = element_rect(fill = "white"), + panel.grid.minor = element_blank() + ) + + guides(color = guide_legend(title = legend_title), alpha = "none") + + if (!is.null(caption_text)) { + p <- p + + theme(plot.caption = element_text(hjust = 0, size = 9)) + + labs(caption = caption_text) + } + + return(p) + } +} + +#' Soft-deprecated aliases (call [sccomp_plot_intervals_1D()] / [sccomp_plot_intervals_2D()] instead). +#' +#' @importFrom lifecycle deprecate_soft +#' @export +#' @noRd +plot_1D_intervals <- function(...) { + deprecate_soft("2.1.29", "plot_1D_intervals()", "sccomp_plot_intervals_1D()") + sccomp_plot_intervals_1D(...) +} + +#' @export +#' @noRd +plot_2D_intervals <- function(...) { + deprecate_soft("2.1.29", "plot_2D_intervals()", "sccomp_plot_intervals_2D()") + sccomp_plot_intervals_2D(...) +} \ No newline at end of file diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index afd19458..2b983c1f 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -504,17 +504,15 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, # Auto-cleanup draw files if requested if (portable) { + estimate_tibble <- incorporate_parameters_into_sccomp_object(estimate_tibble) if (dir.exists(output_directory)) { files_deleted <- attr(estimate_tibble, "fit")$output_files(include_failed = TRUE) - files_deleted <- files_deleted[file.exists(files_deleted)] + if (length(files_deleted) > 0) { - file.remove(files_deleted) - if (verbose) { - message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", - length(files_deleted), output_directory)) - } + suppressWarnings(unlink(files_deleted, force = TRUE)) + message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", length(files_deleted), output_directory)) } } } diff --git a/README.md b/README.md index e3b4d97f..fc47a193 100644 --- a/README.md +++ b/README.md @@ -369,7 +369,7 @@ credible interval. Facets represent the covariates in the model. ``` r sccomp_result |> - plot_1D_intervals() + sccomp_plot_intervals_1D() ``` ![](inst/figures/unnamed-chunk-10-1.png) @@ -382,7 +382,7 @@ modelled jointly, thanks to Bayesian inference. ``` r sccomp_result |> - plot_2D_intervals() + sccomp_plot_intervals_2D() ``` ![](inst/figures/unnamed-chunk-11-1.png) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 9b150403..e47d749e 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -360,7 +360,7 @@ parameters{ // Mean-variability slopes array[A] real prec_slope_1; // s1, always present array[A * bimodal_mean_variability_association] real prec_slope_2; // s2, only for bimodal - real prec_sd; // residual scale for mean–variability association (single or bimodal) + array[A] real prec_sd; // residual scale per effect for mean-variability association real mix_p; // Random intercept // array of sum_to_zero_vector for each random effect @@ -529,18 +529,18 @@ model{ prec_slope_1[a], bimodal_mean_variability_association == 1 ? prec_slope_2[a] : 0, bimodal_mean_variability_association == 1 ? prec_intercept_2[a] : 0, - prec_sd, + prec_sd[a], bimodal_mean_variability_association, mix_p_scalar ); } } else { if(intercept_in_design || A > 1){ - for(a in 1:A_intercept_columns) alpha[a] ~ student_t( 3, prior_prec_intercept[1], prec_sd[a] ); + for(a in 1:A_intercept_columns) alpha[a] ~ student_t(3, prior_prec_intercept[1], prec_sd[a]); if(A > A_intercept_columns) for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ student_t(3, 0, prec_sd[a]); } else { - alpha[1] ~ student_t( 3, prior_prec_intercept[1], prec_sd[a] ); + alpha[1] ~ student_t(3, prior_prec_intercept[1], prec_sd[1]); } } @@ -566,7 +566,7 @@ model{ prec_slope_2[a] ~ student_t(3, 0, 2); // s2 } } - prec_sd ~ normal(0, 1) T[0,]; + for(a in 1:A) prec_sd[a] ~ normal(0, 1) T[0,]; // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 2fb9d966..6a84b557 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -72,7 +72,7 @@ parameters { array[A] ordered[1 + bimodal_mean_variability_association] prec_intercept; array[A] real prec_slope_1; array[A * bimodal_mean_variability_association] real prec_slope_2; - real prec_sd; + array[A] real prec_sd; real mix_p; // Random intercept // Using regular vectors instead of sum_to_zero_vector to avoid floating-point precision issues diff --git a/man/sccomp-package.Rd b/man/sccomp-package.Rd index c61ce586..0d214a20 100644 --- a/man/sccomp-package.Rd +++ b/man/sccomp-package.Rd @@ -23,7 +23,7 @@ The main functions are: \item \code{\link{sccomp_predict}} - Predict cell type proportions for new samples \item \code{\link{sccomp_remove_unwanted_effects}} - Remove unwanted variation from data \item \code{\link{sccomp_proportional_fold_change}} - Calculate proportional fold changes -\item Plotting functions: \code{\link{plot.sccomp_tbl}}, \code{\link{sccomp_boxplot}}, \code{\link{plot_1D_intervals}}, \code{\link{plot_2D_intervals}} +\item Plotting functions: \code{\link{plot.sccomp_tbl}}, \code{\link{sccomp_boxplot}}, \code{\link{sccomp_plot_intervals_1D}}, \code{\link{sccomp_plot_intervals_2D}} } For detailed information on usage, see the package vignettes: diff --git a/man/plot_1D_intervals.Rd b/man/sccomp_plot_intervals_1D.Rd similarity index 90% rename from man/plot_1D_intervals.Rd rename to man/sccomp_plot_intervals_1D.Rd index fe466ec0..27444b4c 100644 --- a/man/plot_1D_intervals.Rd +++ b/man/sccomp_plot_intervals_1D.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{plot_1D_intervals} -\alias{plot_1D_intervals} +% Please edit documentation in R/sccomp_plot_intervals.R +\name{sccomp_plot_intervals_1D} +\alias{sccomp_plot_intervals_1D} \title{Plot 1D Intervals for Cell-group Effects} \usage{ -plot_1D_intervals( +sccomp_plot_intervals_1D( .data, factor = NULL, significance_threshold = 0.05, @@ -56,7 +56,7 @@ print("cmdstanr is needed to run this example.") sccomp_test() # Example usage: - my_plot = plot_1D_intervals(estimate, sort_by = "effect") + my_plot = sccomp_plot_intervals_1D(estimate, sort_by = "effect") } } diff --git a/man/plot_2D_intervals.Rd b/man/sccomp_plot_intervals_2D.Rd similarity index 90% rename from man/plot_2D_intervals.Rd rename to man/sccomp_plot_intervals_2D.Rd index 13b68270..2c77615e 100644 --- a/man/plot_2D_intervals.Rd +++ b/man/sccomp_plot_intervals_2D.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{plot_2D_intervals} -\alias{plot_2D_intervals} +% Please edit documentation in R/sccomp_plot_intervals.R +\name{sccomp_plot_intervals_2D} +\alias{sccomp_plot_intervals_2D} \title{Plot 2D Intervals for Mean-Variance Association} \usage{ -plot_2D_intervals( +sccomp_plot_intervals_2D( .data, factor = NULL, significance_threshold = 0.05, @@ -58,7 +58,7 @@ print("cmdstanr is needed to run this example.") sccomp_test() # Example usage: - my_plot = plot_2D_intervals(estimate) + my_plot = sccomp_plot_intervals_2D(estimate) } } diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index e0823fb7..47e90467 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -60,18 +60,18 @@ test_that("plot_1d_intervals function works correctly", { my_estimate |> sccomp_test() |> - plot_1D_intervals( + sccomp_plot_intervals_1D( significance_threshold = 0.025 ) |> expect_s3_class("patchwork") }) -test_that("plot_1D_intervals works with intercept-only composition", { +test_that("sccomp_plot_intervals_1D works with intercept-only composition", { skip_cmdstan() my_estimate_intercept_only |> sccomp_test() |> - plot_1D_intervals() |> + sccomp_plot_intervals_1D() |> expect_s3_class("patchwork") }) @@ -81,54 +81,54 @@ test_that("plot_2d_intervals function works correctly", { my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals( + sccomp_plot_intervals_2D( significance_threshold = 0.025 ) |> expect_s3_class("patchwork") }) -test_that("plot_1D_intervals accepts factor argument", { +test_that("sccomp_plot_intervals_1D accepts factor argument", { skip_cmdstan() expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(factor = "type") + sccomp_plot_intervals_1D(factor = "type") ) expect_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(factor = "not_a_factor"), + sccomp_plot_intervals_1D(factor = "not_a_factor"), "is not among model factors" ) }) -test_that("plot_2D_intervals accepts factor argument", { +test_that("sccomp_plot_intervals_2D accepts factor argument", { skip_cmdstan() expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(factor = "type") + sccomp_plot_intervals_2D(factor = "type") ) expect_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(factor = "not_a_factor"), + sccomp_plot_intervals_2D(factor = "not_a_factor"), "is not among model factors" ) }) # Test for show_fdr_message parameter in plot functions -test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { +test_that("show_fdr_message parameter works correctly in sccomp_plot_intervals_1D", { skip_cmdstan() # Test with show_fdr_message = TRUE (default) plot_with_message <- my_estimate |> sccomp_test() |> - plot_1D_intervals( + sccomp_plot_intervals_1D( significance_threshold = 0.025, show_fdr_message = TRUE ) @@ -138,7 +138,7 @@ test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { # Test with show_fdr_message = FALSE plot_without_message <- my_estimate |> sccomp_test() |> - plot_1D_intervals( + sccomp_plot_intervals_1D( significance_threshold = 0.025, show_fdr_message = FALSE ) @@ -150,13 +150,13 @@ test_that("show_fdr_message parameter works correctly in plot_1D_intervals", { expect_no_error(plot_without_message) }) -test_that("show_fdr_message parameter works correctly in plot_2D_intervals", { +test_that("show_fdr_message parameter works correctly in sccomp_plot_intervals_2D", { skip_cmdstan() # Test with show_fdr_message = TRUE (default) plot_with_message <- my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals( + sccomp_plot_intervals_2D( significance_threshold = 0.025, show_fdr_message = TRUE ) @@ -166,7 +166,7 @@ test_that("show_fdr_message parameter works correctly in plot_2D_intervals", { # Test with show_fdr_message = FALSE plot_without_message <- my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals( + sccomp_plot_intervals_2D( significance_threshold = 0.025, show_fdr_message = FALSE ) @@ -185,111 +185,111 @@ test_that("show_fdr_message parameter accepts logical values", { expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(show_fdr_message = TRUE) + sccomp_plot_intervals_1D(show_fdr_message = TRUE) ) # Test with FALSE expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(show_fdr_message = FALSE) + sccomp_plot_intervals_1D(show_fdr_message = FALSE) ) # Test with TRUE for 2D plots expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(show_fdr_message = TRUE) + sccomp_plot_intervals_2D(show_fdr_message = TRUE) ) # Test with FALSE for 2D plots expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(show_fdr_message = FALSE) + sccomp_plot_intervals_2D(show_fdr_message = FALSE) ) }) test_that("plot functions work with different significance thresholds", { skip_cmdstan() - # Test plot_1D_intervals with different thresholds + # Test sccomp_plot_intervals_1D with different thresholds expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_threshold = 0.01) + sccomp_plot_intervals_1D(significance_threshold = 0.01) ) expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_threshold = 0.1) + sccomp_plot_intervals_1D(significance_threshold = 0.1) ) - # Test plot_2D_intervals with different thresholds + # Test sccomp_plot_intervals_2D with different thresholds expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_threshold = 0.01) + sccomp_plot_intervals_2D(significance_threshold = 0.01) ) expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_threshold = 0.1) + sccomp_plot_intervals_2D(significance_threshold = 0.1) ) }) -test_that("significance_statistic argument works for plot_1D_intervals", { +test_that("significance_statistic argument works for sccomp_plot_intervals_1D", { skip_cmdstan() expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_statistic = "FDR") + sccomp_plot_intervals_1D(significance_statistic = "FDR") ) expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_statistic = "pH0") + sccomp_plot_intervals_1D(significance_statistic = "pH0") ) }) -test_that("significance_statistic argument works for plot_2D_intervals", { +test_that("significance_statistic argument works for sccomp_plot_intervals_2D", { skip_cmdstan() expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_statistic = "FDR") + sccomp_plot_intervals_2D(significance_statistic = "FDR") ) expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_statistic = "pH0") + sccomp_plot_intervals_2D(significance_statistic = "pH0") ) }) -test_that("show_fdr_message argument works for plot_1D_intervals and plot_2D_intervals", { +test_that("show_fdr_message argument works for sccomp_plot_intervals_1D and sccomp_plot_intervals_2D", { skip_cmdstan() expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_statistic = "FDR", show_fdr_message = TRUE) + sccomp_plot_intervals_1D(significance_statistic = "FDR", show_fdr_message = TRUE) ) expect_no_error( my_estimate |> sccomp_test() |> - plot_1D_intervals(significance_statistic = "FDR", show_fdr_message = FALSE) + sccomp_plot_intervals_1D(significance_statistic = "FDR", show_fdr_message = FALSE) ) expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_statistic = "FDR", show_fdr_message = TRUE) + sccomp_plot_intervals_2D(significance_statistic = "FDR", show_fdr_message = TRUE) ) expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_statistic = "FDR", show_fdr_message = FALSE) + sccomp_plot_intervals_2D(significance_statistic = "FDR", show_fdr_message = FALSE) ) }) @@ -324,12 +324,12 @@ test_that("significance_statistic and show_fdr_message work via plot() S3 method ) ) - fdr_plot <- plot_1D_intervals( + fdr_plot <- sccomp_plot_intervals_1D( my_estimate |> sccomp_test(), significance_statistic = "FDR", show_fdr_message = TRUE ) - ph0_plot <- plot_1D_intervals( + ph0_plot <- sccomp_plot_intervals_1D( my_estimate |> sccomp_test(), significance_statistic = "pH0", show_fdr_message = TRUE @@ -345,12 +345,12 @@ test_that("significance_statistic and show_fdr_message work via plot() S3 method expect_true(grepl("Bayesian FDR", patchwork_caption(fdr_plot))) expect_true(!grepl("Bayesian FDR", patchwork_caption(ph0_plot))) }) -test_that("plot_2D_intervals includes regression line from prec parameters", { +test_that("sccomp_plot_intervals_2D includes regression line from prec parameters", { skip_cmdstan() plot_2d <- my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_threshold = 0.025) + sccomp_plot_intervals_2D(significance_threshold = 0.025) expect_s3_class(plot_2d, "patchwork") @@ -366,13 +366,13 @@ test_that("plot_2D_intervals includes regression line from prec parameters", { expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_threshold = 0.025, significance_statistic = "pH0") + sccomp_plot_intervals_2D(significance_threshold = 0.025, significance_statistic = "pH0") ) expect_no_error( my_estimate_with_variance |> sccomp_test() |> - plot_2D_intervals(significance_threshold = 0.025, show_fdr_message = FALSE) + sccomp_plot_intervals_2D(significance_threshold = 0.025, show_fdr_message = FALSE) ) }) diff --git a/vignettes/introduction.Rmd b/vignettes/introduction.Rmd index 053ce6ea..14452791 100644 --- a/vignettes/introduction.Rmd +++ b/vignettes/introduction.Rmd @@ -307,7 +307,7 @@ A plot of estimates of differential composition (c_) on the x-axis and different ```{r plot-1d-intervals, eval = instantiate::stan_cmdstan_exists(), message=FALSE} sccomp_result |> - plot_1D_intervals() + sccomp_plot_intervals_1D() ``` @@ -316,7 +316,7 @@ We can plot the relationship between abundance and variability. As we can see be ```{r plot-2d-intervals, eval = instantiate::stan_cmdstan_exists(), message=FALSE} sccomp_result |> - plot_2D_intervals() + sccomp_plot_intervals_2D() ``` You can produce the series of plots calling the `plot` method. From 47981a8f0aeb27523f3234faddc93ce140e5010e Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sun, 5 Apr 2026 09:54:36 +0930 Subject: [PATCH 24/68] Enhance variability to composition mapping functionality Refine the `get_variability_to_composition_map` function to improve error handling for missing variability terms in the composition design matrix. Introduce logic to handle cases where the variability formula consists solely of an intercept, ensuring proper mapping to the composition matrix. Update documentation to clarify the mapping process and its exceptions, enhancing overall robustness. --- R/utilities.R | 44 ++++++++++++++----- .../test-variability-design-mapping.R | 23 ++++++++++ 2 files changed, 55 insertions(+), 12 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 724ff581..d2a3f491 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -751,6 +751,13 @@ calculate_na_fraction_contribution = function(my_design_matrix, na_cols, design_ #' #' Match variability to composition design columns #' +#' Normally every column of `Xa` must appear in `X` (variability is a sub-formula of +#' composition). **Exception:** `formula_variability = ~ 1` yields a single `(Intercept)` +#' column in `Xa`. If the composition matrix has no `(Intercept)` (e.g. +#' `formula_composition = ~ 0 + type`), that term has no name in `X`; we map it to +#' composition column `1` so the single shared variability level uses one explicit +#' `beta[1]` in the abundance-variability link in Stan. +#' #' @param X Composition design matrix #' @param Xa Variability design matrix #' @@ -758,19 +765,32 @@ calculate_na_fraction_contribution = function(my_design_matrix, na_cols, design_ #' @keywords internal #' @noRd get_variability_to_composition_map = function(X, Xa) { - variability_to_composition_map = match(colnames(Xa), colnames(X)) - - if (any(is.na(variability_to_composition_map))) { - missing_terms = colnames(Xa)[is.na(variability_to_composition_map)] - stop( - sprintf( - paste0( - "sccomp says: every variability design term must also be present ", - "in the composition design matrix. Missing terms: %s" - ), - paste(missing_terms, collapse = ", ") + comp_names = colnames(X) + var_names = colnames(Xa) + variability_to_composition_map = match(var_names, comp_names) + missing_idx = is.na(variability_to_composition_map) + + if (any(missing_idx)) { + missing_terms = var_names[missing_idx] + only_intercept_variability = + length(var_names) == 1L && var_names[1] == "(Intercept)" + if ( + only_intercept_variability && + !("(Intercept)" %in% comp_names) && + length(comp_names) >= 1L + ) { + variability_to_composition_map[missing_idx] = 1L + } else { + stop( + sprintf( + paste0( + "sccomp says: every variability design term must also be present ", + "in the composition design matrix. Missing terms: %s" + ), + paste(missing_terms, collapse = ", ") + ) ) - ) + } } as.integer(variability_to_composition_map) diff --git a/tests/testthat/test-variability-design-mapping.R b/tests/testthat/test-variability-design-mapping.R index 37da0ef4..080ece19 100644 --- a/tests/testthat/test-variability-design-mapping.R +++ b/tests/testthat/test-variability-design-mapping.R @@ -15,6 +15,29 @@ test_that("get_variability_to_composition_map matches by column name", { ) }) +test_that("get_variability_to_composition_map maps ~1 variability when composition has no intercept", { + X <- matrix(0, nrow = 2, ncol = 2) + colnames(X) <- c("typehealthy", "typecancer") + + Xa <- matrix(0, nrow = 2, ncol = 1) + colnames(Xa) <- "(Intercept)" + + expect_equal(sccomp:::get_variability_to_composition_map(X, Xa), 1L) +}) + +test_that("get_variability_to_composition_map still errors if (Intercept) is extra among multiple variability columns", { + X <- matrix(0, nrow = 2, ncol = 2) + colnames(X) <- c("typehealthy", "typecancer") + + Xa <- matrix(0, nrow = 2, ncol = 2) + colnames(Xa) <- c("(Intercept)", "typehealthy") + + expect_error( + sccomp:::get_variability_to_composition_map(X, Xa), + "Missing terms: \\(Intercept\\)" + ) +}) + test_that("get_variability_to_composition_map errors on missing terms", { X <- matrix(0, nrow = 2, ncol = 2) colnames(X) <- c("(Intercept)", "typehealthy") From 13ae3f1fc3e9293407fbbdb9aaf077ca49443c63 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 10:27:15 +0930 Subject: [PATCH 25/68] Enhance Stan model integration and update plotting functions Add new imports for `stan_package_compile` and `stan_package_model` to improve Stan model handling. Refactor `sccomp_remove_outliers` to utilize the correct output files from the updated fit object. Clean up documentation by removing unnecessary lines in `sccomp_estimate` and `sccomp_remove_outliers` man pages, ensuring clarity and conciseness. These changes enhance the overall functionality and maintainability of the codebase. --- NAMESPACE | 2 + R/plot.R | 970 ---------------------------------- R/sccomp_remove_outliers.R | 1 - man/sccomp_estimate.Rd | 1 - man/sccomp_remove_outliers.Rd | 1 - 5 files changed, 2 insertions(+), 973 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1167d30b..1d8de29a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -97,6 +97,8 @@ importFrom(ggplot2,theme_void) importFrom(ggrepel,geom_text_repel) importFrom(glue,glue) importFrom(instantiate,stan_cmdstan_exists) +importFrom(instantiate,stan_package_compile) +importFrom(instantiate,stan_package_model) importFrom(lifecycle,deprecate_soft) importFrom(lifecycle,deprecate_warn) importFrom(lifecycle,is_present) diff --git a/R/plot.R b/R/plot.R index 80cccc4e..8570b411 100644 --- a/R/plot.R +++ b/R/plot.R @@ -165,976 +165,6 @@ plot.sccomp_tbl <- function( } -#' Plot 1D Intervals for Cell-group Effects -#' -#' This function creates a series of 1D interval plots for cell-group effects, highlighting significant differences based on a given significance threshold. -#' -#' @param .data Data frame containing the main data. -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. -#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. A value of 0.2 correspond to a change in cell proportion of 10% for a cell type with baseline proportion of 50%. That is, a cell type goes from 45% to 50%. When the baseline proportion is closer to 0 or 1 this effect thrshold has consistent value in the logit uncontrained scale. -#' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. -#' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". -#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. -#' @param sort_by Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical". -#' @importFrom patchwork wrap_plots -#' @importFrom forcats fct_reorder -#' @importFrom tidyr drop_na -#' -#' @export -#' -#' @return A combined plot of 1D interval plots. -#' @examples -#' -#' print("cmdstanr is needed to run this example.") -#' -#' \donttest{ -#' if (instantiate::stan_cmdstan_exists()) { -#' data("counts_obj") -#' -#' estimate <- sccomp_estimate( -#' counts_obj, -#' ~ type, -#' ~1, -#' "sample", -#' "cell_group", -#' "count", -#' cores = 1 -#' ) |> -#' sccomp_test() -#' -#' # Example usage: -#' my_plot = plot_1D_intervals(estimate, sort_by = "effect") -#' -#' } -#' } -#' -#' -plot_1D_intervals = function( - .data, - factor = NULL, - significance_threshold = 0.05, - test_composition_above_logit_fold_change = .data |> attr("test_composition_above_logit_fold_change"), - show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR"), - sort_by = c("none", "effect", "significance", "alphabetical") -) { - significance_statistic <- match.arg(significance_statistic) - sort_by <- match.arg(sort_by) - - # Define the variables as NULL to avoid CRAN NOTES - parameter <- NULL - estimate <- NULL - value <- NULL - pH0 <- NULL - FDR <- NULL - effect <- NULL - - .cell_group = attr(.data, ".cell_group") - - # Check if test have been done - if(.data |> select(ends_with("FDR")) |> ncol() |> equals(0)) - stop("sccomp says: to produce plots, you need to run the function sccomp_test() on your estimates.") - - .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) - - plot_list = - .data |> - - # Reshape data - select(-contains("n_eff"), -contains("R_k_hat"), -contains("_ess"), -contains("_rhat")) |> - pivot_longer(c(contains("c_"), contains("v_")), names_sep = "_", names_to = c("which", "estimate")) |> - pivot_wider(names_from = estimate, values_from = value) |> - - # Nest data by parameter and which - nest(data = -c(parameter, which)) |> - mutate(plot = pmap( - list(data, which, parameter), - function(plot_data, plot_which, plot_param) { - # Check if there are any statistics to plot - if(plot_data |> filter(!is.na(effect)) |> nrow() |> equals(0)) - return(NA) - - # Choose color variable and legend - if (significance_statistic == "FDR") { - color_aes <- aes(xmin = lower, xmax = upper, color = FDR < significance_threshold) - color_scale <- scale_color_manual(values = c("grey40", "red")) - legend_title <- "FDR < significance_threshold" - } else { - color_aes <- aes(xmin = lower, xmax = upper, color = pH0 < significance_threshold) - color_scale <- scale_color_manual(values = c("grey40", "red")) - legend_title <- "pH0 < significance_threshold" - } - - # Determine y-axis variable based on sort_by - # Use string-based column selection instead of NSE - if (sort_by == "none") { - # No sorting - plot_data$y_var <- plot_data[[.cell_group]] - } else if (sort_by == "effect") { - # Sort by absolute effect size - plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], abs(plot_data$effect)) - } else if (sort_by == "significance") { - # Sort by significance - if (significance_statistic == "FDR") { - plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$FDR, .desc = TRUE) - } else { - plot_data$y_var <- fct_reorder(plot_data[[.cell_group]], plot_data$pH0, .desc = TRUE) - } - } else if (sort_by == "alphabetical") { - # Alphabetical sorting - plot_data <- plot_data %>% arrange(.data[[.cell_group]]) - plot_data$y_var <- fct_inorder(plot_data[[.cell_group]]) - } - - ggplot(plot_data, aes(x = effect, y = y_var)) + - geom_vline(xintercept = test_composition_above_logit_fold_change, colour = "grey") + - geom_vline(xintercept = -test_composition_above_logit_fold_change, colour = "grey") + - geom_errorbar(color_aes) + - geom_point() + - color_scale + - xlab("Credible interval of the effect") + - ylab("Cell group") + - ggtitle(sprintf("%s %s", plot_which, plot_param)) + - sccomp_theme() + - theme(legend.position = "bottom") + - guides(color = guide_legend(title = legend_title)) - } - )) %>% - - # Filter out NA plots - filter(!is.na(plot)) |> - pull(plot) - - # Combine all individual plots into one plot - combined_plot <- plot_list |> - wrap_plots(ncol = plot_list |> length() |> sqrt() |> ceiling()) - - # Only show the FDR message if significance_statistic == "FDR" and show_fdr_message is TRUE - if (significance_statistic == "FDR" && show_fdr_message) { - caption_text <- paste( - "Bayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", - "\nFDR-significant populations may cross fold change thresholds because Bayesian FDR considers posterior probabilities rather than p-values.", - "\nThe method sorts null hypothesis probabilities in ascending order and calculates cumulative averages for robust false discovery control.", - sep = "" - ) - combined_plot <- combined_plot + patchwork::plot_annotation( - caption = caption_text - ) - } - combined_plot -} - -#' Plot 2D Intervals for Mean-Variance Association -#' -#' This function creates a 2D interval plot for mean-variance association, handling both single and bimodal models. -#' It highlights significant differences based on a given significance threshold. -#' -#' @param .data Data frame containing the main data. -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.05. -#' @param test_composition_above_logit_fold_change A positive integer. It is the effect threshold used for the hypothesis test. -#' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. -#' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". -#' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. -#' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. -#' -#' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups -#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point geom_line geom_area aes facet_wrap theme_bw theme labs guides guide_legend scale_color_manual scale_alpha_manual scale_fill_manual scale_y_continuous coord_flip theme_void element_rect element_text margin -#' @importFrom ggrepel geom_text_repel -#' @importFrom stringr str_detect -#' @importFrom patchwork plot_annotation wrap_plots plot_layout -#' -#' @export -#' -#' @return A ggplot object representing the 2D interval plot. -#' -#' @examples -#' -#' print("cmdstanr is needed to run this example.") -#' -#' \donttest{ -#' if (instantiate::stan_cmdstan_exists()) { -#' data("counts_obj") -#' -#' estimate <- sccomp_estimate( -#' counts_obj, -#' ~ type, -#' ~type, -#' "sample", -#' "cell_group", -#' "count", -#' cores = 1, -#' bimodal_mean_variability_association = TRUE -#' ) |> -#' sccomp_test() -#' -#' # Example usage: -#' my_plot = plot_2D_intervals(estimate) -#' -#' } -#' } -#' -plot_2D_intervals <- function( - .data, - factor = NULL, - significance_threshold = 0.05, - test_composition_above_logit_fold_change = - .data |> attr("test_composition_above_logit_fold_change"), - show_fdr_message = TRUE, - significance_statistic = c("pH0", "FDR"), - add_marginal_density = TRUE -) { - - significance_statistic <- match.arg(significance_statistic) - - # Define variables to avoid CRAN NOTES - v_effect <- NULL - parameter <- NULL - c_effect <- NULL - c_lower <- NULL - c_upper <- NULL - c_FDR <- NULL - v_lower <- NULL - v_upper <- NULL - v_FDR <- NULL - cell_type_label <- NULL - pH0 <- NULL - FDR <- NULL - c_pH0 <- NULL - v_pH0 <- NULL - component <- NULL - assigned_component <- NULL - - .cell_group <- attr(.data, ".cell_group") - - # Check if test has been done - if(.data |> select(ends_with("FDR")) |> ncol() == 0) - stop("sccomp says: you need to run sccomp_test() first.") - - .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) - - # Extract fitted model and mean-variability regression coefficients - fit <- attr(.data, "fit") - prec_intercept_1_summary <- fit$summary("prec_intercept_1") - prec_slope_1_summary <- fit$summary("prec_slope_1") - prec_intercept_2_summary <- tryCatch( - fit$summary("prec_intercept_2"), - error = function(e) tibble() - ) - prec_slope_2_summary <- tryCatch( - fit$summary("prec_slope_2"), - error = function(e) tibble() - ) - - param_names <- .data |> - filter(!is.na(v_effect)) |> - distinct(parameter) |> - pull(parameter) - - param_idx <- match(param_names, colnames(attr(.data, "model_input")$Xa)) - if (any(is.na(param_idx))) { - stop("sccomp says: could not map selected parameters to model coefficients.") - } - - # Derive model type from stored model metadata - bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association - if (is.null(bimodal_flag)) { - stop("sccomp says: cannot infer model type because `bimodal_mean_variability_association` is missing from model metadata.") - } - bimodal_flag <- isTRUE(as.logical(bimodal_flag)) - - # Extract parameters based on model type - if (!bimodal_flag) { - params_list <- lapply(seq_along(param_names), function(a) { - param_name <- param_names[a] - idx <- param_idx[a] - list( - parameter = param_name, - intercept = prec_intercept_1_summary$mean[idx], - slope = prec_slope_1_summary$mean[idx] - ) - }) - - cat("=== Single Model Parameters ===\n") - for(i in 1:length(params_list)) { - p <- params_list[[i]] - cat(sprintf("\n%s:\n", p$parameter)) - cat(sprintf(" v = -(%.3f + %.3f × c)\n", p$intercept, p$slope)) - } - cat("\n") - - } else { - mix_p <- fit$summary("mix_p") |> pull(mean) - - params_list <- lapply(seq_along(param_names), function(a) { - param_name <- param_names[a] - idx <- param_idx[a] - - list( - parameter = param_name, - intercept_1 = prec_intercept_1_summary$mean[idx], - slope_1 = prec_slope_1_summary$mean[idx], - slope_2 = prec_slope_2_summary$mean[idx], - intercept_2 = prec_intercept_2_summary$mean[idx] - ) - }) - - cat("=== Bimodal Model Parameters ===\n") - for(i in 1:length(params_list)) { - p <- params_list[[i]] - cat(sprintf("\n%s:\n", p$parameter)) - cat(sprintf(" Component 1: v = -(%.3f + %.3f × c)\n", p$intercept_1, p$slope_1)) - cat(sprintf(" Component 2: v = -(%.3f + %.3f × c)\n", p$intercept_2, p$slope_2)) - } - cat("\n") - } - - # v_effect already comes from alpha_normalised (adjusted in Stan) - # "raw" panel: ADD BACK entanglement to show raw alpha - # "adjusted" panel: USE v_effect AS-IS - - if (!bimodal_flag) { - .data_raw_list <- lapply(params_list, function(params) { - .data %>% - filter(parameter == params$parameter) %>% - mutate( - v_effect = v_effect - params$slope * c_effect, - v_lower = v_lower - params$slope * c_effect, - v_upper = v_upper - params$slope * c_effect, - parameter = paste0(params$parameter, ", raw") - ) - }) - } else { - .data_raw_list <- lapply(params_list, function(params) { - .data %>% - filter(parameter == params$parameter) %>% - rowwise() %>% - mutate( - raw_v_comp1 = v_effect - params$slope_1 * c_effect, - raw_v_comp2 = v_effect - params$slope_2 * c_effect, - pred_comp1 = -(params$intercept_1 + params$slope_1 * c_effect), - pred_comp2 = -(params$intercept_2 + params$slope_2 * c_effect), - assigned_component = if_else( - abs(raw_v_comp1 - pred_comp1) < abs(raw_v_comp2 - pred_comp2), 1, 2 - ), - slope_to_use = if_else(assigned_component == 1, params$slope_1, params$slope_2), - v_effect = v_effect - slope_to_use * c_effect, - v_lower = v_lower - slope_to_use * c_effect, - v_upper = v_upper - slope_to_use * c_effect, - parameter = paste0(params$parameter, ", raw") - ) %>% - ungroup() %>% - select(-raw_v_comp1, -raw_v_comp2, -pred_comp1, -pred_comp2, -slope_to_use) - }) - } - - .data_raw <- bind_rows(.data_raw_list) - - # Adjusted panel: v_effect as-is (already from alpha_normalised) - .data_adjusted_list <- lapply(params_list, function(params) { - .data %>% - filter(parameter == params$parameter) %>% - mutate(parameter = paste0(params$parameter, ", adjusted")) - }) - .data_adjusted <- bind_rows(.data_adjusted_list) - - .data_plot <- bind_rows(.data_raw, .data_adjusted) - - # Set parameter factor levels - param_order <- c() - for(p in params_list) { - param_order <- c(param_order, paste0(p$parameter, ", raw"), paste0(p$parameter, ", adjusted")) - } - - .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) - - # Add labels for significant cell groups - .data_plot <- .data_plot %>% - filter(!is.na(v_effect)) %>% - with_groups( - parameter, - ~ .x %>% - arrange(c_FDR) %>% - mutate( - cell_type_label = if_else( - row_number() <= 3 & - c_FDR < significance_threshold & - str_detect(parameter, ", adjusted$"), - !!sym(.cell_group), - "" - ) - ) - ) %>% - with_groups( - parameter, - ~ .x %>% - arrange(v_FDR) %>% - mutate( - cell_type_label = if_else( - row_number() <= 3 & - v_FDR < significance_threshold & - str_detect(parameter, ", adjusted$") & - cell_type_label == "", - !!sym(.cell_group), - cell_type_label - ) - ) - ) - - # Choose color aesthetics based on significance statistic - if (significance_statistic == "FDR") { - color_c_aes <- aes( - xmin = c_lower, xmax = c_upper, - color = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), - alpha = c_FDR < significance_threshold & str_detect(parameter, ", adjusted$") - ) - color_v_aes <- aes( - ymin = v_lower, ymax = v_upper, - color = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), - alpha = v_FDR < significance_threshold & str_detect(parameter, ", adjusted$") - ) - color_scale <- scale_color_manual(values = c("#D3D3D3", "#E41A1C")) - alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) - legend_title <- "FDR < significance_threshold" - } else { - color_c_aes <- aes( - xmin = c_lower, xmax = c_upper, - color = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), - alpha = c_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") - ) - color_v_aes <- aes( - ymin = v_lower, ymax = v_upper, - color = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$"), - alpha = v_pH0 < significance_threshold & str_detect(parameter, ", adjusted$") - ) - color_scale <- scale_color_manual(values = c("#D3D3D3", "#377EB8")) - alpha_scale <- scale_alpha_manual(values = c(0.4, 1)) - legend_title <- "pH0 < significance_threshold" - } - - # Prepare regression line data based on model type - if (!bimodal_flag) { - regression_data_all <- lapply(params_list, function(params) { - raw_param <- paste0(params$parameter, ", raw") - param_data <- .data_plot %>% filter(parameter == raw_param) - if(nrow(param_data) == 0) return(NULL) - - c_range <- range(param_data$c_effect, na.rm = TRUE) - c_seq <- seq(c_range[1], c_range[2], length.out = 100) - v_pred <- -(params$intercept + params$slope * c_seq) - - data.frame( - c_effect = c_seq, - v_effect = v_pred, - parameter = raw_param, - stringsAsFactors = FALSE - ) - }) %>% bind_rows() - - adjusted_lines_all <- lapply(params_list, function(params) { - adj_param <- paste0(params$parameter, ", adjusted") - adj_data <- .data_plot %>% filter(parameter == adj_param) - if(nrow(adj_data) == 0) return(NULL) - - c_range_adj <- range(adj_data$c_effect, na.rm = TRUE) - mean_adj <- mean(adj_data$v_effect, na.rm = TRUE) - - data.frame( - c_effect = c_range_adj, - v_effect = rep(mean_adj, 2), - parameter = adj_param, - stringsAsFactors = FALSE - ) - }) %>% bind_rows() - - caption_text <- paste( - "Single model with parameter-specific slopes", - "\nBlue line shows mean-variability relationship for each parameter", - "\n'Adjusted' panels show variability after removing parameter-specific mean-variability association", - "\nMarginal density shows posterior distribution of variability intercept parameters", - "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", - sep = "" - ) - - } else { - regression_data_all <- lapply(params_list, function(params) { - raw_param <- paste0(params$parameter, ", raw") - param_data <- .data_plot %>% filter(parameter == raw_param) - if(nrow(param_data) == 0) return(NULL) - - c_range <- range(param_data$c_effect, na.rm = TRUE) - c_seq <- seq(c_range[1], c_range[2], length.out = 100) - - v_pred_1 <- -(params$intercept_1 + params$slope_1 * c_seq) - v_pred_2 <- -(params$intercept_2 + params$slope_2 * c_seq) - - bind_rows( - data.frame( - c_effect = c_seq, v_effect = v_pred_1, - parameter = raw_param, component = "Component 1" - ), - data.frame( - c_effect = c_seq, v_effect = v_pred_2, - parameter = raw_param, component = "Component 2" - ) - ) - }) %>% bind_rows() - - adjusted_lines_all <- lapply(params_list, function(params) { - adj_param <- paste0(params$parameter, ", adjusted") - c_range_adj <- range(.data_plot$c_effect[.data_plot$parameter == adj_param], na.rm = TRUE) - - bind_rows( - data.frame( - c_effect = c_range_adj, v_effect = rep(-params$intercept_1, 2), - parameter = adj_param, component = "Component 1" - ), - data.frame( - c_effect = c_range_adj, v_effect = rep(-params$intercept_2, 2), - parameter = adj_param, component = "Component 2" - ) - ) - }) %>% bind_rows() - - caption_text <- paste( - sprintf("Bimodal model: mix_p = %.3f (Component 1 weight)", mix_p), - "\nSolid blue line = Component 1 | Dashed orange line = Component 2", - "\n'Adjusted' panels show variability after removing mean-variability association", - "\nMarginal density shows posterior distribution of variability intercept parameters", - "\nBayesian FDR: Stephens' method (doi: 10.1093/biostatistics/kxw041)", - sep = "") - } - - # Add caption based on model type - if (significance_statistic == "FDR" && show_fdr_message) { - - - plot <- plot + ggplot2::labs(caption = caption_text) - plot <- plot + theme(plot.caption = ggplot2::element_text(hjust = 0)) - } - plot -} - - - - -#' Plot Scatterplot of Cell-group Proportion -#' -#' This function creates a scatterplot of cell-group proportions, optionally highlighting significant differences based on a given significance threshold. -#' -#' @param .data Data frame containing the main data. -#' @param data_proportion Data frame containing proportions of cell groups. -#' @param factor_of_interest A factor indicating the biological condition of interest. -#' @param .cell_group The cell group to be analysed. -#' @param .sample The sample identifier. -#' @param significance_threshold Numeric value specifying the significance threshold for highlighting differences. Default is 0.025. -#' @param my_theme A ggplot2 theme object to be applied to the plot. -#' @importFrom scales trans_new -#' @importFrom stringr str_replace -#' @importFrom stats quantile -#' @importFrom magrittr equals -#' -#' -#' @return A ggplot object representing the scatterplot. -#' @examples -#' # Example usage: -#' # plot_scatterplot(.data, data_proportion, "condition", "cell_group", "sample", 0.025, theme_minimal()) -plot_scatterplot = function( - .data, data_proportion, factor_of_interest, .cell_group, - .sample, significance_threshold = 0.05, my_theme -){ - - # Define the variables as NULL to avoid CRAN NOTES - stats_name <- NULL - parameter <- NULL - stats_value <- NULL - count_data <- NULL - generated_proportions <- NULL - proportion <- NULL - name <- NULL - outlier <- NULL - - # Function to remove leading zero from labels - dropLeadingZero <- function(l){ stringr::str_replace(l, '0(?=.)', '') } - - # Define square root transformation and its inverse - S_sqrt <- function(x){sign(x)*sqrt(abs(x))} - IS_sqrt <- function(x){x^2*sign(x)} - S_sqrt_trans <- function() scales::trans_new("S_sqrt",S_sqrt,IS_sqrt) - - .cell_group = enquo(.cell_group) - .sample = enquo(.sample) - - # Prepare significance colors - significance_colors = - .data %>% - pivot_longer( - c(contains("c_"), contains("v_")), - names_pattern = "([cv])_([a-zA-Z0-9]+)", - names_to = c("which", "stats_name"), - values_to = "stats_value" - ) %>% - filter(stats_name == "FDR") %>% - filter(parameter != "(Intercept)") %>% - filter(stats_value < significance_threshold) %>% - filter(`factor` == factor_of_interest) - - if(nrow(significance_colors) > 0){ - - if(.data |> attr("contrasts") |> is.null()) - significance_colors = - significance_colors %>% - unite("name", c(which, parameter), remove = FALSE) %>% - distinct() %>% - - # Get clean parameter - mutate(!!as.symbol(factor_of_interest) := str_replace(parameter, sprintf("^%s", `factor`), "")) %>% - with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) - else - significance_colors = - significance_colors |> - mutate( - factor_values = attr(.data, "count_data") |> - select(all_of(factor_of_interest)) |> - distinct() |> - pull(all_of(factor_of_interest)) - ) |> - unnest(factor_values) |> - - # Filter relevant parameters - mutate( !!as.symbol(factor_of_interest) := as.character(factor_values) ) |> - filter(str_detect(parameter, !!as.symbol(factor_of_interest) )) |> - - # Rename - select(!!.cell_group, !!as.symbol(factor_of_interest), name = parameter) |> - - # Merge contrasts - with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) - } - - my_scatterplot = ggplot() - - if("fit" %in% names(attributes(.data))){ - - simulated_proportion = - .data |> - sccomp_replicate(number_of_draws = 1000) |> - left_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.sample, !!.cell_group)) - - my_scatterplot = - my_scatterplot + - - # Add smoothed line for simulated proportions - geom_smooth( - aes(!!as.symbol(factor_of_interest), (generated_proportions)), - lwd=0.2, - data = - simulated_proportion %>% - inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group, !!.sample)) , - color="blue", fill="blue", - span = 1 - ) - } - - if( - nrow(significance_colors)==0 || - - significance_colors |> - pull(!!as.symbol(factor_of_interest)) |> - intersect( - data_proportion |> - pull(!!as.symbol(factor_of_interest)) - ) |> - length() |> - equals(0) - ) { - - my_scatterplot= - my_scatterplot + - - # Add smoothed line without significance colors - geom_smooth( - aes(!!as.symbol(factor_of_interest), proportion, fill = NULL), - data = - data_proportion , - lwd=0.5, - color = "black", - span = 1 - ) - } - } else { - caption_text <- NULL - } - - # Add marginal density plots if requested - if (add_marginal_density) { - - plot_list <- lapply(param_order, function(param) { - - param_data <- .data_plot %>% filter(parameter == param) - if(nrow(param_data) == 0) return(NULL) - - # Create main plot - p_param <- ggplot(param_data, aes(c_effect, v_effect)) + - geom_vline( - xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) + - geom_hline( - yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) - - # Add regression lines - if (!bimodal_flag) { - reg_data <- regression_data_all %>% filter(parameter == param) - if(!is.null(reg_data) && nrow(reg_data) > 0) { - p_param <- p_param + - geom_line(data = reg_data, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - - adj_line <- adjusted_lines_all %>% filter(parameter == param) - if(!is.null(adj_line) && nrow(adj_line) > 0) { - p_param <- p_param + - geom_line(data = adj_line, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - - } else { - reg_data <- regression_data_all %>% filter(parameter == param) - if(!is.null(reg_data) && nrow(reg_data) > 0) { - p_param <- p_param + - geom_line(data = reg_data %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = reg_data %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - - adj_line <- adjusted_lines_all %>% filter(parameter == param) - if(!is.null(adj_line) && nrow(adj_line) > 0) { - p_param <- p_param + - geom_line(data = adj_line %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = adj_line %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - } - - # Add error bars, points, and labels - p_param <- p_param + - geom_errorbar(color_c_aes, linewidth = 0.2) + - geom_errorbar(color_v_aes, linewidth = 0.2) + - geom_point(size = 0.2) + - geom_text_repel( - aes(c_effect, -v_effect, label = cell_type_label), - size = 2.5, - data = param_data %>% filter(cell_type_label != ""), - max.overlaps = 20 - ) + - color_scale + - alpha_scale + - xlab("c_effect (Abundance effect)") + - ylab("v_effect (Variability effect)") + - ggtitle(param) + - theme_bw() + - theme( - legend.position = "bottom", - strip.background = element_rect(fill = "white"), - panel.grid.minor = element_blank() - ) + - guides(color = guide_legend(title = legend_title), alpha = "none") - - # Add marginal density for adjusted panels (not Intercept) - if (str_detect(param, ", adjusted$") && !str_detect(param, "Intercept")) { - - if (!bimodal_flag) { - param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) - - if (length(param_idx) > 0) { - intercept_var_name <- paste0("prec_intercept_1[", param_idx, "]") - - tryCatch({ - intercept_draws <- fit$draws(variables = intercept_var_name, format = "draws_df") - intercept_values <- as.vector(intercept_draws[[intercept_var_name]]) - - dens <- density(-intercept_values, na.rm = TRUE) - dens_df <- data.frame(x = dens$x, y = dens$y) - - - y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range - - p_density <- ggplot(dens_df, aes(x = x, y = y)) + - geom_area(alpha = 0.5, position = "identity") + - geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + - coord_flip(xlim = y_range) + - scale_y_continuous(expand = c(0, 0)) + - xlab("Posterior Probability") + - theme_void() + - theme( - plot.margin = margin(t = 0, r = 0, b = 0, l = 6), - axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) - ) - - p_combined <- p_param + p_density + - plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & - theme(legend.position = "bottom") - - return(p_combined) - }, error = function(e) { - warning(sprintf("Could not extract intercept draws for %s: %s", intercept_var_name, e$message)) - return(p_param) - }) - } - - } else { - param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) - - if (length(param_idx) > 0) { - intercept1_var_name <- paste0("prec_intercept_1[", param_idx, "]") - intercept2_var_name <- paste0("prec_intercept_2[", param_idx, "]") - - tryCatch({ - intercept1_draws <- fit$draws(variables = intercept1_var_name, format = "draws_df") - intercept2_draws <- fit$draws(variables = intercept2_var_name, format = "draws_df") - - intercept1_values <- as.vector(intercept1_draws[[intercept1_var_name]]) - intercept2_values <- as.vector(intercept2_draws[[intercept2_var_name]]) - - dens1 <- density(-intercept1_values, na.rm = TRUE) - dens2 <- density(-intercept2_values, na.rm = TRUE) - - dens_df <- bind_rows( - data.frame(x = dens1$x, y = dens1$y, component = "Component 1"), - data.frame(x = dens2$x, y = dens2$y, component = "Component 2") - ) - - - y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range - - p_density <- ggplot(dens_df, aes(x = x, y = y, fill = component)) + - geom_area(alpha = 0.5, position = "identity") + - geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + - scale_fill_manual(values = c("Component 1" = "#0072B2", "Component 2" = "#D55E00")) + - coord_flip(xlim = y_range) + - scale_y_continuous(expand = c(0, 0)) + - xlab("Posterior Probability") + - theme_void() + - theme( - plot.margin = margin(t = 0, r = 0, b = 0, l = 5), - legend.position = "none", - axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) - ) - - p_combined <- p_param + p_density + - plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & - theme(legend.position = "bottom") - - return(p_combined) - }, error = function(e) { - warning(sprintf("Could not extract intercept draws: %s", e$message)) - return(p_param) - }) - } - } - } - - return(p_param) - }) - - - plot_list <- plot_list[!sapply(plot_list, is.null)] - combined_plot <- patchwork::wrap_plots(plot_list, ncol = 2) - - if (!is.null(caption_text)) { - combined_plot <- combined_plot + - plot_annotation( - caption = caption_text, - theme = theme(plot.caption = element_text(hjust = 0, size = 9)) - ) - } - - return(combined_plot) - - } else { - # Return faceted plot without marginal densities - p <- ggplot(.data_plot, aes(c_effect, v_effect)) + - geom_vline( - xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) + - geom_hline( - yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) - - # Add regression lines - if (!bimodal_flag) { - if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { - p <- p + geom_line(data = regression_data_all, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { - p <- p + geom_line(data = adjusted_lines_all, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - } else { - if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { - p <- p + - geom_line(data = regression_data_all %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = regression_data_all %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { - p <- p + - geom_line(data = adjusted_lines_all %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = adjusted_lines_all %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - } - - p <- p + - geom_errorbar(color_c_aes, linewidth = 0.2) + - geom_errorbar(color_v_aes, linewidth = 0.2) + - geom_point(size = 0.2) + - geom_text_repel( - aes(c_effect, -v_effect, label = cell_type_label), - size = 2.5, - data = .data_plot %>% filter(cell_type_label != ""), - max.overlaps = 20 - ) + - color_scale + - alpha_scale + - facet_wrap(~ parameter, scales = "free", ncol = 2) + - xlab("c_effect (Abundance effect)") + - ylab("v_effect (Variability effect)") + - theme_bw() + - theme( - legend.position = "bottom", - strip.background = element_rect(fill = "white"), - panel.grid.minor = element_blank() - ) + - guides(color = guide_legend(title = legend_title), alpha = "none") - - if (!is.null(caption_text)) { - p <- p + - theme(plot.caption = element_text(hjust = 0, size = 9)) + - labs(caption = caption_text) - } - - return(p) - } -} - #' Plot Scatterplot of Cell-group Proportion #' #' This function creates a scatterplot of cell-group proportions, optionally diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index 2b983c1f..4c38f8f6 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -509,7 +509,6 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, if (dir.exists(output_directory)) { files_deleted <- attr(estimate_tibble, "fit")$output_files(include_failed = TRUE) - if (length(files_deleted) > 0) { suppressWarnings(unlink(files_deleted, force = TRUE)) message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", length(files_deleted), output_directory)) diff --git a/man/sccomp_estimate.Rd b/man/sccomp_estimate.Rd index a99999e7..128a2011 100644 --- a/man/sccomp_estimate.Rd +++ b/man/sccomp_estimate.Rd @@ -128,7 +128,6 @@ A tibble (\code{tbl}), with the following columns: \item v_ess_bulk - Bulk effective sample size for the variability (v) parameter. \item v_ess_tail - Tail effective sample size for the variability (v) parameter. } - Note: pH0 and FDR columns are not computed by \code{sccomp_estimate()}. Run \code{sccomp_test()} on the result to obtain hypothesis-test statistics. The function also attaches several attributes to the result: diff --git a/man/sccomp_remove_outliers.Rd b/man/sccomp_remove_outliers.Rd index d4062553..f3bc59b8 100644 --- a/man/sccomp_remove_outliers.Rd +++ b/man/sccomp_remove_outliers.Rd @@ -75,7 +75,6 @@ A tibble (\code{tbl}), with the following columns: \item v_ess_bulk - Bulk effective sample size for the variability (v) parameter. \item v_ess_tail - Tail effective sample size for the variability (v) parameter. } - Note: pH0 and FDR columns are not computed by \code{sccomp_remove_outliers()}. Run \code{sccomp_test()} on the result to obtain hypothesis-test statistics. The function also attaches several attributes to the result: From 01adf1eabb2b9d81996f0bf37e067656531118e1 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 12:33:07 +0930 Subject: [PATCH 26/68] Refactor tests for parameter incorporation in Stan models Update the test suite for `incorporate_parameters_into_fit_object` and `incorporate_parameters_into_sccomp_object` to improve error handling and ensure parameters remain accessible after CSV file deletion. Introduce a shared function for estimating draws, enhancing test clarity and maintainability. Add tests for handling models without random effects and ensure proper error messaging for invalid inputs, reinforcing robustness in parameter management. --- tests/testthat/test-incorporate-parameters.R | 187 +++++++++++++------ 1 file changed, 130 insertions(+), 57 deletions(-) diff --git a/tests/testthat/test-incorporate-parameters.R b/tests/testthat/test-incorporate-parameters.R index f04902d4..092446c5 100644 --- a/tests/testthat/test-incorporate-parameters.R +++ b/tests/testthat/test-incorporate-parameters.R @@ -2,18 +2,10 @@ library(dplyr) library(tidyr) library(sccomp) -test_that("incorporate_parameters_into_fit_object loads all parameters", { - skip_cmdstan() - - # Load test data - data("counts_obj") - - # Create a test output directory - test_output_dir <- tempfile("sccomp_test_draws_") - dir.create(test_output_dir) - - # Run sccomp_estimate with portable = FALSE to keep CSV files temporarily - result <- counts_obj |> +# Shared fast estimate for draw-file / portability checks (one factor, pathfinder). +estimate_for_draw_tests <- function(output_directory, portable) { + data("counts_obj", package = "sccomp", envir = environment()) + counts_obj |> sccomp_estimate( formula_composition = ~ type, formula_variability = ~ 1, @@ -24,29 +16,55 @@ test_that("incorporate_parameters_into_fit_object loads all parameters", { inference_method = "pathfinder", max_sampling_iterations = 500, verbose = FALSE, - output_directory = test_output_dir, - portable = FALSE # Keep files to test manual incorporation + output_directory = output_directory, + portable = portable ) - - # Get the fit object +} + +test_that("non-portable estimate: deleting Stan output files before sccomp_test() errors without incorporation", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_draws_no_incorp_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_draw_tests(test_output_dir, portable = FALSE) fit <- attr(result, "fit") - - # Check that CSV files exist + + paths <- fit$output_files(include_failed = TRUE) + paths <- paths[file.exists(paths)] + expect_gt(length(paths), 0L, label = "Stan output files on disk") + + ok <- file.remove(paths) + expect_true(all(ok), label = "removing Stan chain/output files") + expect_false(any(file.exists(paths)), label = "recorded Stan paths should not exist after deletion") + + expect_error( + sccomp_test(result), + "Stan output files for this fit are not on disk" + ) +}) + +test_that("incorporate_parameters_into_fit_object keeps draws after CSV deletion", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_draws_fit_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_draw_tests(test_output_dir, portable = FALSE) + fit <- attr(result, "fit") + csv_files <- list.files(test_output_dir, pattern = "\\.csv$", full.names = TRUE) - expect_true(length(csv_files) > 0, info = "CSV files should exist before cleanup") - - # Call the function to incorporate parameters - expect_no_error({ - sccomp:::incorporate_parameters_into_fit_object(fit) - }) - - # Verify that key parameters can be accessed after incorporation + expect_gt(length(csv_files), 0L) + + sccomp:::incorporate_parameters_into_fit_object(fit) + expect_no_error({ beta_draws <- fit$draws(variables = "beta", format = "draws_df") }) - expect_no_error({ - alpha_draws <- fit$draws(variables = "alpha", format = "draws_df") + fit$draws(variables = "alpha", format = "draws_df") }) expect_no_error({ @@ -54,37 +72,68 @@ test_that("incorporate_parameters_into_fit_object loads all parameters", { }) # Now delete the CSV files to simulate cleanup + file.remove(csv_files) - - # Verify CSV files are gone - csv_files_after <- list.files(test_output_dir, pattern = "\\.csv$", full.names = TRUE) - expect_equal(length(csv_files_after), 0, info = "CSV files should be deleted") - - # Parameters should still be accessible because they were incorporated + expect_no_error({ - beta_draws_after <- fit$draws(variables = "beta", format = "draws_df") + beta_after <- fit$draws(variables = "beta", format = "draws_df") }) - + expect_equal(beta_draws, beta_after) +}) + +test_that("incorporate_parameters_into_sccomp_object keeps draws after CSV deletion", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_draws_sccomp_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_draw_tests(test_output_dir, portable = FALSE) + result <- sccomp:::incorporate_parameters_into_sccomp_object(result) + + csv_files <- list.files(test_output_dir, pattern = "\\.csv$", full.names = TRUE) + expect_gt(length(csv_files), 0L) + expect_no_error({ - alpha_draws_after <- fit$draws(variables = "alpha", format = "draws_df") + beta_draws <- attr(result, "fit")$draws(variables = "beta", format = "draws_df") + }) + + file.remove(csv_files) + + expect_no_error({ + beta_after <- attr(result, "fit")$draws(variables = "beta", format = "draws_df") + }) + expect_equal(beta_draws, beta_after) +}) + +test_that("portable = TRUE keeps draws available after package removes draw CSV files", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_draws_portable_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_draw_tests(test_output_dir, portable = TRUE) + fit <- attr(result, "fit") + + remaining <- fit$output_files(include_failed = TRUE) + remaining <- remaining[file.exists(remaining)] + expect_equal(length(remaining), 0L, label = "Stan output files still on disk after portable cleanup") + + expect_no_error({ + fit$draws(variables = "beta", format = "draws_df") }) - - # Verify the draws are the same before and after CSV deletion - expect_equal(beta_draws, beta_draws_after) - - # Clean up test directory - unlink(test_output_dir, recursive = TRUE) }) test_that("incorporate_parameters_into_fit_object handles models without random effects", { skip_cmdstan() - + data("counts_obj") - - test_output_dir <- tempfile("sccomp_test_draws_") + + test_output_dir <- tempfile("sccomp_test_draws_intercept_") dir.create(test_output_dir) - - # Run a simple model without random effects + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + result <- counts_obj |> sccomp_estimate( formula_composition = ~ 1, @@ -99,23 +148,47 @@ test_that("incorporate_parameters_into_fit_object handles models without random output_directory = test_output_dir, portable = FALSE ) - + fit <- attr(result, "fit") - - # Should handle models without random effects gracefully + expect_no_error({ sccomp:::incorporate_parameters_into_fit_object(fit) }) - - # Basic parameters should still be accessible + expect_no_error({ fit$draws(variables = "beta", format = "draws_df") }) - expect_no_error({ fit$draws(variables = "alpha", format = "draws_df") }) - - # Clean up - unlink(test_output_dir, recursive = TRUE) +}) + +test_that("incorporate_parameters_into_sccomp_object errors without fit attribute", { + bad <- tibble::tibble(x = 1L) + expect_error( + sccomp:::incorporate_parameters_into_sccomp_object(bad), + "expected a \"fit\" attribute on the sccomp object" + ) +}) + +test_that("incorporate_parameters_into_sccomp_object forwards fit and writes back attribute", { + fit_in <- list(seed = 42L) + obj <- tibble::tibble(x = 1L) + attr(obj, "fit") <- fit_in + class(obj) <- c("sccomp_tbl", class(obj)) + + local_mocked_bindings( + incorporate_parameters_into_fit_object = function(fit) { + expect_identical(fit, fit_in) + fit$incorporated <- TRUE + fit + }, + .package = "sccomp" + ) + + out <- sccomp:::incorporate_parameters_into_sccomp_object(obj) + + expect_s3_class(out, "sccomp_tbl") + expect_true(attr(out, "fit")$incorporated) + expect_identical(attr(out, "fit")$seed, 42L) }) From a178f39045d44b688b692ebcfb29336473a70ead Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 13:18:07 +0930 Subject: [PATCH 27/68] Refactor sccomp_estimate and sccomp_remove_outliers for improved parameter handling Update the `portable` parameter documentation to clarify its functionality regarding draw file management. Refactor file deletion logic to use `file.remove` instead of `unlink`, enhancing clarity and error handling. Adjust parameter lists in both functions to include `prec_coeff` and streamline the handling of Stan output files. Introduce new tests for HMC workflows to ensure robustness in parameter accessibility after file deletion, reinforcing the integrity of the estimation process. --- R/sccomp_estimate.R | 28 ++++------ R/sccomp_remove_outliers.R | 9 ++-- tests/testthat/test-incorporate-parameters.R | 55 +++++++++++++++++--- 3 files changed, 65 insertions(+), 27 deletions(-) diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index ae96ad24..d0e25fd5 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -51,24 +51,16 @@ #' @param cache_stan_model A character string specifying the cache directory for compiled Stan models. #' The sccomp version will be automatically appended to ensure version isolation. #' Default is `sccomp_stan_models_cache_dir` which points to `~/.sccomp_models`. -#' @param portable Logical, whether to keep the result **self-contained** after fitting. Default `TRUE`. -#' \describe{ -#' \item{`TRUE`}{After fitting, sccomp calls `incorporate_parameters_into_sccomp_object()` to pull needed draws into the fit, -#' then **deletes** the Stan CSV files under `output_directory` on **this** machine (only files that still exist are removed).} -#' \item{`FALSE`}{sccomp **does not** delete draw files; CSVs stay on disk. The fit object stores **absolute paths** to those files. -#' You must keep that directory alongside the object (or stay on the same filesystem) if you later need variables that -#' were never loaded in this session.} -#' } -#' **Efficiency:** At `sccomp_estimate()` time sccomp only asks cmdstanr for **summaries** of `beta`, `alpha_normalised`, -#' and random-effect blocks needed for the printed table, not full `draws()` tensors for every Stan parameter. CmdStanR still -#' reads output files to compute those summaries (how much is cached in RAM is implementation-dependent). -#' **Relocating the object:** If you save the tibble and open it elsewhere without the CSV directory (or paths point to another -#' host), `attr(..., "fit")$summary()` can fail for variables that were never touched during estimate—for example the -#' table uses **`alpha_normalised`**, not raw `alpha`, so `summary("alpha[1,1]")` may try to re-read CSVs whereas -#' `summary("beta[1,1]")` may still work if that block was already loaded. Use `portable = TRUE` before archiving, or copy -#' the whole draw folder so paths resolve. -#' If you delete CSVs manually with `portable = FALSE`, call `sccomp_test()` before deletion, run `incorporate_parameters_into_sccomp_object()` first, -#' or switch to `portable = TRUE`; otherwise `sccomp_test()` errors when recorded output paths are missing unless draws were incorporated. +#' @param portable Logical, whether to keep the result portable by caching required draws in memory and removing Stan draw CSV files after fitting. +#' Default is TRUE to save disk space and move needed values into memory. Set to FALSE to keep draw CSV files on disk. +#' With `portable = FALSE`, CSVs remain for you to inspect or archive, but cmdstanr typically **still holds posterior draws in RAM** +#' after fitting and summarisation (`fit$summary()`). The printed estimate table only calls `fit$summary()` on composition +#' (`beta`, …) and variability (`alpha_normalised`, …), not on every saved parameter (e.g. `prec_sd`), yet cmdstanr still +#' exposes all saved parameters from memory once output has been read, so `fit$draws(variables = "prec_sd")` can work +#' after CSV deletion just like `beta`. Deleting CSVs does **not** reliably invalidate the fit in the same R session. +#' Call `sccomp_test()` before deleting draw files, use `portable = TRUE` (draws cached then files removed), or run +#' `incorporate_parameters_into_sccomp_object()` before deletion if you remove files manually. `sccomp_test()` stops with a +#' clear error when recorded Stan output paths are missing unless draws were incorporated for portability as above. #' @param .count **DEPRECATED**. Use `abundance` instead. #' @param approximate_posterior_inference **DEPRECATED**. Use `inference_method` instead. #' @param variational_inference **DEPRECATED**. Use `inference_method` instead. diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index 4c38f8f6..afd19458 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -504,14 +504,17 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, # Auto-cleanup draw files if requested if (portable) { - estimate_tibble <- incorporate_parameters_into_sccomp_object(estimate_tibble) if (dir.exists(output_directory)) { files_deleted <- attr(estimate_tibble, "fit")$output_files(include_failed = TRUE) + files_deleted <- files_deleted[file.exists(files_deleted)] if (length(files_deleted) > 0) { - suppressWarnings(unlink(files_deleted, force = TRUE)) - message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", length(files_deleted), output_directory)) + file.remove(files_deleted) + if (verbose) { + message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", + length(files_deleted), output_directory)) + } } } } diff --git a/tests/testthat/test-incorporate-parameters.R b/tests/testthat/test-incorporate-parameters.R index 092446c5..9140f69c 100644 --- a/tests/testthat/test-incorporate-parameters.R +++ b/tests/testthat/test-incorporate-parameters.R @@ -21,6 +21,29 @@ estimate_for_draw_tests <- function(output_directory, portable) { ) } +# Minimal HMC for tests that should reflect typical `inference_method = "hmc"` workflows (CmdStanMCMC, +# chain CSVs). Small warmup/sampling via fit_model args forwarded through `...`. +estimate_for_draw_tests_hmc_minimal <- function(output_directory, portable = FALSE) { + data("counts_obj", package = "sccomp", envir = environment()) + counts_obj |> + sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ 1, + sample = "sample", + cell_group = "cell_group", + abundance = "count", + cores = 1, + inference_method = "hmc", + chains = 1, + warmup_samples = 40, + output_samples = 80, + max_sampling_iterations = 500, + verbose = FALSE, + output_directory = output_directory, + portable = portable + ) +} + test_that("non-portable estimate: deleting Stan output files before sccomp_test() errors without incorporation", { skip_cmdstan() @@ -45,6 +68,32 @@ test_that("non-portable estimate: deleting Stan output files before sccomp_test( ) }) +# With HMC, `sccomp_summarise_posterior_for_estimate()` only touches `fit$summary()` for `beta` / +# `alpha_normalised` (etc.); `prec_sd` is not loaded then. After deleting chain CSVs, `prec_sd` +# must be read from disk and fails (same class of error as copying an RDS to another machine +# without the draw files). + +test_that("non-portable (HMC): prec_sd summary errors after CSV deletion", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_prec_sd_disk_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_draw_tests_hmc_minimal(test_output_dir, portable = FALSE) + fit <- attr(result, "fit") + + paths <- fit$output_files(include_failed = TRUE) + paths <- paths[file.exists(paths)] + expect_gt(length(paths), 0L, label = "Stan output files on disk") + expect_true(all(file.remove(paths)), label = "removing Stan CSV files") + + expect_error( + fit$summary("prec_sd"), + "File does not exist" + ) +}) + test_that("incorporate_parameters_into_fit_object keeps draws after CSV deletion", { skip_cmdstan() @@ -66,12 +115,6 @@ test_that("incorporate_parameters_into_fit_object keeps draws after CSV deletion expect_no_error({ fit$draws(variables = "alpha", format = "draws_df") }) - - expect_no_error({ - prec_intercept_draws <- fit$draws(variables = "prec_intercept_1", format = "draws_df") - }) - - # Now delete the CSV files to simulate cleanup file.remove(csv_files) From 52a459b242b9b43d95d277ef2547ecbd6a6d6126 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 13:18:30 +0930 Subject: [PATCH 28/68] Refactor file deletion logic in sccomp_estimate for improved error handling Update the file deletion process to use `file.remove` and ensure only existing files are targeted for removal. Enhance the verbosity of the cleanup message for better user feedback. Adjust parameter lists in `sccomp_glm_data_frame_counts` to include `prec_coeff`, streamlining the handling of Stan output files. --- R/sccomp_estimate.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index d0e25fd5..a5dfb265 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -716,9 +716,13 @@ sccomp_estimate.data.frame <- function(.data, if (dir.exists(output_directory)) { files_deleted <- attr(res, "fit")$output_files(include_failed = TRUE) + files_deleted <- files_deleted[file.exists(files_deleted)] if (length(files_deleted) > 0) { - suppressWarnings(unlink(files_deleted, force = TRUE)) - message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", length(files_deleted), output_directory)) + file.remove(files_deleted) + if (verbose) { + message(sprintf("sccomp says: auto-cleanup removed %d draw files from '%s'", + length(files_deleted), output_directory)) + } } } } From 4d6d429923e9563a0c24c07d61011b2dabad6d1b Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 16:04:52 +0930 Subject: [PATCH 29/68] Update version to 2.1.31 and refine alpha normalization handling Bump package version in DESCRIPTION. Update .Rbuildignore to exclude test script. Refactor alpha normalization logic in various functions to compute values in R instead of Stan, enhancing clarity and maintainability. Introduce new tests for alpha normalization to ensure correctness in both unimodal and bimodal scenarios, reinforcing the integrity of the estimation process. --- .Rbuildignore | 1 + DESCRIPTION | 2 +- R/sccomp_estimate.R | 4 +- R/sccomp_plot_intervals.R | 2 +- R/sccomp_remove_outliers.R | 4 +- R/sccomp_test.R | 192 +++++++++++++----- R/utilities.R | 190 ++++++++++++++++- inst/stan/glm_multi_beta_binomial.stan | 8 - tests/testthat/test-alpha-normalised-r-side.R | 153 ++++++++++++++ 9 files changed, 486 insertions(+), 70 deletions(-) create mode 100644 tests/testthat/test-alpha-normalised-r-side.R diff --git a/.Rbuildignore b/.Rbuildignore index 75b92fa8..777dfec6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,4 @@ +^run_tests\.R$ ^\.github$ ^LICENSE\.md$ ^README\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index c895b274..c9ced17c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: sccomp Type: Package Title: Differential Composition and Variability Analysis for Single-Cell Data -Version: 2.1.30 +Version: 2.1.31 Date: 2026-04-05 Authors@R: c(person("Stefano", "Mangiola", email = "stefano.mangiola@unimelb.edu.au", role = c("aut", "cre")), person("Alexandra J.", "Roth-Schulze", role = "aut"), person("Marie", "Trussart", role = "aut"), person("Enrique", "Zozaya-Valdés", role = "aut"), person("Mengyao", "Ma", role = "aut"), person("Zijie", "Gao", role = "aut"), person("Alan F.", "Rubin", role = "aut"), person("Terence P.", "Speed", role = "aut"), person("Heejung", "Shim", role = "aut"), person("Anthony T.", "Papenfuss", role = "aut")) Description: Comprehensive R package for differential composition and variability analysis in single-cell RNA sequencing, CyTOF, and microbiome data. Provides robust Bayesian modeling with outlier detection, random effects, and advanced statistical methods for cell type proportion analysis. Features include probabilistic outlier identification, mixed-effect modeling, differential variability testing, and comprehensive visualization tools. Perfect for cancer research, immunology, developmental biology, and single-cell genomics applications. diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index a5dfb265..871728ae 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -55,7 +55,7 @@ #' Default is TRUE to save disk space and move needed values into memory. Set to FALSE to keep draw CSV files on disk. #' With `portable = FALSE`, CSVs remain for you to inspect or archive, but cmdstanr typically **still holds posterior draws in RAM** #' after fitting and summarisation (`fit$summary()`). The printed estimate table only calls `fit$summary()` on composition -#' (`beta`, …) and variability (`alpha_normalised`, …), not on every saved parameter (e.g. `prec_sd`), yet cmdstanr still +#' (`beta`, …) and variability (`alpha`, …), not on every saved parameter (e.g. `prec_sd`), yet cmdstanr still #' exposes all saved parameters from memory once output has been read, so `fit$draws(variables = "prec_sd")` can work #' after CSV deletion just like `beta`. Deleting CSVs does **not** reliably invalidate the fit in the same R session. #' Call `sccomp_test()` before deleting draw files, use `portable = TRUE` (draws cached then files removed), or run @@ -1056,7 +1056,7 @@ sccomp_glm_data_frame_counts = function(.data, pars = c( "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", - "prec_sd", "alpha_normalised", + "prec_sd", "random_effect", "random_effect_2", "random_effect_sigma", "random_effect_sigma_2", "log_lik" diff --git a/R/sccomp_plot_intervals.R b/R/sccomp_plot_intervals.R index 84ebc6b2..076b3cab 100644 --- a/R/sccomp_plot_intervals.R +++ b/R/sccomp_plot_intervals.R @@ -322,7 +322,7 @@ sccomp_plot_intervals_2D <- function( cat("\n") } - # v_effect already comes from alpha_normalised (adjusted in Stan) + # v_effect already comes from alpha_normalised (computed in R from draws) # "raw" panel: ADD BACK entanglement to show raw alpha # "adjusted" panel: USE v_effect AS-IS diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index afd19458..84b53e6d 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -332,7 +332,7 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, pars = c( "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", - "alpha_normalised", "random_effect", "random_effect_2" + "random_effect", "random_effect_2" ), sig_figs = sig_figs, cache_stan_model = cache_stan_model, @@ -468,7 +468,7 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, pars = c( "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", - "alpha_normalised", "random_effect", "random_effect_2", "log_lik" + "random_effect", "random_effect_2", "log_lik" ), cache_stan_model = cache_stan_model, ... diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 6da53c8a..c95ea75b 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -189,50 +189,37 @@ sccomp_test.sccomp_tbl = function(.data, #' @noRd summarise_stan_matrix_for_estimate <- function( fit, - par_name, - design_colnames, - cell_group_levels, + model_input, + stan_parameter, + parameter_names, probs, - cell_group_colname, - prefix, - full_design_colnames = NULL, - full_block_parameter = NULL) { - if (is.null(full_design_colnames)) { - full_design_colnames <- design_colnames - } - # Translate design-matrix column names to Stan matrix column indices (C). - C_idx <- match(design_colnames, full_design_colnames) - if (anyNA(C_idx)) { - stop( - "sccomp says: each name in design_colnames must appear in full_design_colnames.", - call. = FALSE - ) - } - if (is.null(par_name)) { - summ <- summary_to_tibble(fit, full_block_parameter, "C", "M", probs = probs) - } else { - # Subset request uses explicit indexed Stan variable names for selected C across all M. - n_M <- length(cell_group_levels) - g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) - variable_names <- sprintf("%s[%d,%d]", par_name, g$C, g$M) - summ <- summary_to_tibble(fit, variable_names, "C", "M", probs = probs) - } - qcols <- names(summ)[grepl("%$", names(summ))] - q_bounds <- qcols |> + prefix) { + # Map Stan matrix column index M back to user-facing cell-group labels. + cell_group_levels <- colnames(model_input$y) + + # Query Stan summaries for this parameter family (beta/random effects). + summ <- summary_to_tibble(fit, stan_parameter, "C", "M", probs = probs) + + # Identify lower/upper quantile column names from the summary output. + quantile_columns <- names(summ)[grepl("%$", names(summ))] + ordered_quantile_columns <- quantile_columns |> tibble::enframe(value = "qcol") |> dplyr::mutate(pct = as.numeric(gsub("%$", "", qcol, perl = TRUE))) |> dplyr::arrange(pct) |> dplyr::pull(qcol) - qlo <- q_bounds[[1]] - qhi <- q_bounds[[2]] + lower_quantile_column <- ordered_quantile_columns[[1]] + upper_quantile_column <- ordered_quantile_columns[[2]] + # Provide a stable mapping from C indices to design-matrix parameter names. par_by_C <- - tibble::tibble(C = C_idx, parameter = design_colnames) |> + tibble::tibble(C = seq_along(parameter_names), parameter = parameter_names) |> dplyr::distinct() + # Attach parameter labels to each C/M summary row. joined <- summ |> dplyr::left_join(par_by_C, by = "C") + # Keep output column names configurable for c_/v_ style reuse. lower_col <- paste0(prefix, "lower") effect_col <- paste0(prefix, "effect") upper_col <- paste0(prefix, "upper") @@ -240,14 +227,97 @@ summarise_stan_matrix_for_estimate <- function( ess_bulk_col <- paste0(prefix, "ess_bulk") ess_tail_col <- paste0(prefix, "ess_tail") + # Return compact, user-facing summary table with diagnostics. joined |> dplyr::transmute( - !!rlang::sym(cell_group_colname) := cell_group_levels[M], + cell_group = cell_group_levels[M], M, parameter, - !!lower_col := .data[[qlo]], + !!lower_col := .data[[lower_quantile_column]], !!effect_col := mean, - !!upper_col := .data[[qhi]], + !!upper_col := .data[[upper_quantile_column]], + !!rhat_col := rhat, + !!ess_bulk_col := ess_bulk, + !!ess_tail_col := ess_tail + ) +} + +#' Build variability summaries from R-side alpha normalisation draws. +#' +#' This mirrors `summarise_stan_matrix_for_estimate()` but computes quantiles for +#' alpha_normalised from derived draws, while borrowing convergence diagnostics +#' (rhat/ESS) from the corresponding `alpha` elements. +#' +#' @keywords internal +#' @noRd +summarise_alpha_normalised_for_estimate <- function( + fit, + model_input, + design_colnames, + probs, + cell_group_colname, + prefix) { + # Map Stan matrix column index M back to user-facing cell-group labels. + cell_group_levels <- colnames(model_input$y) + + # Match variability design columns to Stan C indices. + C_idx <- match(design_colnames, colnames(model_input$XA)) + if (anyNA(C_idx)) { + stop( + "sccomp says: each variability design column must appear in model_input$XA.", + call. = FALSE + ) + } + + n_M <- length(cell_group_levels) + g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) + alpha_subset <- sprintf("alpha[%d,%d]", g$C, g$M) + + # Compute alpha_normalised summaries from derived R-side draws. + draws_summary <- compute_alpha_normalised_draws( + fit = fit, + model_input = model_input, + alpha_variable_subset = alpha_subset + ) |> + dplyr::group_by(C, M) |> + dplyr::summarise( + effect = mean(.value), + lower_quantile = stats::quantile(.value, probs = probs[[1]], na.rm = TRUE), + upper_quantile = stats::quantile(.value, probs = probs[[2]], na.rm = TRUE), + .groups = "drop" + ) + + # Pull diagnostics from the corresponding base alpha parameters in Stan. + alpha_diagnostics <- summary_to_tibble(fit, alpha_subset, "C", "M", probs = probs) |> + dplyr::select(C, M, rhat, ess_bulk, ess_tail) |> + dplyr::distinct() + + # Combine derived summaries, diagnostics, and design parameter labels. + joined <- draws_summary |> + dplyr::left_join(alpha_diagnostics, by = c("C", "M")) |> + dplyr::left_join( + tibble::tibble(C = C_idx, parameter = design_colnames) |> + dplyr::distinct(), + by = "C" + ) + + # Keep output column names configurable for v_ style summaries. + lower_col <- paste0(prefix, "lower") + effect_col <- paste0(prefix, "effect") + upper_col <- paste0(prefix, "upper") + rhat_col <- paste0(prefix, "rhat") + ess_bulk_col <- paste0(prefix, "ess_bulk") + ess_tail_col <- paste0(prefix, "ess_tail") + + # Return compact, user-facing summary table with diagnostics. + joined |> + dplyr::transmute( + !!rlang::sym(cell_group_colname) := cell_group_levels[M], + M, + parameter, + !!lower_col := lower_quantile, + !!effect_col := effect, + !!upper_col := upper_quantile, !!rhat_col := rhat, !!ess_bulk_col := ess_bulk, !!ess_tail_col := ess_tail @@ -267,20 +337,26 @@ sccomp_summarise_posterior_for_estimate <- function( fp <- percent_false_positive / 100 probs <- c(fp / 2, 1 - fp / 2) - cell_group_levels <- model_input$y |> colnames() - abundance_parts <- list( summarise_stan_matrix_for_estimate( - fit, NULL, colnames(model_input$X), cell_group_levels, - probs, cg, "c_", full_block_parameter = "beta" + fit = fit, + model_input = model_input, + stan_parameter = "beta", + parameter_names = colnames(model_input$X), + probs = probs, + prefix = "c_" ) ) if (model_input$n_random_eff > 0) { abundance_parts <- c( abundance_parts, list(summarise_stan_matrix_for_estimate( - fit, NULL, colnames(model_input$X_random_effect), cell_group_levels, - probs, cg, "c_", full_block_parameter = "random_effect" + fit = fit, + model_input = model_input, + stan_parameter = "random_effect", + parameter_names = colnames(model_input$X_random_effect), + probs = probs, + prefix = "c_" )) ) } @@ -288,17 +364,26 @@ sccomp_summarise_posterior_for_estimate <- function( abundance_parts <- c( abundance_parts, list(summarise_stan_matrix_for_estimate( - fit, NULL, colnames(model_input$X_random_effect_2), cell_group_levels, - probs, cg, "c_", full_block_parameter = "random_effect_2" + fit = fit, + model_input = model_input, + stan_parameter = "random_effect_2", + parameter_names = colnames(model_input$X_random_effect_2), + probs = probs, + prefix = "c_" )) ) } - abundance <- dplyr::bind_rows(abundance_parts) + abundance <- dplyr::bind_rows(abundance_parts) |> + dplyr::rename(!!cg := cell_group) - variability <- summarise_stan_matrix_for_estimate( - fit, NULL, colnames(model_input$XA), cell_group_levels, - probs, cg, "v_", full_block_parameter = "alpha_normalised" + variability <- summarise_alpha_normalised_for_estimate( + fit = fit, + model_input = model_input, + design_colnames = colnames(model_input$XA), + probs = probs, + cell_group_colname = cg, + prefix = "v_" ) |> dplyr::mutate( v_lower = -v_lower, @@ -721,14 +806,15 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset n_M <- ncol(.data |> attr("model_input") %$% y) C_idx <- match(needed, variability_factor_of_interest) g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) - alpha_variable_subset <- sprintf("alpha_normalised[%d,%d]", g$C, g$M) + alpha_variable_subset <- sprintf("alpha[%d,%d]", g$C, g$M) } draws = - - .data |> - attr("fit") %>% - draws_to_tibble_x_y(if (is.null(alpha_variable_subset)) "alpha_normalised" else alpha_variable_subset, "C", "M") |> + compute_alpha_normalised_draws( + fit = .data |> attr("fit"), + model_input = .data |> attr("model_input"), + alpha_variable_subset = alpha_variable_subset + ) |> # We want variability, not concentration mutate(.value = -.value) @@ -777,7 +863,7 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset convergence_df = .data |> attr("fit") |> - summary_to_tibble("alpha_normalised", "C", "M") |> + summary_to_tibble("alpha", "C", "M") |> # Add cell name left_join( diff --git a/R/utilities.R b/R/utilities.R index d2a3f491..5e933c16 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -136,7 +136,6 @@ incorporate_parameters_into_fit_object = function(fit) { # Transformed parameters "beta", # Generated quantities - "alpha_normalised", "log_lik" ) @@ -380,7 +379,7 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { # ".variable" = character()), values_to = ".value" ) %>% - tidyr::extract(parameter, c(".chain", ".variable", x, y), "([1-9]+)?\\.?([a-zA-Z0-9_\\.]+)\\[([0-9]+),([0-9]+)") |> + tidyr::extract(parameter, c(".variable", x, y), "(?:[1-9]+\\.)?([a-zA-Z0-9_\\.]+)\\[([0-9]+),([0-9]+)") |> # Warning message: # Expected 5 pieces. Additional pieces discarded @@ -394,11 +393,196 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { group_by(.variable, !!as.symbol(x), !!as.symbol(y)) %>% mutate(.draw = seq_len(n())) %>% ungroup() %>% - select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw ,.variable , .value) %>% + select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw, .variable, .value) %>% filter(.variable == base_parameter) } +#' draws_to_tibble_x +#' +#' @param fit A fit object +#' @param par A character vector. The parameters to extract. +#' @param x A character. The index. +#' +#' @keywords internal +#' @noRd +draws_to_tibble_x = function(fit, par, x) { + + # Define the variables as NULL to avoid CRAN NOTES + .variable <- NULL + .chain <- NULL + .iteration <- NULL + .draw <- NULL + .value <- NULL + + base_parameter <- sub("\\[.*$", "", par[[1]]) + + draws_df <- fit$draws(variables = par, format = "draws_df") + value_columns <- setdiff(colnames(draws_df), c(".chain", ".iteration", ".draw")) + + draws_df %>% + mutate(.iteration = seq_len(n())) %>% + pivot_longer( + names_to = "parameter", + cols = tidyselect::all_of(value_columns), + values_to = ".value" + ) %>% + tidyr::extract(parameter, c(".variable", x), "(?:[1-9]+\\.)?([a-zA-Z0-9_\\.]+)(?:\\[([0-9]+))?") |> + suppressWarnings() %>% + mutate( + !!as.symbol(x) := as.integer(!!as.symbol(x)) + ) %>% + arrange(.variable, !!as.symbol(x), .chain) %>% + group_by(.variable, !!as.symbol(x)) %>% + mutate(.draw = seq_len(n())) %>% + ungroup() %>% + select(!!as.symbol(x), .chain, .iteration, .draw, .variable, .value) %>% + filter(.variable == base_parameter) +} + +#' Compute alpha_normalised draws in R +#' +#' @param fit A cmdstanr fit object. +#' @param model_input The model input list attached to sccomp results. +#' @param alpha_variable_subset Optional character vector like +#' `alpha[a,m]` (or legacy `alpha_normalised[a,m]`) to limit extraction. +#' +#' @return A tibble with columns `C`, `M`, `.chain`, `.iteration`, `.draw`, +#' `.variable`, `.value`. +#' +#' @keywords internal +#' @noRd +compute_alpha_normalised_draws = function(fit, model_input, alpha_variable_subset = NULL) { + + # Define the variables as NULL to avoid CRAN NOTES + C <- NULL + M <- NULL + .chain <- NULL + .iteration <- NULL + .draw <- NULL + .variable <- NULL + .value <- NULL + beta <- NULL + alpha <- NULL + prec_slope_1 <- NULL + prec_slope_2 <- NULL + prec_intercept_1 <- NULL + prec_intercept_2 <- NULL + prec_sd <- NULL + mix_p <- NULL + C_comp <- NULL + log_1 <- NULL + log_2 <- NULL + weight_1 <- NULL + slope_effective <- NULL + max_log <- NULL + + variability_to_composition_map <- model_input$variability_to_composition_map + if (is.null(variability_to_composition_map)) { + stop("sccomp says: missing `variability_to_composition_map` in model metadata.") + } + + bimodal_flag <- isTRUE(as.logical(model_input$bimodal_mean_variability_association)) + + if (is.null(alpha_variable_subset)) { + # Fast path: use all variability coefficients and all cell groups. + alpha_draws <- draws_to_tibble_x_y(fit, "alpha", "C", "M") + } else { + # Subset path: trust upstream subset names as-is. + alpha_draws <- draws_to_tibble_x_y(fit, alpha_variable_subset, "C", "M") + } + + needed_C <- sort(unique(alpha_draws$C)) + needed_C_comp <- sort(unique(variability_to_composition_map[needed_C])) + n_M <- ncol(model_input$y) + + # Map variability coefficients (C in Xa) to composition coefficients (C in X), + # then load beta for all M so we can apply draw-wise correction. + beta_vars <- as.vector( + outer( + needed_C_comp, + seq_len(n_M), + FUN = function(c_idx, m_idx) sprintf("beta[%d,%d]", c_idx, m_idx) + ) + ) + + beta_draws <- draws_to_tibble_x_y(fit, beta_vars, "C", "M") |> + rename(C_comp = C, beta = .value) |> + select(C_comp, M, .chain, .iteration, beta) + + alpha_draws <- alpha_draws |> + rename(alpha = .value) |> + mutate(C_comp = variability_to_composition_map[C]) |> + left_join(beta_draws, by = c("C_comp", "M", ".chain", ".iteration")) + + + slope_1_vars <- sprintf("prec_slope_1[%d]", needed_C) + slope_1_draws <- draws_to_tibble_x(fit, slope_1_vars, "C") |> + transmute(C, .chain, .iteration, prec_slope_1 = .value) + + alpha_draws <- alpha_draws |> + left_join(slope_1_draws, by = c("C", ".chain", ".iteration")) + + if (!bimodal_flag) { + # Unimodal model: the effective slope is the single regression slope. + alpha_draws <- alpha_draws |> + mutate(slope_effective = prec_slope_1) + } else { + slope_2_vars <- sprintf("prec_slope_2[%d]", needed_C) + intercept_1_vars <- sprintf("prec_intercept_1[%d]", needed_C) + intercept_2_vars <- sprintf("prec_intercept_2[%d]", needed_C) + prec_sd_vars <- sprintf("prec_sd[%d]", needed_C) + + slope_2_draws <- draws_to_tibble_x(fit, slope_2_vars, "C") |> + transmute(C, .chain, .iteration, prec_slope_2 = .value) + intercept_1_draws <- draws_to_tibble_x(fit, intercept_1_vars, "C") |> + transmute(C, .chain, .iteration, prec_intercept_1 = .value) + intercept_2_draws <- draws_to_tibble_x(fit, intercept_2_vars, "C") |> + transmute(C, .chain, .iteration, prec_intercept_2 = .value) + prec_sd_draws <- draws_to_tibble_x(fit, prec_sd_vars, "C") |> + transmute(C, .chain, .iteration, prec_sd = .value) + + mix_p_draws <- fit$draws(variables = "mix_p", format = "draws_df") |> + transmute( + .chain = as.integer(.chain), + .iteration = as.integer(.iteration), + mix_p = mix_p + ) + + alpha_draws <- alpha_draws |> + left_join(slope_2_draws, by = c("C", ".chain", ".iteration")) |> + left_join(intercept_1_draws, by = c("C", ".chain", ".iteration")) |> + left_join(intercept_2_draws, by = c("C", ".chain", ".iteration")) |> + left_join(prec_sd_draws, by = c("C", ".chain", ".iteration")) |> + left_join(mix_p_draws, by = c(".chain", ".iteration")) |> + mutate( + # Soft assignment: compute draw-specific responsibility for component 1 + # from mixture log-densities and use it to blend slopes. + # Here log_1/log_2 are: + # log p(z = k) + log p(alpha | z = k, draw params) + # where p(alpha | z = k, ...) is Student-t(df = 3) with + # location beta * prec_slope_k + prec_intercept_k and scale prec_sd. + # The -log(prec_sd) term applies the scale correction. + log_1 = log(mix_p) + + stats::dt((alpha - (beta * prec_slope_1 + prec_intercept_1)) / prec_sd, df = 3, log = TRUE) - + log(prec_sd), + log_2 = log1p(-mix_p) + + stats::dt((alpha - (beta * prec_slope_2 + prec_intercept_2)) / prec_sd, df = 3, log = TRUE) - + log(prec_sd), + max_log = pmax(log_1, log_2), + weight_1 = exp(log_1 - max_log) / (exp(log_1 - max_log) + exp(log_2 - max_log)), + slope_effective = weight_1 * prec_slope_1 + (1 - weight_1) * prec_slope_2 + ) + } + + alpha_draws |> + mutate( + .value = alpha - (beta * slope_effective), + .variable = "alpha_normalised" + ) |> + select(C, M, .chain, .iteration, .draw, .variable, .value) +} + #' @importFrom tidyr separate #' @importFrom purrr when diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index e47d749e..b2b26e32 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -592,14 +592,6 @@ model{ } } generated quantities { - matrix[A, M] alpha_normalised = alpha; - -// Entanglement adjustment - - for(a in 1:A) - alpha_normalised[a] = alpha[a] - (beta[variability_to_composition_map[a]] * prec_slope_1[a]); - - // LOO vector[TNS] log_lik = rep_vector(0, TNS); diff --git a/tests/testthat/test-alpha-normalised-r-side.R b/tests/testthat/test-alpha-normalised-r-side.R new file mode 100644 index 00000000..51510836 --- /dev/null +++ b/tests/testthat/test-alpha-normalised-r-side.R @@ -0,0 +1,153 @@ +library(dplyr) +library(sccomp) + +estimate_for_alpha_normalisation_tests <- function(output_directory, bimodal = FALSE) { + data("counts_obj", package = "sccomp", envir = environment()) + cache_dir <- file.path(output_directory, "stan_cache") + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + + counts_obj |> + sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ 1, + sample = "sample", + cell_group = "cell_group", + abundance = "count", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = 500, + output_samples = 200, + verbose = FALSE, + output_directory = output_directory, + portable = FALSE, + cache_stan_model = cache_dir, + bimodal_mean_variability_association = bimodal + ) +} + +test_that("alpha_normalised is computed in R for unimodal fits", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_alpha_norm_unimodal_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_alpha_normalisation_tests(test_output_dir, bimodal = FALSE) + fit <- attr(result, "fit") + model_input <- attr(result, "model_input") + + # Use one variability coefficient across all cell groups to keep the test fast. + n_m <- ncol(model_input$y) + alpha_subset <- sprintf("alpha[%d,%d]", 1L, seq_len(n_m)) + + calc <- sccomp:::compute_alpha_normalised_draws( + fit = fit, + model_input = model_input, + alpha_variable_subset = alpha_subset + ) |> + arrange(C, M, .chain, .iteration) |> + select(C, M, .chain, .iteration, calc = .value) + + alpha <- sccomp:::draws_to_tibble_x_y(fit, alpha_subset, "C", "M") |> + rename(alpha = .value) + beta <- sccomp:::draws_to_tibble_x_y(fit, sprintf("beta[%d,%d]", 1L, seq_len(n_m)), "C", "M") |> + rename(C_comp = C, beta = .value) + slope_1 <- sccomp:::draws_to_tibble_x(fit, "prec_slope_1", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_slope_1 = .value) + + expected <- alpha |> + mutate(C_comp = model_input$variability_to_composition_map[C]) |> + left_join(beta, by = c("C_comp", "M", ".chain", ".iteration")) |> + left_join(slope_1, by = c("C", ".chain", ".iteration")) |> + mutate(expected = alpha - (beta * prec_slope_1)) |> + arrange(C, M, .chain, .iteration) |> + select(C, M, .chain, .iteration, expected) + + joined <- left_join(calc, expected, by = c("C", "M", ".chain", ".iteration")) + + expect_false(any(is.na(joined$calc))) + expect_false(any(is.na(joined$expected))) + expect_equal(joined$calc, joined$expected, tolerance = 1e-8) +}) + +test_that("alpha_normalised soft correction matches manual bimodal computation", { + skip_cmdstan() + + test_output_dir <- tempfile("sccomp_test_alpha_norm_bimodal_") + dir.create(test_output_dir) + on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) + + result <- estimate_for_alpha_normalisation_tests(test_output_dir, bimodal = TRUE) + fit <- attr(result, "fit") + model_input <- attr(result, "model_input") + + # Use one variability coefficient across all cell groups to keep the test fast. + n_m <- ncol(model_input$y) + alpha_subset <- sprintf("alpha[%d,%d]", 1L, seq_len(n_m)) + + calc <- sccomp:::compute_alpha_normalised_draws( + fit = fit, + model_input = model_input, + alpha_variable_subset = alpha_subset + ) |> + arrange(C, M, .chain, .iteration) |> + select(C, M, .chain, .iteration, calc = .value) + + alpha <- sccomp:::draws_to_tibble_x_y(fit, alpha_subset, "C", "M") |> + rename(alpha = .value) + beta <- sccomp:::draws_to_tibble_x_y(fit, sprintf("beta[%d,%d]", 1L, seq_len(n_m)), "C", "M") |> + rename(C_comp = C, beta = .value) + slope_1 <- sccomp:::draws_to_tibble_x(fit, "prec_slope_1", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_slope_1 = .value) + slope_2 <- sccomp:::draws_to_tibble_x(fit, "prec_slope_2", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_slope_2 = .value) + intercept_1 <- sccomp:::draws_to_tibble_x(fit, "prec_intercept_1", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_intercept_1 = .value) + intercept_2 <- sccomp:::draws_to_tibble_x(fit, "prec_intercept_2", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_intercept_2 = .value) + prec_sd <- sccomp:::draws_to_tibble_x(fit, "prec_sd", "C") |> + filter(C == 1L) |> + transmute(C, .chain, .iteration, prec_sd = .value) + mix_p <- fit$draws(variables = "mix_p", format = "draws_df") |> + transmute( + .chain = as.integer(.chain), + .iteration = as.integer(.iteration), + mix_p = mix_p + ) + + expected <- alpha |> + mutate(C_comp = model_input$variability_to_composition_map[C]) |> + left_join(beta, by = c("C_comp", "M", ".chain", ".iteration")) |> + left_join(slope_1, by = c("C", ".chain", ".iteration")) |> + left_join(slope_2, by = c("C", ".chain", ".iteration")) |> + left_join(intercept_1, by = c("C", ".chain", ".iteration")) |> + left_join(intercept_2, by = c("C", ".chain", ".iteration")) |> + left_join(prec_sd, by = c("C", ".chain", ".iteration")) |> + left_join(mix_p, by = c(".chain", ".iteration")) |> + mutate( + log_1 = log(mix_p) + + stats::dt((alpha - (beta * prec_slope_1 + prec_intercept_1)) / prec_sd, df = 3, log = TRUE) - + log(prec_sd), + log_2 = log1p(-mix_p) + + stats::dt((alpha - (beta * prec_slope_2 + prec_intercept_2)) / prec_sd, df = 3, log = TRUE) - + log(prec_sd), + max_log = pmax(log_1, log_2), + weight_1 = exp(log_1 - max_log) / (exp(log_1 - max_log) + exp(log_2 - max_log)), + slope_effective = weight_1 * prec_slope_1 + (1 - weight_1) * prec_slope_2, + expected = alpha - (beta * slope_effective) + ) |> + arrange(C, M, .chain, .iteration) |> + select(C, M, .chain, .iteration, expected) + + joined <- left_join(calc, expected, by = c("C", "M", ".chain", ".iteration")) + + expect_false(any(is.na(joined$calc))) + expect_false(any(is.na(joined$expected))) + expect_equal(joined$calc, joined$expected, tolerance = 1e-8) +}) + From 215c6817b33cb9eeaa37cc1e7ce10791e45ef3f9 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 16:16:59 +0930 Subject: [PATCH 30/68] Enhance statistical summarization in draws_to_statistics function Update the `draws_to_statistics` function to include `na.rm = TRUE` in quantile and mean calculations, improving robustness against missing values. This change ensures accurate statistical summaries by handling NA values appropriately, enhancing the overall reliability of the function. --- R/sccomp_test.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index c95ea75b..580d560d 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -998,11 +998,11 @@ draws_to_statistics = function(draws, false_positive_rate, test_composition_abov draws %>% group_by(!!.cell_group, M, parameter, rhat, ess_bulk, ess_tail) %>% summarise( - lower = quantile(.value, false_positive_rate / 2), - effect = mean(.value), - upper = quantile(.value, 1 - (false_positive_rate / 2)), - bigger_zero = sum(.value > test_composition_above_logit_fold_change), - smaller_zero = sum(.value < -test_composition_above_logit_fold_change), + lower = quantile(.value, false_positive_rate / 2, na.rm = TRUE), + effect = mean(.value, na.rm = TRUE), + upper = quantile(.value, 1 - (false_positive_rate / 2), na.rm = TRUE), + bigger_zero = sum(.value > test_composition_above_logit_fold_change, na.rm = TRUE), + smaller_zero = sum(.value < -test_composition_above_logit_fold_change, na.rm = TRUE), # R_k_hat = unique(R_k_hat), # n_eff = unique(n_eff), n = n(), From 8ab8957a876fb2693ae2a1bafcbf3d9627d786d2 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 7 Apr 2026 16:21:30 +0930 Subject: [PATCH 31/68] update docs --- man/sccomp_estimate.Rd | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/man/sccomp_estimate.Rd b/man/sccomp_estimate.Rd index 128a2011..a97f45d8 100644 --- a/man/sccomp_estimate.Rd +++ b/man/sccomp_estimate.Rd @@ -93,7 +93,15 @@ The sccomp version will be automatically appended to ensure version isolation. Default is \code{sccomp_stan_models_cache_dir} which points to \verb{~/.sccomp_models}.} \item{portable}{Logical, whether to keep the result portable by caching required draws in memory and removing Stan draw CSV files after fitting. -Default is TRUE to save disk space and move needed values into memory. Set to FALSE to keep draw CSV files on disk.} +Default is TRUE to save disk space and move needed values into memory. Set to FALSE to keep draw CSV files on disk. +With \code{portable = FALSE}, CSVs remain for you to inspect or archive, but cmdstanr typically \strong{still holds posterior draws in RAM} +after fitting and summarisation (\code{fit$summary()}). The printed estimate table only calls \code{fit$summary()} on composition +(\code{beta}, …) and variability (\code{alpha}, …), not on every saved parameter (e.g. \code{prec_sd}), yet cmdstanr still +exposes all saved parameters from memory once output has been read, so \code{fit$draws(variables = "prec_sd")} can work +after CSV deletion just like \code{beta}. Deleting CSVs does \strong{not} reliably invalidate the fit in the same R session. +Call \code{sccomp_test()} before deleting draw files, use \code{portable = TRUE} (draws cached then files removed), or run +\code{incorporate_parameters_into_sccomp_object()} before deletion if you remove files manually. \code{sccomp_test()} stops with a +clear error when recorded Stan output paths are missing unless draws were incorporated for portability as above.} \item{...}{Additional arguments passed to the \code{cmdstanr::sample} function.} From 5cf93ae7b5a53e08530ea9bb31f00da51c03eb64 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 08:39:25 +0930 Subject: [PATCH 32/68] Refactor parameter incorporation functions for improved flexibility Update `incorporate_parameters_into_fit_object` and `incorporate_parameters_into_sccomp_object` to accept a customizable list of parameters to load, enhancing their flexibility and usability. This change allows users to specify which parameters to include, streamlining the integration process with Stan models and improving overall code maintainability. --- R/utilities.R | 56 +++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 5e933c16..d946055e 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -110,35 +110,9 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE #' #' @keywords internal #' @noRd -incorporate_parameters_into_fit_object = function(fit) { - - # List of all parameters in the Stan model (glm_multi_beta_binomial) - # This includes parameters, transformed parameters, and generated quantities - parameters_to_load <- c( - # Parameters block - "beta_raw", - "alpha", - "prec_intercept_1", - "prec_slope_1", - "prec_intercept_2", - "prec_slope_2", - "prec_sd", - "mix_p", - "random_effect_raw", - "random_effect_raw_2", - "random_effect_sigma_mu", - "random_effect_sigma_sigma", - "random_effect_sigma_raw", - "sigma_correlation_factor", - "random_effect_sigma_raw_2", - "sigma_correlation_factor_2", - "zero_random_effect", - # Transformed parameters - "beta", - # Generated quantities - "log_lik" - ) +incorporate_parameters_into_fit_object = function(fit, params_to_load) { + # Get list of available variables from the fit object available_vars <- names(fit$draws(format = "draws_df")) @@ -168,7 +142,31 @@ incorporate_parameters_into_fit_object = function(fit) { #' #' @keywords internal #' @noRd -incorporate_parameters_into_sccomp_object = function(obj) { +incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c( + # Parameters block + "beta_raw", + "alpha", + "prec_intercept_1", + "prec_slope_1", + "prec_intercept_2", + "prec_slope_2", + "prec_sd", + "mix_p", + "random_effect_raw", + "random_effect_raw_2", + "random_effect_sigma_mu", + "random_effect_sigma_sigma", + "random_effect_sigma_raw", + "sigma_correlation_factor", + "random_effect_sigma_raw_2", + "sigma_correlation_factor_2", + "zero_random_effect", + # Transformed parameters + "beta", + # Generated quantities + "log_lik" + )) { + fit <- attr(obj, "fit") if (is.null(fit)) { stop("sccomp says: expected a \"fit\" attribute on the sccomp object.", call. = FALSE) From 8a48453e0cfc95b9a511e7ed6256294f31f115a8 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 08:46:10 +0930 Subject: [PATCH 33/68] Refactor parameter naming for consistency in incorporation functions Update the parameter name in `incorporate_parameters_into_fit_object` and its usage in `incorporate_parameters_into_sccomp_object` to enhance clarity and maintainability. This change standardizes the terminology used for parameters, improving code readability and consistency across the functions. --- R/utilities.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index d946055e..4fcc229f 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -110,19 +110,19 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE #' #' @keywords internal #' @noRd -incorporate_parameters_into_fit_object = function(fit, params_to_load) { +incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { # Get list of available variables from the fit object available_vars <- names(fit$draws(format = "draws_df")) # Filter to only include the parameters we care about that are available - params_to_load <- intersect(parameters_to_load, available_vars) + parameters_to_load <- intersect(parameters_to_load, available_vars) # Load parameters by calling draws() # This forces cmdstanr to read from CSV and store in memory - if (length(params_to_load) > 0) { - fit$draws(variables = params_to_load, format = "draws_df") + if (length(parameters_to_load) > 0) { + fit$draws(variables = parameters_to_load, format = "draws_df") } invisible(fit) @@ -171,7 +171,7 @@ incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c if (is.null(fit)) { stop("sccomp says: expected a \"fit\" attribute on the sccomp object.", call. = FALSE) } - attr(obj, "fit") <- incorporate_parameters_into_fit_object(fit) + attr(obj, "fit") <- incorporate_parameters_into_fit_object(fit, parameters_to_load) attr(obj, "sccomp_draws_incorporated_for_portability") <- TRUE obj } From 89833547fd72445e120cd9f678ddb6e4c5148ec8 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 08:54:44 +0930 Subject: [PATCH 34/68] Refactor parameter loading in incorporation functions for simplification Streamline the `incorporate_parameters_into_fit_object` function by removing unnecessary checks and directly loading specified parameters. This change simplifies the function's logic, enhancing readability and maintainability while ensuring that the fit object is returned correctly. Additionally, the error handling in `incorporate_parameters_into_sccomp_object` has been adjusted to rely on the updated fit object structure. --- R/utilities.R | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 4fcc229f..d5146053 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -112,20 +112,11 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE #' @noRd incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { - - # Get list of available variables from the fit object - available_vars <- names(fit$draws(format = "draws_df")) - - # Filter to only include the parameters we care about that are available - parameters_to_load <- intersect(parameters_to_load, available_vars) - # Load parameters by calling draws() # This forces cmdstanr to read from CSV and store in memory - if (length(parameters_to_load) > 0) { - fit$draws(variables = parameters_to_load, format = "draws_df") - } + fit$draws(variables = parameters_to_load, format = "draws_df") - invisible(fit) + fit } @@ -168,9 +159,6 @@ incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c )) { fit <- attr(obj, "fit") - if (is.null(fit)) { - stop("sccomp says: expected a \"fit\" attribute on the sccomp object.", call. = FALSE) - } attr(obj, "fit") <- incorporate_parameters_into_fit_object(fit, parameters_to_load) attr(obj, "sccomp_draws_incorporated_for_portability") <- TRUE obj From 64f095c7ed1caad64ec5cb6a95a140d18f3f9c38 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 17:39:51 +0930 Subject: [PATCH 35/68] streamline the contrast calculation --- DESCRIPTION | 4 +- NAMESPACE | 5 + R/sccomp_test.R | 506 ++++++++++++++++++++---------------------------- R/utilities.R | 8 +- 4 files changed, 225 insertions(+), 298 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c9ced17c..06391fee 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,8 @@ Imports: readr, stringr, glue, - SingleCellExperiment + SingleCellExperiment, + posterior Suggests: knitr, rmarkdown, @@ -48,7 +49,6 @@ Suggests: tidyseurat, tidySingleCellExperiment, bayesplot, - posterior, remotes Additional_repositories: https://mc-stan.org/r-packages/ diff --git a/NAMESPACE b/NAMESPACE index 1d8de29a..278225e4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -113,6 +113,11 @@ importFrom(parallel,detectCores) importFrom(patchwork,plot_annotation) importFrom(patchwork,plot_layout) importFrom(patchwork,wrap_plots) +importFrom(posterior,as_draws_df) +importFrom(posterior,ess_bulk) +importFrom(posterior,ess_tail) +importFrom(posterior,rhat) +importFrom(posterior,summarise_draws) importFrom(purrr,as_mapper) importFrom(purrr,map) importFrom(purrr,map2) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 580d560d..d69fe5f4 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -87,63 +87,46 @@ sccomp_test.sccomp_tbl = function(.data, truncation_df2 = .data |> attr("truncation_df2") inference_method = .data |> attr("inference_method") - identified <- sccomp_identify_covariate_contrasts(contrasts, model_input) - mapped_covariates <- if (is.null(identified)) NULL else unique(identified$contrast_mapping$design_param) - contrasts_parameters <- NULL - if (!is.null(contrasts)) { - contrasts_parameters <- contrasts_to_parameter_list(contrasts) - } - # sccomp_test always computes pH0/FDR from posterior draws. - abundance_CI <- get_abundance_contrast_draws(.data, contrasts, mapped_covariates, contrasts_parameters) - - if ("parameter" %in% colnames(abundance_CI)) { - abundance_CI <- - abundance_CI |> + result <- + get_abundance_contrast_draws(.data, contrasts) |> draws_to_statistics( percent_false_positive / 100, test_composition_above_logit_fold_change, !!.cell_group, "c_" ) - } - - variability_CI <- get_variability_contrast_draws(.data, contrasts, mapped_covariates, contrasts_parameters) + + variability_draws <- get_variability_contrast_draws(.data, contrasts) - if ("parameter" %in% colnames(variability_CI)) { - variability_CI <- - variability_CI |> - draws_to_statistics( - percent_false_positive / 100, - test_composition_above_logit_fold_change, - !!.cell_group, - "v_" - ) + # If I have variability draws for those contrasts, compute the variability CI + if ("parameter" %in% colnames(variability_draws)) { + result = + result |> + left_join( + variability_draws |> + draws_to_statistics( + percent_false_positive / 100, + test_composition_above_logit_fold_change, + !!.cell_group, + "v_" + ) + ) } + - # If I don't have factors (~1) - if (!"factor" %in% colnames(model_input$factor_parameter_dictionary)) - factor_parameter_dictionary = tibble(`factor` = character(), design_matrix_col = character()) - else - factor_parameter_dictionary = + factor_parameter_dictionary = model_input$factor_parameter_dictionary |> select(`factor`, design_matrix_col) # Merge and parse result = - abundance_CI |> - - # Add ALPHA - left_join(variability_CI) |> - suppressMessages() |> + result |> - # Add easy to understand factor labels - left_join(factor_parameter_dictionary, - by = c("parameter" = "design_matrix_col")) |> - select(parameter, `factor`, everything()) |> - - select(!!.cell_group, everything(),-M) - + # Keep factor labels in the result schema; plotting/subsetting helpers rely on this. + left_join(factor_parameter_dictionary, by = c("parameter" = "design_matrix_col")) |> + select(!!.cell_group, parameter, `factor`, everything(), -M) + if(pass_fit) result = result |> @@ -458,8 +441,53 @@ sccomp_identify_covariate_contrasts <- function(contrasts, model_input) { ) } +#' Build Stan indexed-variable subset from contrast terms. +#' +#' @param contrasts Character vector of contrast expressions. Can be `NULL`. +#' @param design_columns Character vector of design-matrix column names for the target parameter block. +#' @param stan_parameter Character scalar Stan parameter name (for example, `"beta"` or `"alpha"`). +#' @param model_input Model input list containing `y`, used to infer the `M` index size. +#' +#' @keywords internal +#' @noRd +build_stan_parameter_subset <- function(contrasts, design_columns, stan_parameter, model_input) { + if (is.null(contrasts)) { + return( + tibble::tibble( + parameter = design_columns, + variable = rep(stan_parameter, length(design_columns)) + ) + ) + } + + candidate_terms <- contrasts_to_parameter_list(contrasts) + if (is.null(candidate_terms) || length(candidate_terms) == 0) { + return(tibble::tibble(parameter = character(), variable = character())) + } + + candidate_terms <- unique(candidate_terms) + candidate_terms <- candidate_terms[!is.na(candidate_terms) & candidate_terms != ""] + if (length(candidate_terms) == 0) { + return(tibble::tibble(parameter = character(), variable = character())) + } + + matched <- intersect(candidate_terms, design_columns) + if (length(matched) == 0) { + return(tibble::tibble(parameter = character(), variable = character())) + } + + n_M <- ncol(model_input$y) + C_idx <- match(matched, design_columns) + g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) + + tibble::tibble( + parameter = matched[g$C], + variable = sprintf("%s[%d,%d]", stan_parameter, g$C, g$M) + ) +} + # this can be helpful if we want to draw PCA with uncertainty -get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = NULL, contrasts_parameters = NULL){ +get_abundance_contrast_draws = function(.data, contrasts = NULL){ # Define the variables as NULL to avoid CRAN NOTES X <- NULL @@ -475,67 +503,57 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = .cell_group = .data |> attr(".cell_group") + model_input <- .data |> attr("model_input") + cell_index_map <- + model_input %$% + y %>% + colnames() |> + enframe(name = "M", value = quo_name(.cell_group)) # Beta - beta_factor_of_interest = .data |> attr("model_input") %$% X |> colnames() - # beta = - # .data |> - # attr("fit") %>% - # draws_to_tibble_x_y("beta", "C", "M") |> - # pivot_wider(names_from = C, values_from = .value) %>% - # setNames(colnames(.)[1:5] |> c(beta_factor_of_interest)) - beta_variable_subset <- NULL - if (!is.null(design_param_subset)) { - needed <- intersect(design_param_subset, beta_factor_of_interest) - if (length(needed) > 0) { - n_M <- ncol(.data |> attr("model_input") %$% y) - C_idx <- match(needed, beta_factor_of_interest) - g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) - beta_variable_subset <- sprintf("beta[%d,%d]", g$C, g$M) - } - } - - if(contrasts |> is.null()) - draws = - .data |> - attr("fit") %>% - draws_to_tibble_x_y("beta", "C", "M") |> - pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(beta_factor_of_interest)) |> - select(-.variable) + beta_covariates = model_input %$% X |> colnames() - else if((beta_factor_of_interest %in% contrasts_parameters) |> which() |> length() > 0) + beta_subset <- build_stan_parameter_subset( + contrasts = contrasts, + design_columns = beta_covariates, + stan_parameter = "beta", + model_input = model_input + ) + beta_parameters <- beta_subset |> dplyr::pull(parameter) |> unique() + beta_variable_subset <- beta_subset |> dplyr::pull(variable) |> unique() + draws = .data |> attr("fit") %>% - draws_to_tibble_x_y( - if (is.null(beta_variable_subset)) "beta" else beta_variable_subset, - "C", - "M" - ) |> + draws_to_tibble_x_y( beta_variable_subset, "C", "M") |> left_join( - beta_factor_of_interest |> enframe(name = "C", value = "parameters_name"), + beta_covariates |> enframe(name = "C", value = "parameters_name"), by = "C" ) |> - filter(parameters_name %in% contrasts_parameters) |> select(-C) |> pivot_wider(names_from = parameters_name, values_from = .value) |> select(-.variable) - else - draws = tibble() # Random effect - beta_random_effect_factor_of_interest = .data |> attr("model_input") %$% X_random_effect |> colnames() + random_effect_covariates = model_input %$% X_random_effect |> colnames() + beta_random_effect_subset <- build_stan_parameter_subset( + contrasts = contrasts, + design_columns = random_effect_covariates, + stan_parameter = "random_effect", + model_input = model_input + ) + beta_random_effect_parameters <- beta_random_effect_subset |> dplyr::pull(parameter) |> unique() + beta_random_effect_variables <- beta_random_effect_subset |> dplyr::pull(variable) |> unique() if( .data |> attr("model_input") %$% n_random_eff > 0 && ( contrasts |> is.null() || - (beta_random_effect_factor_of_interest %in% contrasts_parameters) |> which() |> length() > 0 + length(beta_random_effect_parameters) > 0 ) ){ @@ -543,7 +561,7 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = beta_random_effect = .data |> attr("fit") %>% - draws_to_tibble_x_y("random_effect", "C", "M") + draws_to_tibble_x_y(beta_random_effect_variables, "C", "M" ) # Add last component other_group_random_effect = @@ -563,10 +581,10 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = beta_random_effect = beta_random_effect |> left_join( - beta_random_effect_factor_of_interest |> enframe(name = "C", value = "parameters_name"), + random_effect_covariates |> enframe(name = "C", value = "parameters_name"), by = "C" ) |> - filter(parameters_name %in% contrasts_parameters) |> + filter(parameters_name %in% beta_random_effect_parameters) |> select(-C) |> pivot_wider(names_from = parameters_name, values_from = .value) @@ -574,8 +592,8 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = beta_random_effect = beta_random_effect |> pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(beta_random_effect_factor_of_interest)) - + setNames(colnames(.)[1:5] |> c(random_effect_covariates)) + # If I don't have fix nor 1st level random effect if(draws |> nrow() == 0) draws = select(beta_random_effect, -.variable) @@ -586,24 +604,32 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = ) } else { - beta_random_effect_factor_of_interest = "" + random_effect_covariates = "" } # Second random effect. IN THE FUTURE THIS WILL BE VECTORISED TO ARBUTRARY GRI+OUING - beta_random_effect_factor_of_interest_2 = .data |> attr("model_input") %$% X_random_effect_2 |> colnames() + random_effect_covariates_2 = model_input %$% X_random_effect_2 |> colnames() + beta_random_effect_subset_2 <- build_stan_parameter_subset( + contrasts = contrasts, + design_columns = random_effect_covariates_2, + stan_parameter = "random_effect_2", + model_input = model_input + ) + beta_random_effect_parameters_2 <- beta_random_effect_subset_2 |> dplyr::pull(parameter) |> unique() + beta_random_effect_variables_2 <- beta_random_effect_subset_2 |> dplyr::pull(variable) |> unique() if( .data |> attr("model_input") %$% n_random_eff > 1 && ( contrasts |> is.null() || - (beta_random_effect_factor_of_interest_2 %in% contrasts_parameters) |> which() |> length() > 0 + length(beta_random_effect_parameters_2) > 0 ) ){ beta_random_effect_2 = .data |> attr("fit") %>% - draws_to_tibble_x_y("random_effect_2", "C", "M") + draws_to_tibble_x_y( beta_random_effect_variables_2, "C", "M" ) # Add last component other_group_random_effect = @@ -621,10 +647,10 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = beta_random_effect_2 = beta_random_effect_2 |> left_join( - beta_random_effect_factor_of_interest_2 |> enframe(name = "C", value = "parameters_name"), + random_effect_covariates_2 |> enframe(name = "C", value = "parameters_name"), by = "C" ) |> - filter(parameters_name %in% contrasts_parameters) |> + filter(parameters_name %in% beta_random_effect_parameters_2) |> select(-C) |> pivot_wider(names_from = parameters_name, values_from = .value) @@ -632,7 +658,7 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = beta_random_effect_2 = beta_random_effect_2 |> pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(beta_random_effect_factor_of_interest_2)) + setNames(colnames(.)[1:5] |> c(random_effect_covariates_2)) # If I don't have fix nor 1st level random effect if(draws |> nrow() == 0) @@ -643,7 +669,7 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = by = c("M", ".chain", ".iteration", ".draw") ) } else { - beta_random_effect_factor_of_interest_2 = "" + random_effect_covariates_2 = "" } @@ -652,130 +678,28 @@ get_abundance_contrast_draws = function(.data, contrasts, design_param_subset = draws = draws |> mutate_from_expr_list(contrasts, ignore_errors = FALSE) |> - select(- any_of(c(beta_factor_of_interest, beta_random_effect_factor_of_interest) |> setdiff(contrasts)) ) - - # Add cell name - draws = draws |> - left_join( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) %>% - select(!!.cell_group, everything()) - - - # If no contrasts of interest just return an empty data frame - if(ncol(draws)==5) return(draws |> distinct(M, !!.cell_group)) - - # Get convergence for fixed effects - convergence_df = - .data |> - attr("fit") |> - summary_to_tibble("beta", "C", "M") |> - - # Add cell name - left_join( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) |> - - # factor names - left_join( - beta_factor_of_interest |> - enframe(name = "C", value = "parameter"), - by = "C" - ) - - # Get convergence for random effects if they exist - if(.data |> attr("model_input") %$% n_random_eff > 0) { - convergence_df_random = - .data |> - attr("fit") |> - summary_to_tibble("random_effect", "C", "M") |> - - # Add cell name - left_join( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) |> - - # factor names - left_join( - beta_random_effect_factor_of_interest |> - enframe(name = "C", value = "parameter"), - by = "C" - ) - - # Combine fixed and random effects convergence - convergence_df = bind_rows(convergence_df, convergence_df_random) - } - - # Get convergence for second random effect if it exists - if(.data |> attr("model_input") %$% n_random_eff > 1) { - convergence_df_random_2 = - .data |> - attr("fit") |> - summary_to_tibble("random_effect_2", "C", "M") |> - - # Add cell name - left_join( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) |> - - # factor names - left_join( - beta_random_effect_factor_of_interest_2 |> - enframe(name = "C", value = "parameter"), - by = "C" - ) - - # Combine with existing convergence data - convergence_df = bind_rows(convergence_df, convergence_df_random_2) - } - - # if ("Rhat" %in% colnames(convergence_df)) { - # convergence_df <- rename(convergence_df, R_k_hat = Rhat) - # } else if ("khat" %in% colnames(convergence_df)) { - # convergence_df <- rename(convergence_df, R_k_hat = khat) - # } - - - convergence_df = - convergence_df |> - select(!!.cell_group, parameter, any_of(c("n_eff", "R_k_hat", "rhat", "ess_bulk", "ess_tail"))) |> - suppressWarnings() + select(- any_of(c(beta_covariates, random_effect_covariates) |> setdiff(contrasts)) ) - draws |> - pivot_longer(-c(1:5), names_to = "parameter", values_to = ".value") |> - - # Attach convergence if I have no contrasts - left_join(convergence_df, by = c(quo_name(.cell_group), "parameter")) |> + + draws = draws |> + pivot_longer(-c(1:4), names_to = "parameter", values_to = ".value") |> # Reorder because pivot long is bad - mutate(parameter = parameter |> fct_relevel(colnames(draws)[-c(1:5)])) |> + mutate(parameter = parameter |> fct_relevel(colnames(draws)[-c(1:4)])) |> arrange(parameter) + + # Add cell name + draws = draws |> + left_join(cell_index_map, by = "M" ) %>% + select(!!.cell_group, everything()) + + draws } #' @importFrom forcats fct_relevel #' @noRd -get_variability_contrast_draws = function(.data, contrasts, design_param_subset = NULL, contrasts_parameters = NULL){ +get_variability_contrast_draws = function(.data, contrasts){ # Define the variables as NULL to avoid CRAN NOTES XA <- NULL @@ -788,31 +712,31 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset R_k_hat <- NULL .cell_group = .data |> attr(".cell_group") - - variability_factor_of_interest = .data |> attr("model_input") %$% XA |> colnames() - alpha_variable_subset <- NULL - if (!is.null(design_param_subset)) { - needed <- intersect(design_param_subset, variability_factor_of_interest) - if (length(needed) == 0 && !is.null(contrasts)) { - return( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)) |> - dplyr::select(!!.cell_group, M) - ) - } - n_M <- ncol(.data |> attr("model_input") %$% y) - C_idx <- match(needed, variability_factor_of_interest) - g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) - alpha_variable_subset <- sprintf("alpha[%d,%d]", g$C, g$M) + model_input <- .data |> attr("model_input") + cell_index_map <- + model_input %$% + y %>% + colnames() |> + enframe(name = "M", value = quo_name(.cell_group)) + + variability_covariates = model_input %$% XA |> colnames() + alpha_subset <- build_stan_parameter_subset( + contrasts = contrasts, + design_columns = variability_covariates, + stan_parameter = "alpha", + model_input = model_input + ) + alpha_parameters <- alpha_subset |> dplyr::pull("parameter") |> unique() + alpha_variable_subset <- alpha_subset |> dplyr::pull("variable") |> unique() + if (length(alpha_variable_subset) == 0) alpha_variable_subset <- NULL + if (!is.null(contrasts) && length(alpha_parameters) == 0) { + return(cell_index_map |> dplyr::select(!!.cell_group, M)) } draws = compute_alpha_normalised_draws( fit = .data |> attr("fit"), - model_input = .data |> attr("model_input"), + model_input = model_input, alpha_variable_subset = alpha_variable_subset ) |> @@ -825,10 +749,9 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset draws = draws |> left_join( - variability_factor_of_interest |> enframe(name = "C", value = "parameters_name"), + variability_covariates |> enframe(name = "C", value = "parameters_name"), by = "C" ) |> - filter(parameters_name %in% contrasts_parameters) |> select(-C) |> pivot_wider(names_from = parameters_name, values_from = .value) |> select( -.variable) @@ -837,66 +760,28 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset draws = draws |> pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(variability_factor_of_interest)) |> + setNames(colnames(.)[1:5] |> c(variability_covariates)) |> select( -.variable) # If I have constrasts calculate if (!is.null(contrasts)) draws <- mutate_from_expr_list(draws, contrasts, ignore_errors = TRUE) - draws = draws |> - - # Add cell name - left_join( - .data |> attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) %>% - select(!!.cell_group, everything()) - # If no contrasts of interest just return an empty data frame - if(ncol(draws)==5) return(draws |> distinct(M, !!.cell_group)) - - # Get convergence - convergence_df = - .data |> - attr("fit") |> - summary_to_tibble("alpha", "C", "M") |> - - # Add cell name - left_join( - .data |> - attr("model_input") %$% - y %>% - colnames() |> - enframe(name = "M", value = quo_name(.cell_group)), - by = "M" - ) |> - - # factor names - left_join( - variability_factor_of_interest |> - enframe(name = "C", value = "parameter"), - by = "C" - ) + if(ncol(draws)==5) return(cell_index_map |> dplyr::select(!!.cell_group, M) |> distinct()) - convergence_df = - convergence_df |> - select(!!.cell_group, parameter, any_of(c("n_eff", "R_k_hat", "rhat", "ess_bulk", "ess_tail"))) |> - suppressWarnings() - - - draws |> + draws = draws |> pivot_longer(-c(1:5), names_to = "parameter", values_to = ".value") |> - - # Attach convergence if I have no contrasts - left_join(convergence_df, by = c(quo_name(.cell_group), "parameter")) |> - + # Reorder because pivot long is bad mutate(parameter = parameter |> fct_relevel(colnames(draws)[-c(1:5)])) |> arrange(parameter) + + draws = draws |> + left_join(cell_index_map, by = "M") %>% + select(!!.cell_group, everything()) + + draws } @@ -929,8 +814,10 @@ get_variability_contrast_draws = function(.data, contrasts, design_param_subset #' mutate_from_expr_list = function(x, formula_expr, ignore_errors = TRUE){ - if(formula_expr |> names() |> is.null()) - names(formula_expr) = formula_expr + # Preserve provided contrast names; for unnamed entries, use the expression itself. + names(formula_expr) = + ifelse(is.null(names(formula_expr)) || names(formula_expr) == "", formula_expr, names(formula_expr)) |> + make.unique() # Creating a named vector where the names are the strings to be replaced # and the values are empty strings @@ -977,10 +864,17 @@ mutate_from_expr_list = function(x, formula_expr, ignore_errors = TRUE){ } +#' @importFrom dplyr pull +#' @importFrom posterior as_draws_df summarise_draws rhat ess_bulk ess_tail +#' @noRd draws_to_statistics = function(draws, false_positive_rate, test_composition_above_logit_fold_change, .cell_group, prefix = ""){ # Define the variables as NULL to avoid CRAN NOTES M <- NULL + .chain <- NULL + .iteration <- NULL + .draw <- NULL + .value <- NULL parameter <- NULL bigger_zero <- NULL smaller_zero <- NULL @@ -993,27 +887,55 @@ draws_to_statistics = function(draws, false_positive_rate, test_composition_abov R_k_hat <- NULL .cell_group = enquo(.cell_group) - - draws = + lower_prob = false_positive_rate / 2 + upper_prob = 1 - lower_prob + + draw_summaries = + draws |> + group_by(!!.cell_group, M, parameter) |> + group_modify( + ~ { + draws_df = + .x |> + select(.chain, .iteration, .draw, value = .value) |> + as_draws_df() |> + summarise_draws( + lower = function(.x) stats::quantile(.x, probs = lower_prob, na.rm = TRUE), + effect = function(.x) mean(.x, na.rm = TRUE), + upper = function(.x) stats::quantile(.x, probs = upper_prob, na.rm = TRUE), + rhat, + ess_bulk, + ess_tail + ) |> + select(-variable) + + # Standardise CI column names when posterior returns percentage names (e.g. `5%`, `97.5%`). + quantile_cols = names(draws_df)[grepl("%$", names(draws_df))] + names(draws_df)[names(draws_df) %in% quantile_cols] = c("lower", "upper") + + draws_df + } + ) |> + ungroup() + + probability_stats = draws %>% - group_by(!!.cell_group, M, parameter, rhat, ess_bulk, ess_tail) %>% + group_by(!!.cell_group, M, parameter) %>% summarise( - lower = quantile(.value, false_positive_rate / 2, na.rm = TRUE), - effect = mean(.value, na.rm = TRUE), - upper = quantile(.value, 1 - (false_positive_rate / 2), na.rm = TRUE), bigger_zero = sum(.value > test_composition_above_logit_fold_change, na.rm = TRUE), smaller_zero = sum(.value < -test_composition_above_logit_fold_change, na.rm = TRUE), - # R_k_hat = unique(R_k_hat), - # n_eff = unique(n_eff), n = n(), - .groups = "drop" # To ungroup the output if needed - ) |> - + .groups = "drop" + ) + + draws = + draw_summaries |> + left_join(probability_stats, by = c(quo_name(.cell_group), "M", "parameter")) |> # Calculate probability non 0 mutate(pH0 = (1 - (pmax(bigger_zero, smaller_zero) / n))) |> with_groups(parameter, ~ mutate(.x, FDR = get_FDR(pH0))) |> - select(!!.cell_group, M, parameter, lower, effect, upper, pH0, FDR, any_of(c("n_eff", "R_k_hat", "rhat", "ess_bulk", "ess_tail"))) |> + select(!!.cell_group, M, parameter, lower, effect, upper, pH0, FDR, any_of(c("rhat", "ess_bulk", "ess_tail"))) |> suppressWarnings() # Setting up names separately because |> is not flexible enough diff --git a/R/utilities.R b/R/utilities.R index d5146053..77e96b4c 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -111,10 +111,12 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE #' @keywords internal #' @noRd incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { + parameters_present <- intersect(parameters_to_load, fit$metadata()$model_params) + # Load parameters by calling draws() # This forces cmdstanr to read from CSV and store in memory - fit$draws(variables = parameters_to_load, format = "draws_df") + fit$draws(variables = parameters_present, format = "draws_df") fit } @@ -349,7 +351,6 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { .value <- NULL - base_parameter <- sub("\\[.*$", "", par[[1]]) draws_df <- fit$draws(variables = par, format = "draws_df") value_columns <- setdiff(colnames(draws_df), c(".chain", ".iteration", ".draw")) @@ -379,8 +380,7 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { group_by(.variable, !!as.symbol(x), !!as.symbol(y)) %>% mutate(.draw = seq_len(n())) %>% ungroup() %>% - select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw, .variable, .value) %>% - filter(.variable == base_parameter) + select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw, .variable, .value) } From 05a9d1017f4b10d153134894065f32419b5267d8 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 17:56:25 +0930 Subject: [PATCH 36/68] Add function to handle missing contrast names in mutate_from_expr_list Introduce `add_missing_contrast_names` to ensure contrast names are properly assigned, enhancing the clarity and robustness of the `mutate_from_expr_list` function. This change improves the handling of unnamed entries, making the code more maintainable and user-friendly. --- R/sccomp_test.R | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index d69fe5f4..8b729ef6 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -787,6 +787,19 @@ get_variability_contrast_draws = function(.data, contrasts){ #' Mutate Data Frame Based on Expression List #' +#' @noRd +add_missing_contrast_names = function(formula_expr){ + contrast_names = names(formula_expr) + if (is.null(contrast_names)) { + contrast_names = formula_expr + } else { + missing_names = is.na(contrast_names) | contrast_names == "" + contrast_names[missing_names] = formula_expr[missing_names] + } + + make.unique(contrast_names) +} + #' @description #' `mutate_from_expr_list` takes a data frame and a list of formula expressions, #' and mutates the data frame based on these expressions. It allows for ignoring @@ -814,10 +827,7 @@ get_variability_contrast_draws = function(.data, contrasts){ #' mutate_from_expr_list = function(x, formula_expr, ignore_errors = TRUE){ - # Preserve provided contrast names; for unnamed entries, use the expression itself. - names(formula_expr) = - ifelse(is.null(names(formula_expr)) || names(formula_expr) == "", formula_expr, names(formula_expr)) |> - make.unique() + names(formula_expr) = add_missing_contrast_names(formula_expr) # Creating a named vector where the names are the strings to be replaced # and the values are empty strings From 9985687e6b32f7d0181f4788b00e3bd67b5daec3 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 18:03:23 +0930 Subject: [PATCH 37/68] Update variability contrast draws handling to accommodate fewer columns Modify the `get_variability_contrast_draws` function to handle cases where the number of columns in `draws` is less than or equal to four. This change ensures that the function can return an appropriate empty data frame when no contrasts of interest are present, improving its robustness and flexibility in processing data. --- R/sccomp_test.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 8b729ef6..4c14fc2a 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -768,13 +768,13 @@ get_variability_contrast_draws = function(.data, contrasts){ draws <- mutate_from_expr_list(draws, contrasts, ignore_errors = TRUE) # If no contrasts of interest just return an empty data frame - if(ncol(draws)==5) return(cell_index_map |> dplyr::select(!!.cell_group, M) |> distinct()) + if(ncol(draws) <= 4) return(cell_index_map |> dplyr::select(!!.cell_group, M) |> distinct()) draws = draws |> - pivot_longer(-c(1:5), names_to = "parameter", values_to = ".value") |> + pivot_longer(-c(1:4), names_to = "parameter", values_to = ".value") |> # Reorder because pivot long is bad - mutate(parameter = parameter |> fct_relevel(colnames(draws)[-c(1:5)])) |> + mutate(parameter = parameter |> fct_relevel(colnames(draws)[-c(1:4)])) |> arrange(parameter) draws = draws |> From 76b92d6823508c416835b49b3e902aeda69ab972 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 18:29:01 +0930 Subject: [PATCH 38/68] Refactor draws_to_tibble functions for improved data handling Update the `draws_to_tibble_x_y` and `draws_to_tibble_x` functions to convert `.chain`, `.iteration`, and `.draw` columns to integers, enhancing data consistency. Additionally, streamline the arrangement of data frames by including `.iteration` in the sorting process, improving the overall organization of the output data. --- R/utilities.R | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index 77e96b4c..e7af9239 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -356,7 +356,11 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { value_columns <- setdiff(colnames(draws_df), c(".chain", ".iteration", ".draw")) draws_df %>% - mutate(.iteration = seq_len(n())) %>% + mutate( + .chain = as.integer(.chain), + .iteration = as.integer(.iteration), + .draw = as.integer(.draw) + ) %>% pivot_longer( names_to = "parameter", # c( ".chain", ".variable", x, y), @@ -376,10 +380,7 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { !!as.symbol(x) := as.integer(!!as.symbol(x)), !!as.symbol(y) := as.integer(!!as.symbol(y)) ) %>% - arrange(.variable, !!as.symbol(x), !!as.symbol(y), .chain) %>% - group_by(.variable, !!as.symbol(x), !!as.symbol(y)) %>% - mutate(.draw = seq_len(n())) %>% - ungroup() %>% + arrange(.variable, !!as.symbol(x), !!as.symbol(y), .chain, .iteration) %>% select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw, .variable, .value) } @@ -407,7 +408,11 @@ draws_to_tibble_x = function(fit, par, x) { value_columns <- setdiff(colnames(draws_df), c(".chain", ".iteration", ".draw")) draws_df %>% - mutate(.iteration = seq_len(n())) %>% + mutate( + .chain = as.integer(.chain), + .iteration = as.integer(.iteration), + .draw = as.integer(.draw) + ) %>% pivot_longer( names_to = "parameter", cols = tidyselect::all_of(value_columns), @@ -418,10 +423,7 @@ draws_to_tibble_x = function(fit, par, x) { mutate( !!as.symbol(x) := as.integer(!!as.symbol(x)) ) %>% - arrange(.variable, !!as.symbol(x), .chain) %>% - group_by(.variable, !!as.symbol(x)) %>% - mutate(.draw = seq_len(n())) %>% - ungroup() %>% + arrange(.variable, !!as.symbol(x), .chain, .iteration) %>% select(!!as.symbol(x), .chain, .iteration, .draw, .variable, .value) %>% filter(.variable == base_parameter) } From 76193355b24af46f6222a0f55a3ec040ccf6c47b Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 18:33:07 +0930 Subject: [PATCH 39/68] Remove unnecessary arrangement steps in draws_to_tibble functions for cleaner output Eliminate the sorting of data frames by `.variable` and other columns in the `draws_to_tibble_x_y` and `draws_to_tibble_x` functions. This change simplifies the output structure, focusing on essential columns and improving data handling efficiency. --- R/utilities.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index e7af9239..cd19d3b4 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -380,7 +380,6 @@ draws_to_tibble_x_y = function(fit, par, x, y, number_of_draws = NULL) { !!as.symbol(x) := as.integer(!!as.symbol(x)), !!as.symbol(y) := as.integer(!!as.symbol(y)) ) %>% - arrange(.variable, !!as.symbol(x), !!as.symbol(y), .chain, .iteration) %>% select(!!as.symbol(x), !!as.symbol(y), .chain, .iteration, .draw, .variable, .value) } @@ -423,7 +422,6 @@ draws_to_tibble_x = function(fit, par, x) { mutate( !!as.symbol(x) := as.integer(!!as.symbol(x)) ) %>% - arrange(.variable, !!as.symbol(x), .chain, .iteration) %>% select(!!as.symbol(x), .chain, .iteration, .draw, .variable, .value) %>% filter(.variable == base_parameter) } From 80d4459c28a38cb9b06b6cd46173bd72c224f513 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 19:30:17 +0930 Subject: [PATCH 40/68] fix parameter incorporation logic in fit object function --- R/utilities.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utilities.R b/R/utilities.R index cd19d3b4..7d74f824 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -111,7 +111,9 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE #' @keywords internal #' @noRd incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { - parameters_present <- intersect(parameters_to_load, fit$metadata()$model_params) + model_params <- fit$metadata()$model_params + model_params_base <- unique(sub("(\\[.*\\])?$", "", model_params)) + parameters_present <- intersect(parameters_to_load, model_params_base) # Load parameters by calling draws() From 58087afb6d3f1cfdd744963bd79050892856c583 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 19:55:57 +0930 Subject: [PATCH 41/68] Refactor initialization logic in fit_model function for improved clarity and flexibility Update the initialization of parameters in the fit_model function, including changes to the precision standard deviation and mixing proportion. Simplify the logic for setting intercept and non-intercept initial values based on variability conditions, enhancing code readability and maintainability. --- R/model_fitting.R | 115 ++++++++++++++++++++-------------------------- 1 file changed, 51 insertions(+), 64 deletions(-) diff --git a/R/model_fitting.R b/R/model_fitting.R index 5c850c78..da509819 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -10,27 +10,27 @@ fit_model = function( ... ) { - + # # if analysis approximated # # If posterior analysis is approximated I just need enough # how_many_posterior_draws_practical = ifelse(approximate_posterior_analysis, 1000, how_many_posterior_draws) # additional_parameters_to_save = additional_parameters_to_save %>% c("lambda_log_param", "sigma_raw") %>% unique - - + + # Find number of draws draws_supporting_quantile = 50 if(is.null(output_samples)){ - + output_samples = (draws_supporting_quantile/((1-quantile)/2)) %>% # /2 because I have two tails - max(4000) - + max(4000) + if(output_samples > max_sampling_iterations) { # message("sccomp says: the number of draws used to defined quantiles of the posterior distribution is capped to 20K.") # This means that for very low probability threshold the quantile could become unreliable. We suggest to limit the probability threshold between 0.1 and 0.01") output_samples = max_sampling_iterations - + }} - + # Find optimal number of chains if(is.null(chains)) chains = @@ -40,7 +40,7 @@ fit_model = function( parallelisation_start_penalty = 100 ) %>% min(cores) - + # chains = 3 init_list = list( @@ -48,27 +48,24 @@ fit_model = function( rep(0, (data_for_model$A - 1) * data_for_model$M)), nrow = data_for_model$A, byrow = TRUE), beta_raw = matrix(0, data_for_model$C, data_for_model$M), - prec_sd = rep(1, data_for_model$A), - mix_p = 0.1 + log_prec_sd = rep(0, data_for_model$A), + mix_p = 0.5 ) has_variability_intercept <- isTRUE(as.logical(data_for_model$intercept_in_design)) bimodal <- data_for_model$bimodal_mean_variability_association == 1L - init_list$prec_intercept <- vector("list", data_for_model$A) - for (a in seq_len(data_for_model$A)) { - intercept_col <- has_variability_intercept && a == 1L - init_list$prec_intercept[[a]] <- if (bimodal) { - if (intercept_col) c(4, 5) - else if (has_variability_intercept) c(0, 1) - else c(4, 5) + intercept_init <- if (bimodal) c(4, 5) else c(4) + non_intercept_init <- if (bimodal) c(0, 1) else c(0) + + init_list$prec_intercept <- + if (has_variability_intercept) { + c(list(intercept_init), rep(list(non_intercept_init), data_for_model$A - 1L)) } else { - if (intercept_col) c(4) - else if (has_variability_intercept) c(0) - else c(4) + rep(list(intercept_init), data_for_model$A) } - } + init_list$prec_slope_1 = rep(0, data_for_model$A) - if (data_for_model$bimodal_mean_variability_association == 1) { + if (bimodal) { init_list$prec_slope_2 = rep(0, data_for_model$A) } @@ -76,23 +73,23 @@ fit_model = function( init_list$random_effect_raw = matrix(0, data_for_model$ncol_X_random_eff[1] , data_for_model$M) init_list$random_effect_sigma_raw = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[1]) init_list$sigma_correlation_factor = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[1], + data_for_model$M, + data_for_model$how_many_factors_in_random_design[1], data_for_model$how_many_factors_in_random_design[1] )) # init_list$random_effect_sigma_mu = 0.5 |> as.array() # init_list$random_effect_sigma_sigma = 0.2 |> as.array() init_list$zero_random_effect = rep(0, size = 1) |> as.array() - - } - + + } + if(data_for_model$n_random_eff>1){ init_list$random_effect_raw_2 = matrix(0, data_for_model$ncol_X_random_eff[2] , data_for_model$M) init_list$random_effect_sigma_raw_2 = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[2]) init_list$sigma_correlation_factor_2 = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[2], + data_for_model$M, + data_for_model$how_many_factors_in_random_design[2], data_for_model$how_many_factors_in_random_design[2] )) @@ -133,25 +130,15 @@ fit_model = function( sig_figs = sig_figs, show_exceptions = verbose, ... - ) - - # }, - # error = function(e) { - # - # # I don't know why thi is needed nd why the model sometimes is not compliled correctly - # if(e |> as.character() |> str_detect("Model not compiled")) - # model = load_model(model_name, force=TRUE, threads = cores) - # else - # stop(e) - # - # }) - + ) + + } else{ - + if(inference_method=="pathfinder") init = pf else if(inference_method=="variational") init = list(init_list) - + vb_iterative( mod, model_name = model_name, @@ -162,20 +149,20 @@ fit_model = function( seed = seed, output_dir = output_directory, init = init, - inference_method = inference_method, + inference_method = inference_method, cores = cores, - psis_resample = FALSE, + psis_resample = FALSE, verbose = verbose, sig_figs = sig_figs, cache_stan_model = cache_stan_model, show_exceptions = FALSE, ... - ) - + ) + } - - - + + + } get_model_from_data = function(file_compiled_model, model_code){ @@ -185,7 +172,7 @@ get_model_from_data = function(file_compiled_model, model_code){ model_generate = stan_model(model_code = model_code) model_generate %>% saveRDS(file_compiled_model) model_generate - + } } @@ -431,9 +418,9 @@ vb_iterative = function(model, }) i = i + 1 } - + if(is.null(res)) stop(sprintf("sccomp says: variational Bayes did not converge after %s attempts. Please use variational_inference = FALSE for a HMC fitting.", i)) - + return(res) } @@ -449,21 +436,21 @@ vb_iterative = function(model, #' @return A Stan fit object find_optimal_number_of_chains = function(how_many_posterior_draws = 100, max_number_to_check = 100, warmup = 200, parallelisation_start_penalty = 100) { - - - + + + # Define the variables as NULL to avoid CRAN NOTES chains <- NULL - - + + chains_df = tibble(chains = seq_len(max_number_to_check)) %>% mutate(tot = (how_many_posterior_draws / chains) + warmup + (parallelisation_start_penalty * chains)) - + d1 <- diff(chains_df$tot) / diff(seq_len(nrow(chains_df))) # first derivative abs(d1) %>% order() %>% .[1] # Find derivative == 0 - - + + } @@ -507,4 +494,4 @@ variational_fx <- function(model, ...) { generate_quantities_fx <- function(model, ...) { model$generate_quantities(...) -} +} \ No newline at end of file From e39c86d396dafdad5fcc78a383d421c5e3d37b65 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Wed, 8 Apr 2026 13:17:33 +0000 Subject: [PATCH 42/68] Add NULL check for fit attribute in incorporate_parameters_into_sccomp_object Agent-Logs-Url: https://github.com/MangiolaLaboratory/sccomp/sessions/30502755-e418-4530-a70a-caa943c78b62 Co-authored-by: stemangiola <7232890+stemangiola@users.noreply.github.com> --- R/utilities.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index 7d74f824..afa0e99d 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -163,6 +163,9 @@ incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c )) { fit <- attr(obj, "fit") + if (is.null(fit)) { + stop('expected a "fit" attribute on the sccomp object', call. = FALSE) + } attr(obj, "fit") <- incorporate_parameters_into_fit_object(fit, parameters_to_load) attr(obj, "sccomp_draws_incorporated_for_portability") <- TRUE obj From 96fafecf4a7a178273d70a2593842a5346758d96 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Wed, 8 Apr 2026 22:47:39 +0930 Subject: [PATCH 43/68] Remove deprecated scatterplot function and its documentation from plot.R This commit eliminates the `plot_scatterplot` function and its associated documentation, streamlining the codebase by removing unused components. The changes enhance clarity and maintainability of the plotting functions in the R package. --- R/plot.R | 184 ------------------------------------------------------- 1 file changed, 184 deletions(-) diff --git a/R/plot.R b/R/plot.R index 8570b411..3e6a8f5c 100644 --- a/R/plot.R +++ b/R/plot.R @@ -164,187 +164,3 @@ plot.sccomp_tbl <- function( plots } - -#' Plot Scatterplot of Cell-group Proportion -#' -#' This function creates a scatterplot of cell-group proportions, optionally -#' highlighting significant differences based on a given significance threshold. -#' -#' @param .data Data frame containing the main data. -#' @param data_proportion Data frame containing proportions of cell groups. -#' @param factor_of_interest A factor indicating the biological condition of interest. -#' @param significance_threshold Numeric value specifying the significance threshold -#' for highlighting differences. Default is 0.05. -#' @param my_theme A ggplot2 theme object to be applied to the plot. -#' @importFrom scales trans_new -#' @importFrom stringr str_replace str_detect -#' -#' @return A ggplot object representing the scatterplot. -#' -#' @noRd -plot_scatterplot = function( - .data, data_proportion, factor_of_interest, - significance_threshold = 0.05, my_theme -){ - - # Define the variables as NULL to avoid CRAN NOTES - stats_name <- NULL - parameter <- NULL - stats_value <- NULL - count_data <- NULL - generated_proportions <- NULL - proportion <- NULL - name <- NULL - outlier <- NULL - - # Function to remove leading zero from labels - dropLeadingZero <- function(l){ stringr::str_replace(l, '0(?=.)', '') } - - # Define square root transformation and its inverse - S_sqrt <- function(x){sign(x)*sqrt(abs(x))} - IS_sqrt <- function(x){x^2*sign(x)} - S_sqrt_trans <- function() scales::trans_new("S_sqrt",S_sqrt,IS_sqrt) - - .cell_group = attr(.data, ".cell_group") - .count = attr(.data, ".count") - .sample = attr(.data, ".sample") - - # Prepare significance colors - significance_colors = - .data %>% - pivot_longer( - c(contains("c_"), contains("v_")), - names_pattern = "([cv])_([a-zA-Z0-9]+)", - names_to = c("which", "stats_name"), - values_to = "stats_value" - ) %>% - filter(stats_name == "FDR") %>% - filter(parameter != "(Intercept)") %>% - filter(stats_value < significance_threshold) %>% - filter(`factor` == factor_of_interest) - - if(nrow(significance_colors) > 0){ - - if(.data |> attr("contrasts") |> is.null()) - significance_colors = - significance_colors %>% - unite("name", c(which, parameter), remove = FALSE) %>% - distinct() %>% - - # Get clean parameter - mutate(!!as.symbol(factor_of_interest) := str_replace(parameter, sprintf("^%s", `factor`), "")) %>% - with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) - else - significance_colors = - significance_colors |> - mutate( - factor_values = attr(.data, "count_data") |> - select(all_of(factor_of_interest)) |> - distinct() |> - pull(all_of(factor_of_interest)) - ) |> - unnest(factor_values) |> - - # Filter relevant parameters - mutate( !!as.symbol(factor_of_interest) := as.character(factor_values) ) |> - filter(str_detect(parameter, !!as.symbol(factor_of_interest) )) |> - - # Rename - select(!!.cell_group, !!as.symbol(factor_of_interest), name = parameter) |> - - # Merge contrasts - with_groups(c(!!.cell_group, !!as.symbol(factor_of_interest)), ~ .x %>% summarise(name = paste(name, collapse = ", "))) - } - - my_scatterplot = ggplot() - - if("fit" %in% names(attributes(.data))){ - - simulated_proportion = - .data |> - sccomp_replicate(number_of_draws = 1000) |> - left_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.sample, !!.cell_group)) - - my_scatterplot = - my_scatterplot + - - # Add smoothed line for simulated proportions - geom_smooth( - aes(!!as.symbol(factor_of_interest), (generated_proportions)), - lwd=0.2, - data = - simulated_proportion %>% - inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group, !!.sample)) , - color="blue", fill="blue", - span = 1 - ) - } - - if( - nrow(significance_colors)==0 || - - significance_colors |> - pull(!!as.symbol(factor_of_interest)) |> - intersect( - data_proportion |> - pull(!!as.symbol(factor_of_interest)) - ) |> - length() |> - equals(0) - ) { - - my_scatterplot= - my_scatterplot + - - # Add smoothed line without significance colors - geom_smooth( - aes(!!as.symbol(factor_of_interest), proportion, fill = NULL), - data = - data_proportion , - lwd=0.5, - color = "black", - span = 1 - ) - } else { - my_scatterplot= - my_scatterplot + - - # Add smoothed line with significance colors - geom_smooth( - aes(!!as.symbol(factor_of_interest), proportion, fill = name), - data = data_proportion , - fatten = 0.5, - lwd=0.5, - color = "black", - span = 1 - ) - } - - my_scatterplot + - - # Add jittered points for individual data - geom_point( - aes(!!as.symbol(factor_of_interest), proportion, shape=outlier, color=outlier), - data = data_proportion, - position=position_jitterdodge(jitter.height = 0, jitter.width = 0.2), - size = 0.5 - ) + - - # Facet wrap by cell group - facet_wrap( - vars(!!.cell_group), - scales = "free_y", - nrow = 4 - ) + - scale_color_manual(values = c("black", "#e11f28")) + - scale_y_continuous(trans=S_sqrt_trans(), labels = dropLeadingZero) + - scale_fill_discrete(na.value = "white") + - xlab("Biological condition") + - ylab("Cell-group proportion") + - guides(color="none", alpha="none", size="none") + - labs(fill="Significant difference") + - ggtitle("Note: Be careful judging significance (or outliers) visually for lowly abundant cell groups. \nVisualising proportion hides the uncertainty characteristic of count data, that a count-based statistical model can estimate.") + - my_theme + - theme(axis.text.x = element_text(angle=20, hjust = 1), title = element_text(size = 3)) -} - From 49e590b32cb10ec9e560ce7335de09e4c0a03b30 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Thu, 9 Apr 2026 01:46:38 +0000 Subject: [PATCH 44/68] Address review comments: imports, filter .env$, cat->message, !!.cell_group Agent-Logs-Url: https://github.com/MangiolaLaboratory/sccomp/sessions/910d9d09-b5f6-4da3-9037-a043b4832b71 Co-authored-by: stemangiola <7232890+stemangiola@users.noreply.github.com> --- R/sccomp_plot_intervals.R | 24 ++++++++++++------------ R/utilities.R | 4 ++-- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/R/sccomp_plot_intervals.R b/R/sccomp_plot_intervals.R index 076b3cab..decb8c09 100644 --- a/R/sccomp_plot_intervals.R +++ b/R/sccomp_plot_intervals.R @@ -11,7 +11,7 @@ #' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. #' @param sort_by Character vector indicating how to sort taxa. Options are "none" (default), "effect" (by effect size), "significance" (by FDR/pH0), or "alphabetical". #' @importFrom patchwork wrap_plots -#' @importFrom forcats fct_reorder +#' @importFrom forcats fct_reorder fct_inorder #' @importFrom tidyr drop_na #' #' @export @@ -288,13 +288,13 @@ sccomp_plot_intervals_2D <- function( ) }) - cat("=== Single Model Parameters ===\n") + message("=== Single Model Parameters ===") for(i in 1:length(params_list)) { p <- params_list[[i]] - cat(sprintf("\n%s:\n", p$parameter)) - cat(sprintf(" v = -(%.3f + %.3f × c)\n", p$intercept, p$slope)) + message(sprintf("\n%s:", p$parameter)) + message(sprintf(" v = -(%.3f + %.3f \u00d7 c)", p$intercept, p$slope)) } - cat("\n") + message("") } else { mix_p <- fit$summary("mix_p") |> pull(mean) @@ -312,14 +312,14 @@ sccomp_plot_intervals_2D <- function( ) }) - cat("=== Bimodal Model Parameters ===\n") + message("=== Bimodal Model Parameters ===") for(i in 1:length(params_list)) { p <- params_list[[i]] - cat(sprintf("\n%s:\n", p$parameter)) - cat(sprintf(" Component 1: v = -(%.3f + %.3f × c)\n", p$intercept_1, p$slope_1)) - cat(sprintf(" Component 2: v = -(%.3f + %.3f × c)\n", p$intercept_2, p$slope_2)) + message(sprintf("\n%s:", p$parameter)) + message(sprintf(" Component 1: v = -(%.3f + %.3f \u00d7 c)", p$intercept_1, p$slope_1)) + message(sprintf(" Component 2: v = -(%.3f + %.3f \u00d7 c)", p$intercept_2, p$slope_2)) } - cat("\n") + message("") } # v_effect already comes from alpha_normalised (computed in R from draws) @@ -393,7 +393,7 @@ sccomp_plot_intervals_2D <- function( row_number() <= 3 & c_FDR < significance_threshold & str_detect(parameter, ", adjusted$"), - !!sym(.cell_group), + !!.cell_group, "" ) ) @@ -408,7 +408,7 @@ sccomp_plot_intervals_2D <- function( v_FDR < significance_threshold & str_detect(parameter, ", adjusted$") & cell_type_label == "", - !!sym(.cell_group), + !!.cell_group, cell_type_label ) ) diff --git a/R/utilities.R b/R/utilities.R index afa0e99d..b8d77bd9 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -84,10 +84,10 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE if (keep_intercept) .data |> - filter(`factor` == factor | parameter == "(Intercept)") + filter(`factor` == .env$factor | parameter == "(Intercept)") else .data |> - filter(`factor` == factor) + filter(`factor` == .env$factor) } #' Incorporate all Stan model parameters into fit object From 66226bdf848c00ff22a4b0e9689c0ac117554bcb Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Thu, 9 Apr 2026 06:18:21 +0000 Subject: [PATCH 45/68] Use !!factor instead of .env$factor in subset_results_by_factor filter Agent-Logs-Url: https://github.com/MangiolaLaboratory/sccomp/sessions/8874427d-1d31-4bef-b1c5-2d97851aeef2 Co-authored-by: stemangiola <7232890+stemangiola@users.noreply.github.com> --- R/utilities.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utilities.R b/R/utilities.R index b8d77bd9..6f0a9c13 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -84,10 +84,10 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE if (keep_intercept) .data |> - filter(`factor` == .env$factor | parameter == "(Intercept)") + filter(`factor` == !!factor | parameter == "(Intercept)") else .data |> - filter(`factor` == .env$factor) + filter(`factor` == !!factor) } #' Incorporate all Stan model parameters into fit object From 3f85c28d952f2050d50cdd7ff0cc47f07d5c92b0 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 13 Apr 2026 12:35:17 +0930 Subject: [PATCH 46/68] Refactor Stan model parameters and likelihood calculations for improved numerical stability Fixed generation of quantities --- inst/stan/glm_multi_beta_binomial.stan | 5 ++++- ...glm_multi_beta_binomial_generate_data.stan | 22 ++++++++----------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index b2b26e32..ecf3acd0 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -360,7 +360,8 @@ parameters{ // Mean-variability slopes array[A] real prec_slope_1; // s1, always present array[A * bimodal_mean_variability_association] real prec_slope_2; // s2, only for bimodal - array[A] real prec_sd; // residual scale per effect for mean-variability association + // Log-scale residual SD avoids a hard boundary at 0 and reduces funnel neck pathologies. + array[A] real log_prec_sd; real mix_p; // Random intercept // array of sum_to_zero_vector for each random effect @@ -388,8 +389,10 @@ transformed parameters{ array[A] real prec_intercept_1; array[A * bimodal_mean_variability_association] real prec_intercept_2; + array[A] real prec_sd; // residual scale per effect for mean-variability association for (a in 1:A) { prec_intercept_1[a] = prec_intercept[a][1]; + prec_sd[a] = exp(log_prec_sd[a]); if (bimodal_mean_variability_association == 1) prec_intercept_2[a] = prec_intercept[a][2]; } diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 6a84b557..5c17ffa5 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -67,17 +67,17 @@ transformed data{ parameters { - array[C] vector[M] beta_raw; // Each row is a vector of length M + // Keep names/dimensions compatible with fitted draws, but avoid strict + // sum_to_zero validation when reading rounded CSVs in generated quantities. + array[C] vector[M] beta_raw; matrix[A, M] alpha; // Variability array[A] ordered[1 + bimodal_mean_variability_association] prec_intercept; array[A] real prec_slope_1; array[A * bimodal_mean_variability_association] real prec_slope_2; - array[A] real prec_sd; + array[A] real log_prec_sd; real mix_p; - // Random intercept // Using regular vectors instead of sum_to_zero_vector to avoid floating-point precision issues - // NOTE: Floating-point precision can cause sum_to_zero_vector to fail the strict sum-to-zero constraint - // We use regular vectors and apply the constraint manually where needed + // Random intercept array[ncol_X_random_eff[1] * (is_random_effect>0)] vector[M] random_effect_raw; array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] vector[M] random_effect_raw_2; @@ -120,13 +120,9 @@ generated quantities{ matrix[C,M] beta; - // Convert vectors to matrix and apply sum-to-zero constraint manually + // Convert vectors to matrix and enforce sum-to-zero numerically. for(c in 1:C) { - vector[M] temp_beta = beta_raw[c]; - // NOTE: Due to floating point precision, we must explicitly normalize to sum to zero - // instead of declating the sum_to_zero variabe - temp_beta = normalize_sum_to_zero(temp_beta); - beta[c,] = to_row_vector(temp_beta); + beta[c,] = to_row_vector(normalize_sum_to_zero(beta_raw[c])); } // Subset for mean and deviation @@ -188,7 +184,7 @@ generated quantities{ // For first random effect if(length_X_random_effect_which[1]>0) { - // Convert vector array and apply sum-to-zero constraint manually + // Convert vector array and enforce sum-to-zero numerically array[ncol_X_random_eff[1]] vector[M] random_effect_raw_vec; for(i in 1:ncol_X_random_eff[1]) { random_effect_raw_vec[i] = normalize_sum_to_zero(random_effect_raw[i]); @@ -229,7 +225,7 @@ generated quantities{ // For second random effect if(length_X_random_effect_which[2]>0) { - // Convert vector array and apply sum-to-zero constraint manually + // Convert vector array and enforce sum-to-zero numerically array[ncol_X_random_eff[2]] vector[M] random_effect_raw_2_vec; for(i in 1:ncol_X_random_eff[2]) { random_effect_raw_2_vec[i] = normalize_sum_to_zero(random_effect_raw_2[i]); From 733a94989b67e19291c68f83e041460a514faf1f Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 13 Apr 2026 12:42:04 +0930 Subject: [PATCH 47/68] Update Stan model to replace Student's t distribution with Normal distribution for likelihood calculations Refactor precision standard deviation handling by switching to log scale for improved numerical stability. This change enhances the model's performance and clarity in the likelihood computations. --- inst/stan/glm_multi_beta_binomial.stan | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index ecf3acd0..887c0833 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -31,24 +31,23 @@ functions{ ){ real lp = 0; - int nu = 3; // If mean-variability association is bimodal such as for single-cell RNA use mixed model if(bimodal_mean_variability_association == 1){ for(m in 1:cols(variability)) lp += log_mix(mix_p, - student_t_lpdf(variability[m] | nu, - abundance[m] * prec_slope_1 + prec_intercept_1, - prec_sd), - student_t_lpdf(variability[m] | nu, - abundance[m] * prec_slope_2 + prec_intercept_2, - prec_sd) + normal_lpdf(variability[m] | + abundance[m] * prec_slope_1 + prec_intercept_1, + prec_sd), + normal_lpdf(variability[m] | + abundance[m] * prec_slope_2 + prec_intercept_2, + prec_sd) ); // If no bimodal } else { - lp = student_t_lpdf(variability | nu, - abundance * prec_slope_1 + prec_intercept_1, - prec_sd); + lp = normal_lpdf(variability | + abundance * prec_slope_1 + prec_intercept_1, + prec_sd); } return(lp); @@ -569,7 +568,7 @@ model{ prec_slope_2[a] ~ student_t(3, 0, 2); // s2 } } - for(a in 1:A) prec_sd[a] ~ normal(0, 1) T[0,]; + for(a in 1:A) log_prec_sd[a] ~ normal(1, 0.5); // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); From 25ff71d31689a1fa3442835a8e213254f12d1f46 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 15:23:56 +0930 Subject: [PATCH 48/68] Add precision parameters to incorporate_parameters_into_sccomp_object function This update includes the addition of 'prec_intercept' and 'log_prec_sd' to the parameters block, enhancing the model's capability to handle precision-related computations more effectively. --- R/utilities.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/utilities.R b/R/utilities.R index 6f0a9c13..da3c21c1 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -141,6 +141,8 @@ incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c # Parameters block "beta_raw", "alpha", + "prec_intercept", + "log_prec_sd", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", From c3e0a0b871d9222ba9f5d3e5c3087d41eb223596 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 16:38:06 +0930 Subject: [PATCH 49/68] Bug fix Refactor factor parameter dictionary handling in sccomp_test.R and utilities.R This update simplifies the initialization of the factor parameter dictionary by removing unnecessary conditional checks and ensures consistent usage of column names in the data processing functions. Additionally, it enhances clarity in the handling of design columns and improves the extraction of unique parameters and variables from subsets. --- R/sccomp_test.R | 26 +++++++++++--------------- R/utilities.R | 3 ++- 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 4c14fc2a..70dea1ce 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -375,19 +375,13 @@ sccomp_summarise_posterior_for_estimate <- function( ) |> dplyr::rename(v_lower = v_upper, v_upper = v_lower) - if (!"factor" %in% colnames(model_input$factor_parameter_dictionary)) { - factor_parameter_dictionary <- - tibble::tibble(`factor` = character(), design_matrix_col = character()) - } else { - factor_parameter_dictionary <- - model_input$factor_parameter_dictionary |> - dplyr::select(`factor`, design_matrix_col) - } + factor_parameter_dictionary <- + model_input$factor_parameter_dictionary |> + dplyr::select(`factor`, design_matrix_col) result <- abundance |> dplyr::left_join(variability, by = c(cg, "M", "parameter")) |> - suppressMessages() |> dplyr::left_join( factor_parameter_dictionary, by = c("parameter" = "design_matrix_col") @@ -451,6 +445,8 @@ sccomp_identify_covariate_contrasts <- function(contrasts, model_input) { #' @keywords internal #' @noRd build_stan_parameter_subset <- function(contrasts, design_columns, stan_parameter, model_input) { + design_columns <- as.character(design_columns) + if (is.null(contrasts)) { return( tibble::tibble( @@ -519,8 +515,8 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ stan_parameter = "beta", model_input = model_input ) - beta_parameters <- beta_subset |> dplyr::pull(parameter) |> unique() - beta_variable_subset <- beta_subset |> dplyr::pull(variable) |> unique() + beta_parameters <- beta_subset |> dplyr::pull("parameter") |> unique() + beta_variable_subset <- beta_subset |> dplyr::pull("variable") |> unique() draws = @@ -546,8 +542,8 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ stan_parameter = "random_effect", model_input = model_input ) - beta_random_effect_parameters <- beta_random_effect_subset |> dplyr::pull(parameter) |> unique() - beta_random_effect_variables <- beta_random_effect_subset |> dplyr::pull(variable) |> unique() + beta_random_effect_parameters <- beta_random_effect_subset |> dplyr::pull("parameter") |> unique() + beta_random_effect_variables <- beta_random_effect_subset |> dplyr::pull("variable") |> unique() if( .data |> attr("model_input") %$% n_random_eff > 0 && @@ -615,8 +611,8 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ stan_parameter = "random_effect_2", model_input = model_input ) - beta_random_effect_parameters_2 <- beta_random_effect_subset_2 |> dplyr::pull(parameter) |> unique() - beta_random_effect_variables_2 <- beta_random_effect_subset_2 |> dplyr::pull(variable) |> unique() + beta_random_effect_parameters_2 <- beta_random_effect_subset_2 |> dplyr::pull("parameter") |> unique() + beta_random_effect_variables_2 <- beta_random_effect_subset_2 |> dplyr::pull("variable") |> unique() if( .data |> attr("model_input") %$% n_random_eff > 1 && diff --git a/R/utilities.R b/R/utilities.R index da3c21c1..e734c20b 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -1220,7 +1220,8 @@ data_spread_to_model_input = data_for_model$TNIM = 0 # Add parameter factor dictionary - data_for_model$factor_parameter_dictionary = tibble() + data_for_model$factor_parameter_dictionary = + tibble(`factor` = character(), design_matrix_col = character()) if(.data_spread |> select(any_of(parse_formula(formula))) |> lapply(class) %in% c("factor", "character") |> any()) data_for_model$factor_parameter_dictionary = From a52992129910f908f2199d5753fdea7ca90db264 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 17:49:11 +0930 Subject: [PATCH 50/68] Add ggside package support and new omit_ci parameter for interval plots This update introduces the ggside package for enhanced plotting capabilities, allowing for side density plots in 2D interval visualizations. Additionally, a new parameter, omit_ci, has been added to the sccomp_plot_intervals_2D and plot.sccomp_tbl functions, enabling users to omit credible interval error bars from the plots. Documentation has been updated accordingly, and tests have been added to ensure functionality with the new features. --- DESCRIPTION | 1 + NAMESPACE | 15 +- R/plot.R | 5 +- R/sccomp_plot_intervals.R | 480 +++++++++++++++----------------- man/plot.sccomp_tbl.Rd | 3 + man/sccomp_plot_intervals_2D.Rd | 5 +- tests/testthat/test-plot.R | 112 +++++++- 7 files changed, 360 insertions(+), 261 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 06391fee..00b23467 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,6 +30,7 @@ Imports: tibble, ggplot2, ggrepel, + ggside, patchwork, forcats, readr, diff --git a/NAMESPACE b/NAMESPACE index 278225e4..7354520f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -69,14 +69,15 @@ importFrom(dplyr,slice) importFrom(dplyr,summarise) importFrom(dplyr,where) importFrom(dplyr,with_groups) +importFrom(forcats,fct_inorder) importFrom(forcats,fct_relevel) importFrom(forcats,fct_reorder) importFrom(ggplot2,aes) -importFrom(ggplot2,coord_flip) +importFrom(ggplot2,element_blank) importFrom(ggplot2,element_rect) importFrom(ggplot2,element_text) importFrom(ggplot2,facet_wrap) -importFrom(ggplot2,geom_area) +importFrom(ggplot2,geom_blank) importFrom(ggplot2,geom_errorbar) importFrom(ggplot2,geom_hline) importFrom(ggplot2,geom_line) @@ -86,15 +87,17 @@ importFrom(ggplot2,ggplot) importFrom(ggplot2,guide_legend) importFrom(ggplot2,guides) importFrom(ggplot2,labs) -importFrom(ggplot2,margin) importFrom(ggplot2,scale_alpha_manual) importFrom(ggplot2,scale_color_manual) importFrom(ggplot2,scale_fill_manual) -importFrom(ggplot2,scale_y_continuous) importFrom(ggplot2,theme) importFrom(ggplot2,theme_bw) -importFrom(ggplot2,theme_void) +importFrom(ggplot2,xlab) +importFrom(ggplot2,ylab) importFrom(ggrepel,geom_text_repel) +importFrom(ggside,geom_ysidedensity) +importFrom(ggside,scale_ysidex_continuous) +importFrom(ggside,theme_ggside_void) importFrom(glue,glue) importFrom(instantiate,stan_cmdstan_exists) importFrom(instantiate,stan_package_compile) @@ -110,8 +113,6 @@ importFrom(magrittr,multiply_by) importFrom(magrittr,not) importFrom(magrittr,subtract) importFrom(parallel,detectCores) -importFrom(patchwork,plot_annotation) -importFrom(patchwork,plot_layout) importFrom(patchwork,wrap_plots) importFrom(posterior,as_draws_df) importFrom(posterior,ess_bulk) diff --git a/R/plot.R b/R/plot.R index 3e6a8f5c..0e7bbeb1 100644 --- a/R/plot.R +++ b/R/plot.R @@ -11,6 +11,7 @@ #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". #' @param show_fdr_message Logical. Whether to show the Bayesian FDR interpretation message on the plot. Default is TRUE. #' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels in 2D intervals. Default is TRUE. +#' @param omit_ci Logical. Whether to omit credible interval error bars from 2D interval plots. Default is FALSE. #' @param ... For internal use #' #' @return A list containing ggplot objects @@ -48,6 +49,7 @@ plot.sccomp_tbl <- function( significance_statistic = c("pH0", "FDR"), show_fdr_message = TRUE, add_marginal_density = TRUE, + omit_ci = FALSE, sort_by = c("none", "effect", "significance", "alphabetical"), ... ) { @@ -157,7 +159,8 @@ plot.sccomp_tbl <- function( test_composition_above_logit_fold_change = test_composition_above_logit_fold_change, significance_statistic = significance_statistic, show_fdr_message = show_fdr_message, - add_marginal_density = add_marginal_density + add_marginal_density = add_marginal_density, + omit_ci = omit_ci ) } diff --git a/R/sccomp_plot_intervals.R b/R/sccomp_plot_intervals.R index decb8c09..1a3fc784 100644 --- a/R/sccomp_plot_intervals.R +++ b/R/sccomp_plot_intervals.R @@ -170,12 +170,13 @@ sccomp_plot_intervals_1D = function( #' @param significance_statistic Character vector indicating which statistic to highlight. Default is "pH0". #' @param factor Optional character string selecting one model factor to plot. If provided, plots are restricted to that factor plus `(Intercept)`. #' @param add_marginal_density Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE. +#' @param omit_ci Logical. Whether to omit credible interval error bars. Default is FALSE. #' #' @importFrom dplyr filter arrange mutate if_else row_number bind_rows distinct slice pull with_groups -#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point geom_line geom_area aes facet_wrap theme_bw theme labs guides guide_legend scale_color_manual scale_alpha_manual scale_fill_manual scale_y_continuous coord_flip theme_void element_rect element_text margin +#' @importFrom ggplot2 ggplot geom_vline geom_hline geom_errorbar geom_point geom_line geom_blank aes xlab ylab facet_wrap theme_bw theme labs guides guide_legend scale_color_manual scale_alpha_manual scale_fill_manual element_rect element_blank element_text #' @importFrom ggrepel geom_text_repel #' @importFrom stringr str_detect -#' @importFrom patchwork plot_annotation wrap_plots plot_layout +#' @importFrom ggside geom_ysidedensity theme_ggside_void scale_ysidex_continuous #' #' @export #' @@ -215,12 +216,14 @@ sccomp_plot_intervals_2D <- function( .data |> attr("test_composition_above_logit_fold_change"), show_fdr_message = TRUE, significance_statistic = c("pH0", "FDR"), - add_marginal_density = TRUE + add_marginal_density = TRUE, + omit_ci = FALSE ) { significance_statistic <- match.arg(significance_statistic) - # Define variables to avoid CRAN NOTES + # Locals declared as NULL to silence R CMD check NOTEs about "no visible binding" + # for tidyverse NSE references (dplyr/ggplot evaluate these as column names). v_effect <- NULL parameter <- NULL c_effect <- NULL @@ -237,46 +240,52 @@ sccomp_plot_intervals_2D <- function( v_pH0 <- NULL component <- NULL assigned_component <- NULL + v_value <- NULL .cell_group <- attr(.data, ".cell_group") - # Check if test has been done + # The plot relies on FDR / pH0 columns that only exist after sccomp_test(); + # fail fast with a user-meaningful message rather than later with a cryptic NSE error. if(.data |> select(ends_with("FDR")) |> ncol() == 0) stop("sccomp says: you need to run sccomp_test() first.") + # Intercept is kept even when subsetting to a single factor because the Intercept + # panel acts as the visual baseline against which factor-specific effects are read. .data <- subset_results_by_factor(.data, factor, keep_intercept = TRUE) - # Extract fitted model and mean-variability regression coefficients fit <- attr(.data, "fit") + + # Determine model topology *before* pulling Stan summaries: `prec_*_2` variables + # are only declared in the bimodal Stan program, so blindly requesting them + # would error on single-component fits. + bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association + # no check needed; bimodal_flag should always be present + bimodal_flag <- isTRUE(as.logical(bimodal_flag)) + + # Posterior summaries of the mean-variability regression coefficients + # v_pred = -(prec_intercept + prec_slope * c_effect) + # These are pulled once and reused per-parameter via `param_idx`. prec_intercept_1_summary <- fit$summary("prec_intercept_1") prec_slope_1_summary <- fit$summary("prec_slope_1") - prec_intercept_2_summary <- tryCatch( - fit$summary("prec_intercept_2"), - error = function(e) tibble() - ) - prec_slope_2_summary <- tryCatch( - fit$summary("prec_slope_2"), - error = function(e) tibble() - ) + # Only parameters that actually have a v_effect (i.e. are estimated under the + # variability design Xa) can be plotted on the 2D space. param_names <- .data |> filter(!is.na(v_effect)) |> distinct(parameter) |> - pull(parameter) + pull("parameter") + # Map each parameter name to its column index in the variability design matrix + # `Xa` because Stan stores `prec_*` indexed by Xa column position, not by name. param_idx <- match(param_names, colnames(attr(.data, "model_input")$Xa)) if (any(is.na(param_idx))) { stop("sccomp says: could not map selected parameters to model coefficients.") } - # Derive model type from stored model metadata - bimodal_flag <- attr(.data, "model_input")$bimodal_mean_variability_association - if (is.null(bimodal_flag)) { - stop("sccomp says: cannot infer model type because `bimodal_mean_variability_association` is missing from model metadata.") - } - bimodal_flag <- isTRUE(as.logical(bimodal_flag)) - - # Extract parameters based on model type + # `params_list` flattens the Stan posterior summaries into one entry per parameter, + # carrying only the scalars (`intercept`, `slope`, or per-component variants) + # required by downstream geometry, so the heavy `fit$summary` tibbles are not + # re-scanned inside per-row mutate() / lapply() calls. if (!bimodal_flag) { params_list <- lapply(seq_along(param_names), function(a) { param_name <- param_names[a] @@ -288,6 +297,8 @@ sccomp_plot_intervals_2D <- function( ) }) + # Print the fitted lines so users can sanity-check the regression underlying + # the visual adjustment (especially useful when comparing across fits). message("=== Single Model Parameters ===") for(i in 1:length(params_list)) { p <- params_list[[i]] @@ -297,6 +308,10 @@ sccomp_plot_intervals_2D <- function( message("") } else { + prec_intercept_2_summary <- fit$summary("prec_intercept_2") + prec_slope_2_summary <- fit$summary("prec_slope_2") + # `mix_p` is the posterior mixing weight of component 1; reported in the + # caption so users can judge which component dominates the population. mix_p <- fit$summary("mix_p") |> pull(mean) params_list <- lapply(seq_along(param_names), function(a) { @@ -322,10 +337,15 @@ sccomp_plot_intervals_2D <- function( message("") } - # v_effect already comes from alpha_normalised (computed in R from draws) - # "raw" panel: ADD BACK entanglement to show raw alpha - # "adjusted" panel: USE v_effect AS-IS - + # The 2D plot juxtaposes two views of v_effect for each parameter: + # - "raw": v_effect with the mean-variability association reintroduced, + # i.e. the data as it would look *without* the model's correction; + # the fitted regression line should pass through this cloud. + # - "adjusted": v_effect with the association removed (what sccomp uses for + # inference). Cells off-axis here are the genuine outliers. + # Since `.data$v_effect` is already the adjusted form (it comes from the + # `alpha_normalised` draws), we *reverse the adjustment* to construct "raw" + # and we use v_effect verbatim for "adjusted". if (!bimodal_flag) { .data_raw_list <- lapply(params_list, function(params) { .data %>% @@ -338,6 +358,13 @@ sccomp_plot_intervals_2D <- function( ) }) } else { + # Bimodal case: each cell type's "raw" position is generated by *one* of the + # two mixture components, but the latent assignment is not directly observed. + # We hard-assign by nearest predicted v_effect (smallest residual against + # each component's regression line), then reverse the adjustment using only + # that component's slope. This produces a visually coherent "raw" scatter + # in which each point lies near its parent regression line rather than at + # an arbitrary average of the two. .data_raw_list <- lapply(params_list, function(params) { .data %>% filter(parameter == params$parameter) %>% @@ -363,7 +390,8 @@ sccomp_plot_intervals_2D <- function( .data_raw <- bind_rows(.data_raw_list) - # Adjusted panel: v_effect as-is (already from alpha_normalised) + # "adjusted" rows are the original v_effect, only the parameter label changes + # so facet_wrap can place them in a separate panel. .data_adjusted_list <- lapply(params_list, function(params) { .data %>% filter(parameter == params$parameter) %>% @@ -373,7 +401,10 @@ sccomp_plot_intervals_2D <- function( .data_plot <- bind_rows(.data_raw, .data_adjusted) - # Set parameter factor levels + # Interleave "raw" before "adjusted" for each parameter so the facets read + # left-to-right as "before -> after the model's adjustment". param_order is + # also reused by the helper to ensure stable panel order across patchwork and + # facet_wrap callers. param_order <- c() for(p in params_list) { param_order <- c(param_order, paste0(p$parameter, ", raw"), paste0(p$parameter, ", adjusted")) @@ -381,7 +412,12 @@ sccomp_plot_intervals_2D <- function( .data_plot$parameter <- factor(.data_plot$parameter, levels = param_order) - # Add labels for significant cell groups + # Label only the top-3 cell groups by significance per panel, and only in + # ", adjusted" panels because the "raw" panel is meant to show the underlying + # association (labels there would clutter without adding analytical value). + # Two sequential passes — first by c_FDR (abundance), then by v_FDR + # (variability) — guarantee a cell is labeled if it is significant on + # *either* axis, while preserving the abundance label when both apply. .data_plot <- .data_plot %>% filter(!is.na(v_effect)) %>% with_groups( @@ -414,7 +450,11 @@ sccomp_plot_intervals_2D <- function( ) ) - # Choose color aesthetics based on significance statistic + # Encode significance in the errorbar aesthetics so the plot is readable + # without consulting the underlying table. Significance is only meaningful on + # ", adjusted" panels — raw panels are unconditionally desaturated to convey + # "descriptive, not inferential". FDR (Stephens) uses red, pH0 (posterior + # tail probability) uses blue, mirroring their distinct meanings. if (significance_statistic == "FDR") { color_c_aes <- aes( xmin = c_lower, xmax = c_upper, @@ -481,6 +521,8 @@ sccomp_plot_intervals_2D <- function( }) %>% bind_rows() } else { + # Bimodal: two regression lines and two horizontal references per panel. + # The `component` column lets the plot helper colour them distinctly. regression_data_all <- lapply(params_list, function(params) { raw_param <- paste0(params$parameter, ", raw") param_data <- .data_plot %>% filter(parameter == raw_param) @@ -521,7 +563,9 @@ sccomp_plot_intervals_2D <- function( }) %>% bind_rows() } - # Add caption based on model type + # Caption is reserved for FDR mode: users that opt into FDR-based inference + # benefit from the explicit citation/interpretation reminder; pH0 users are + # assumed to already understand the posterior-tail interpretation. if (significance_statistic == "FDR" && show_fdr_message) { if (!bimodal_flag) { caption_text <- paste( @@ -546,203 +590,37 @@ sccomp_plot_intervals_2D <- function( caption_text <- NULL } - # Add marginal density plots if requested - if (add_marginal_density) { - - plot_list <- lapply(param_order, function(param) { - - param_data <- .data_plot %>% filter(parameter == param) - if(nrow(param_data) == 0) return(NULL) - - # Create main plot - p_param <- ggplot(param_data, aes(c_effect, v_effect)) + - geom_vline( - xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) + - geom_hline( - yintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), - colour = "grey", linetype = "dashed", linewidth = 0.3 - ) - - # Add regression lines - if (!bimodal_flag) { - reg_data <- regression_data_all %>% filter(parameter == param) - if(!is.null(reg_data) && nrow(reg_data) > 0) { - p_param <- p_param + - geom_line(data = reg_data, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - - adj_line <- adjusted_lines_all %>% filter(parameter == param) - if(!is.null(adj_line) && nrow(adj_line) > 0) { - p_param <- p_param + - geom_line(data = adj_line, mapping = aes(c_effect, v_effect), - color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) - } - - } else { - reg_data <- regression_data_all %>% filter(parameter == param) - if(!is.null(reg_data) && nrow(reg_data) > 0) { - p_param <- p_param + - geom_line(data = reg_data %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = reg_data %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - - adj_line <- adjusted_lines_all %>% filter(parameter == param) - if(!is.null(adj_line) && nrow(adj_line) > 0) { - p_param <- p_param + - geom_line(data = adj_line %>% filter(component == "Component 1"), - mapping = aes(c_effect, v_effect), color = "#0072B2", - linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = adj_line %>% filter(component == "Component 2"), - mapping = aes(c_effect, v_effect), color = "#D55E00", - linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) - } - } - - # Add error bars, points, and labels - p_param <- p_param + - geom_errorbar(color_c_aes, linewidth = 0.2) + - geom_errorbar(color_v_aes, linewidth = 0.2) + - geom_point(size = 0.2) + - geom_text_repel( - aes(c_effect, -v_effect, label = cell_type_label), - size = 2.5, - data = param_data %>% filter(cell_type_label != ""), - max.overlaps = 20 - ) + - color_scale + - alpha_scale + - xlab("c_effect (Abundance effect)") + - ylab("v_effect (Variability effect)") + - ggtitle(param) + - theme_bw() + - theme( - legend.position = "bottom", - strip.background = element_rect(fill = "white"), - panel.grid.minor = element_blank() - ) + - guides(color = guide_legend(title = legend_title), alpha = "none") - - # Add marginal density for adjusted panels (not Intercept) - if (str_detect(param, ", adjusted$") && !str_detect(param, "Intercept")) { - - if (!bimodal_flag) { - param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) - - if (length(param_idx) > 0) { - intercept_var_name <- paste0("prec_intercept_1[", param_idx, "]") - - tryCatch({ - intercept_draws <- fit$draws(variables = intercept_var_name, format = "draws_df") - intercept_values <- as.vector(intercept_draws[[intercept_var_name]]) - - dens <- density(-intercept_values, na.rm = TRUE) - dens_df <- data.frame(x = dens$x, y = dens$y) - - - y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range - - p_density <- ggplot(dens_df, aes(x = x, y = y)) + - geom_area(alpha = 0.5, position = "identity") + - geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + - coord_flip(xlim = y_range) + - scale_y_continuous(expand = c(0, 0)) + - xlab("Posterior Probability") + - theme_void() + - theme( - plot.margin = margin(t = 0, r = 0, b = 0, l = 6), - axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) - ) - - p_combined <- p_param + p_density + - plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & - theme(legend.position = "bottom") - - return(p_combined) - }, error = function(e) { - warning(sprintf("Could not extract intercept draws for %s: %s", intercept_var_name, e$message)) - return(p_param) - }) - } - - } else { - param_idx <- which(sapply(params_list, function(p) paste0(p$parameter, ", adjusted") == param)) - - if (length(param_idx) > 0) { - intercept1_var_name <- paste0("prec_intercept_1[", param_idx, "]") - intercept2_var_name <- paste0("prec_intercept_2[", param_idx, "]") - - tryCatch({ - intercept1_draws <- fit$draws(variables = intercept1_var_name, format = "draws_df") - intercept2_draws <- fit$draws(variables = intercept2_var_name, format = "draws_df") - - intercept1_values <- as.vector(intercept1_draws[[intercept1_var_name]]) - intercept2_values <- as.vector(intercept2_draws[[intercept2_var_name]]) - - dens1 <- density(-intercept1_values, na.rm = TRUE) - dens2 <- density(-intercept2_values, na.rm = TRUE) - - dens_df <- bind_rows( - data.frame(x = dens1$x, y = dens1$y, component = "Component 1"), - data.frame(x = dens2$x, y = dens2$y, component = "Component 2") - ) - - - y_range <- ggplot_build(p_param)$layout$panel_params[[1]]$y.range - - p_density <- ggplot(dens_df, aes(x = x, y = y, fill = component)) + - geom_area(alpha = 0.5, position = "identity") + - geom_vline(xintercept = 0, linetype = "dashed", color = "black", linewidth = 0.3) + - scale_fill_manual(values = c("Component 1" = "#0072B2", "Component 2" = "#D55E00")) + - coord_flip(xlim = y_range) + - scale_y_continuous(expand = c(0, 0)) + - xlab("Posterior Probability") + - theme_void() + - theme( - plot.margin = margin(t = 0, r = 0, b = 0, l = 5), - legend.position = "none", - axis.title.y = element_text(angle = 90, size = 7, vjust = 0.5) - ) - - p_combined <- p_param + p_density + - plot_layout(ncol = 2, widths = c(5, 0.6), guides = "collect") & - theme(legend.position = "bottom") - - return(p_combined) - }, error = function(e) { - warning(sprintf("Could not extract intercept draws: %s", e$message)) - return(p_param) - }) - } - } - } - - return(p_param) - }) - - - plot_list <- plot_list[!sapply(plot_list, is.null)] - combined_plot <- patchwork::wrap_plots(plot_list, ncol = 2) + # Both modes (with and without marginal density) produce a single faceted plot; the only difference is + # whether ggside's y-side area layer is added on top. We rely on ggside + # rather than patchwork-of-per-panel-plots so axis titles are not duplicated + # and panel widths stay grid-aligned. + build_2d_interval_plot <- function(plot_data, regression_data, adjusted_lines, density_data = NULL) { + + # Force the canonical factor order on every input: the data preparation + # above does it on `.data_plot`, but `regression_data` / `adjusted_lines` / + # `density_data` come from separate pipelines and must agree on level order + # for facet_wrap to keep panels in sync. + plot_data <- plot_data %>% + mutate(parameter = factor(as.character(parameter), levels = param_order)) + + if (!is.null(regression_data) && nrow(regression_data) > 0) { + regression_data <- regression_data %>% + mutate(parameter = factor(as.character(parameter), levels = param_order)) + } - if (!is.null(caption_text)) { - combined_plot <- combined_plot + - plot_annotation( - caption = caption_text, - theme = theme(plot.caption = element_text(hjust = 0, size = 9)) - ) + if (!is.null(adjusted_lines) && nrow(adjusted_lines) > 0) { + adjusted_lines <- adjusted_lines %>% + mutate(parameter = factor(as.character(parameter), levels = param_order)) } - return(combined_plot) + if (!is.null(density_data) && nrow(density_data) > 0) { + density_data <- density_data %>% + mutate(parameter = factor(as.character(parameter), levels = param_order)) + } - } else { - # Return faceted plot without marginal densities - p <- ggplot(.data_plot, aes(c_effect, v_effect)) + + # Decision boundary at ± test_composition_above_logit_fold_change: cells + # outside this box are the only ones a hypothesis test could call significant. + p <- ggplot(plot_data, aes(c_effect, v_effect)) + geom_vline( xintercept = c(-test_composition_above_logit_fold_change, test_composition_above_logit_fold_change), colour = "grey", linetype = "dashed", linewidth = 0.3 @@ -752,50 +630,73 @@ sccomp_plot_intervals_2D <- function( colour = "grey", linetype = "dashed", linewidth = 0.3 ) - # Add regression lines + # Regression / reference lines. + # `inherit.aes = FALSE` shields these geoms from the top-level + # aes(c_effect, v_effect) mapping so the lines use their own data verbatim + # — important because their tibbles have a different row schema (no CI + # columns, no cell_group, etc.) than `plot_data`. + # In bimodal mode the two components get distinct visual treatment so the + # eye can separate them without consulting the caption. if (!bimodal_flag) { - if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { - p <- p + geom_line(data = regression_data_all, mapping = aes(c_effect, v_effect), + if(!is.null(regression_data) && nrow(regression_data) > 0) { + p <- p + geom_line(data = regression_data, mapping = aes(c_effect, v_effect), color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) } - if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { - p <- p + geom_line(data = adjusted_lines_all, mapping = aes(c_effect, v_effect), + if(!is.null(adjusted_lines) && nrow(adjusted_lines) > 0) { + p <- p + geom_line(data = adjusted_lines, mapping = aes(c_effect, v_effect), color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) } } else { - if(!is.null(regression_data_all) && nrow(regression_data_all) > 0) { + if(!is.null(regression_data) && nrow(regression_data) > 0) { p <- p + - geom_line(data = regression_data_all %>% filter(component == "Component 1"), + geom_line(data = regression_data %>% filter(component == "Component 1"), mapping = aes(c_effect, v_effect), color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = regression_data_all %>% filter(component == "Component 2"), + geom_line(data = regression_data %>% filter(component == "Component 2"), mapping = aes(c_effect, v_effect), color = "#D55E00", linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) } - if(!is.null(adjusted_lines_all) && nrow(adjusted_lines_all) > 0) { + if(!is.null(adjusted_lines) && nrow(adjusted_lines) > 0) { p <- p + - geom_line(data = adjusted_lines_all %>% filter(component == "Component 1"), + geom_line(data = adjusted_lines %>% filter(component == "Component 1"), mapping = aes(c_effect, v_effect), color = "#0072B2", linewidth = 0.5, alpha = 0.8, inherit.aes = FALSE) + - geom_line(data = adjusted_lines_all %>% filter(component == "Component 2"), + geom_line(data = adjusted_lines %>% filter(component == "Component 2"), mapping = aes(c_effect, v_effect), color = "#D55E00", linewidth = 0.5, alpha = 0.8, linetype = "dashed", inherit.aes = FALSE) } } + # Credible intervals. When omitted, we substitute invisible `geom_blank` + # layers at the CI bounds so the plot's coordinate system is still trained + # by the same data range — keeping axes identical whether errorbars are + # drawn or not (otherwise the no-CI plot would zoom in onto just the points). + if (!omit_ci) { + p <- p + + geom_errorbar(color_c_aes, linewidth = 0.2) + + geom_errorbar(color_v_aes, linewidth = 0.2) + + color_scale + + alpha_scale + + guides(color = guide_legend(title = legend_title), alpha = "none") + } else { + p <- p + + geom_blank(aes(x = c_lower, y = v_lower)) + + geom_blank(aes(x = c_upper, y = v_upper)) + } + + # Points are drawn *after* the errorbars/lines so they sit on top and + # remain readable when CIs overlap; labels go last for highest z-order. + # Note `geom_text_repel` uses `-v_effect` (y-axis flip) because labels are + # placed relative to the inverted visual reading where higher v means + # higher dispersion — this matches users' mental model of "outlier upward". p <- p + - geom_errorbar(color_c_aes, linewidth = 0.2) + - geom_errorbar(color_v_aes, linewidth = 0.2) + geom_point(size = 0.2) + geom_text_repel( aes(c_effect, -v_effect, label = cell_type_label), size = 2.5, - data = .data_plot %>% filter(cell_type_label != ""), + data = plot_data %>% filter(cell_type_label != ""), max.overlaps = 20 ) + - color_scale + - alpha_scale + - facet_wrap(~ parameter, scales = "free", ncol = 2) + xlab("c_effect (Abundance effect)") + ylab("v_effect (Variability effect)") + theme_bw() + @@ -803,17 +704,100 @@ sccomp_plot_intervals_2D <- function( legend.position = "bottom", strip.background = element_rect(fill = "white"), panel.grid.minor = element_blank() - ) + - guides(color = guide_legend(title = legend_title), alpha = "none") + ) - if (!is.null(caption_text)) { + # Marginal posterior densities, drawn via ggside so they participate in the + # same facet system as the main scatter (no patchwork → no duplicated axis + # titles, no panel-width misalignment). We pass raw posterior draws (one + # row per draw, with `parameter` set to the panel they belong to) and let + # `geom_ysidedensity` compute the kernel density per facet. ggside lays + # the result on the y-side, mapping the data's `y` aesthetic to the main + # panel's y-axis. `scales = "free"` propagates so each panel's density + # rescales to fit its own y-range. + if (!is.null(density_data) && nrow(density_data) > 0) { + density_aes <- if (bimodal_flag) { + aes(y = v_value, fill = component) + } else { + aes(y = v_value) + } p <- p + - theme(plot.caption = element_text(hjust = 0, size = 9)) + - labs(caption = caption_text) + geom_ysidedensity( + data = density_data, + mapping = density_aes, + alpha = 0.5, + position = "identity", + inherit.aes = FALSE + ) + + # Drop ggside's own axis decorations: the density value axis is + # uninformative on its own (relative scale per panel) and would + # otherwise clutter the strip. + theme_ggside_void() + + scale_ysidex_continuous(expand = c(0, 0)) + + if (bimodal_flag) { + p <- p + scale_fill_manual(values = c("Component 1" = "#0072B2", "Component 2" = "#D55E00")) + } } - return(p) + # `scales = "free"` is intentional: raw and adjusted panels live on + # different natural scales (raw v_effect can span much wider than adjusted + # residuals), and the same applies across parameters. + p + facet_wrap(~ parameter, scales = "free", ncol = 2) + } + + # Posterior draws of `-prec_intercept_*[param_idx]` for every parameter, + # replicated across both that parameter's facets (", raw" and ", adjusted"). + # The intercept density is a property of the parameter, not of the visual + # mode, so showing it on every facet is both honest and what ggside requires + # to attach a side layer per panel (omitting a facet's density would leave + # that side panel empty, breaking visual rhythm). + # The sign flip mirrors the parameterisation v = -(prec_intercept + slope·c) + # so the density lies on the same axis orientation as v_effect. We pass raw + # draws (not pre-computed densities) because ggside's density geom computes + # the kernel per facet itself. + density_data_all <- if (add_marginal_density) { + bind_rows(lapply(seq_along(param_names), function(i) { + param_name <- param_names[i] + idx <- param_idx[i] + + component_vars <- if (bimodal_flag) { + c("Component 1" = paste0("prec_intercept_1[", idx, "]"), + "Component 2" = paste0("prec_intercept_2[", idx, "]")) + } else { + c("Component 1" = paste0("prec_intercept_1[", idx, "]")) + } + + bind_rows(lapply(seq_along(component_vars), function(j) { + var_name <- component_vars[[j]] + values <- as.vector(fit$draws(variables = var_name, format = "draws_df")[[var_name]]) + draws_per_param <- tibble( + component = names(component_vars)[j], + v_value = -values + ) + bind_rows( + draws_per_param %>% mutate(parameter = paste0(param_name, ", raw")), + draws_per_param %>% mutate(parameter = paste0(param_name, ", adjusted")) + ) + })) + })) + } else { + NULL } + + p <- build_2d_interval_plot( + .data_plot, + regression_data_all, + adjusted_lines_all, + density_data = density_data_all + ) + + if (!is.null(caption_text)) { + p <- p + + theme(plot.caption = element_text(hjust = 0, size = 9)) + + labs(caption = caption_text) + } + + p } #' Soft-deprecated aliases (call [sccomp_plot_intervals_1D()] / [sccomp_plot_intervals_2D()] instead). diff --git a/man/plot.sccomp_tbl.Rd b/man/plot.sccomp_tbl.Rd index 51a73605..fc98a5ea 100644 --- a/man/plot.sccomp_tbl.Rd +++ b/man/plot.sccomp_tbl.Rd @@ -12,6 +12,7 @@ significance_statistic = c("pH0", "FDR"), show_fdr_message = TRUE, add_marginal_density = TRUE, + omit_ci = FALSE, sort_by = c("none", "effect", "significance", "alphabetical"), ... ) @@ -29,6 +30,8 @@ \item{add_marginal_density}{Logical. Whether to add marginal density plots on adjusted panels in 2D intervals. Default is TRUE.} +\item{omit_ci}{Logical. Whether to omit credible interval error bars from 2D interval plots. Default is FALSE.} + \item{...}{For internal use} } \value{ diff --git a/man/sccomp_plot_intervals_2D.Rd b/man/sccomp_plot_intervals_2D.Rd index 2c77615e..f561b7d0 100644 --- a/man/sccomp_plot_intervals_2D.Rd +++ b/man/sccomp_plot_intervals_2D.Rd @@ -12,7 +12,8 @@ sccomp_plot_intervals_2D( "test_composition_above_logit_fold_change"), show_fdr_message = TRUE, significance_statistic = c("pH0", "FDR"), - add_marginal_density = TRUE + add_marginal_density = TRUE, + omit_ci = FALSE ) } \arguments{ @@ -29,6 +30,8 @@ sccomp_plot_intervals_2D( \item{significance_statistic}{Character vector indicating which statistic to highlight. Default is "pH0".} \item{add_marginal_density}{Logical. Whether to add marginal density plots on adjusted panels. Default is TRUE.} + +\item{omit_ci}{Logical. Whether to omit credible interval error bars. Default is FALSE.} } \value{ A ggplot object representing the 2D interval plot. diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 47e90467..b6d0aaac 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -41,6 +41,22 @@ if (instantiate::stan_cmdstan_exists()){ max_sampling_iterations = n_iterations, verbose=FALSE ) + # Bimodal mean-variability association: exercises the two-component code + # paths in sccomp_plot_intervals_2D (per-cell component assignment in the + # "raw" panel, two regression lines, two-component side densities). + my_estimate_with_variance_bimodal = + seurat_obj |> + sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ type, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + bimodal_mean_variability_association = TRUE, + verbose = FALSE + ) + my_estimate_intercept_only = seurat_obj |> sccomp_estimate( @@ -84,7 +100,93 @@ test_that("plot_2d_intervals function works correctly", { sccomp_plot_intervals_2D( significance_threshold = 0.025 ) |> - expect_s3_class("patchwork") + expect_s3_class("ggplot") +}) + +test_that("sccomp_plot_intervals_2D can omit credible interval error bars", { + skip_cmdstan() + + count_errorbar_layers <- function(plot) { + sum(vapply( + plot$layers, + function(layer) inherits(layer$geom, "GeomErrorbar"), + logical(1) + )) + } + + estimate_with_tests <- my_estimate_with_variance |> + sccomp_test() + + plot_with_ci <- estimate_with_tests |> + sccomp_plot_intervals_2D(add_marginal_density = FALSE) + + plot_without_ci <- estimate_with_tests |> + sccomp_plot_intervals_2D(add_marginal_density = FALSE, omit_ci = TRUE) + + plot_without_ci_density <- estimate_with_tests |> + sccomp_plot_intervals_2D(omit_ci = TRUE) + + expect_s3_class(plot_with_ci, "ggplot") + expect_s3_class(plot_without_ci, "ggplot") + expect_s3_class(plot_without_ci_density, "ggplot") + expect_equal(count_errorbar_layers(plot_with_ci), 2) + expect_equal(count_errorbar_layers(plot_without_ci), 0) + expect_true("omit_ci" %in% names(formals(getS3method("plot", "sccomp_tbl")))) +}) + +test_that("sccomp_plot_intervals_2D works with bimodal mean-variability association", { + skip_cmdstan() + + estimate_bimodal <- my_estimate_with_variance_bimodal |> sccomp_test() + + # Sanity: the model metadata advertises bimodality so the plotter takes the + # two-component branch (otherwise this test would silently exercise the + # single-component path and miss the intended coverage). + expect_true(isTRUE(as.logical( + attr(estimate_bimodal, "model_input")$bimodal_mean_variability_association + ))) + + # Both modes must render without error and stay on the single-faceted-ggplot + # contract that the non-bimodal tests above rely on. + plot_no_density <- estimate_bimodal |> + sccomp_plot_intervals_2D(add_marginal_density = FALSE) + plot_with_density <- estimate_bimodal |> + sccomp_plot_intervals_2D(add_marginal_density = TRUE) + + expect_s3_class(plot_no_density, "ggplot") + expect_s3_class(plot_with_density, "ggplot") + + # Per parameter the bimodal "raw" panel draws *two* component lines (solid + + # dashed) and the "adjusted" panel draws two horizontal references — i.e. + # at least 4 line geoms total for a two-parameter model. The single-component + # path would have at most 2. Use this as a structural marker that the bimodal + # branch ran end-to-end. + count_line_layers <- function(plot) { + sum(vapply( + plot$layers, + function(layer) inherits(layer$geom, "GeomLine"), + logical(1) + )) + } + expect_gte(count_line_layers(plot_no_density), 4) + + # ggside attaches a density side panel for every facet when density mode is + # on; assert at least one ysidedensity layer present. + count_ysidedensity_layers <- function(plot) { + sum(vapply( + plot$layers, + function(layer) inherits(layer$geom, "GeomYsidedensity"), + logical(1) + )) + } + expect_gte(count_ysidedensity_layers(plot_with_density), 1) + + # Bimodal models report `mix_p` (component-1 weight) in the FDR caption; + # verify the caption pipeline is connected for this branch. + fdr_plot <- estimate_bimodal |> + sccomp_plot_intervals_2D(significance_statistic = "FDR", show_fdr_message = TRUE) + caption <- fdr_plot$labels$caption + expect_true(!is.null(caption) && grepl("mix_p", caption)) }) test_that("sccomp_plot_intervals_1D accepts factor argument", { @@ -161,7 +263,9 @@ test_that("show_fdr_message parameter works correctly in sccomp_plot_intervals_2 show_fdr_message = TRUE ) - expect_s3_class(plot_with_message, "patchwork") + # 2D output is now a single faceted ggplot (with optional ggside layer) + # rather than a patchwork composition. + expect_s3_class(plot_with_message, "ggplot") # Test with show_fdr_message = FALSE plot_without_message <- my_estimate_with_variance |> @@ -171,7 +275,7 @@ test_that("show_fdr_message parameter works correctly in sccomp_plot_intervals_2 show_fdr_message = FALSE ) - expect_s3_class(plot_without_message, "patchwork") + expect_s3_class(plot_without_message, "ggplot") # Verify that both plots are created successfully (no errors) expect_no_error(plot_with_message) @@ -352,7 +456,7 @@ test_that("sccomp_plot_intervals_2D includes regression line from prec parameter sccomp_test() |> sccomp_plot_intervals_2D(significance_threshold = 0.025) - expect_s3_class(plot_2d, "patchwork") + expect_s3_class(plot_2d, "ggplot") fit <- attr(my_estimate_with_variance |> sccomp_test(), "fit") prec_intercept_summary <- fit$summary("prec_intercept_1") From f07b2b2898125840e9fcee6c3eae620a36ede924 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 18:18:27 +0930 Subject: [PATCH 51/68] Modify sccomp_estimate function parameters In the sccomp_estimate function, the parameter 'exclude_priors' has been replaced with 'exclude_mean_variability_association' to clarify its purpose. The corresponding changes have been made in the function definitions, documentation, and Stan model to ensure consistency across the codebase. Deprecated parameters have also been noted in the documentation. --- DESCRIPTION | 4 +- R/sccomp_estimate.R | 71 +++++++++++++++++--------- inst/stan/glm_multi_beta_binomial.stan | 67 +++++++++++++----------- man/sccomp_estimate.Rd | 14 +++-- 4 files changed, 99 insertions(+), 57 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 00b23467..0b98f9f1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: sccomp Type: Package Title: Differential Composition and Variability Analysis for Single-Cell Data -Version: 2.1.31 -Date: 2026-04-05 +Version: 2.1.32 +Date: 2026-05-11 Authors@R: c(person("Stefano", "Mangiola", email = "stefano.mangiola@unimelb.edu.au", role = c("aut", "cre")), person("Alexandra J.", "Roth-Schulze", role = "aut"), person("Marie", "Trussart", role = "aut"), person("Enrique", "Zozaya-Valdés", role = "aut"), person("Mengyao", "Ma", role = "aut"), person("Zijie", "Gao", role = "aut"), person("Alan F.", "Rubin", role = "aut"), person("Terence P.", "Speed", role = "aut"), person("Heejung", "Shim", role = "aut"), person("Anthony T.", "Papenfuss", role = "aut")) Description: Comprehensive R package for differential composition and variability analysis in single-cell RNA sequencing, CyTOF, and microbiome data. Provides robust Bayesian modeling with outlier detection, random effects, and advanced statistical methods for cell type proportion analysis. Features include probabilistic outlier identification, mixed-effect modeling, differential variability testing, and comprehensive visualization tools. Perfect for cancer research, immunology, developmental biology, and single-cell genomics applications. License: GPL-3 diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index 871728ae..a8c0ea30 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -42,7 +42,11 @@ #' @param verbose Logical, whether to print progression details. #' @param enable_loo Logical, whether to enable model comparison using the LOO package. #' @param noise_model A character string specifying the noise model (e.g., 'multi_beta_binomial'). -#' @param exclude_priors Logical, whether to run a prior-free model. +#' @param exclude_mean_variability_association Logical. When `TRUE`, the prior +#' on the variability parameters does not depend on the abundance: the +#' mean-variability regression is reduced to an intercept-only Normal (or a +#' two-component mixture when `bimodal_mean_variability_association = TRUE`) +#' while the rest of the hierarchical prior structure stays unchanged. #' @param use_data Logical, whether to run the model data-free. #' @param mcmc_seed An integer seed for MCMC reproducibility. #' @param max_sampling_iterations Integer to limit the maximum number of iterations for large datasets. @@ -67,6 +71,7 @@ #' @param .sample **DEPRECATED**. Use `sample` instead. #' @param .cell_group **DEPRECATED**. Use `cell_group` instead. #' @param .abundance **DEPRECATED**. Use `abundance` instead. +#' @param exclude_priors **DEPRECATED**. Use `exclude_mean_variability_association` instead. #' @param ... Additional arguments passed to the `cmdstanr::sample` function. #' #' @return A tibble (`tbl`), with the following columns: @@ -163,7 +168,7 @@ sccomp_estimate <- function(.data, verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -179,7 +184,8 @@ sccomp_estimate <- function(.data, variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL) { + .abundance = NULL, + exclude_priors = NULL) { # Run the function check_and_install_cmdstanr() @@ -256,7 +262,7 @@ sccomp_estimate.Seurat <- function(.data, verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -272,7 +278,8 @@ sccomp_estimate.Seurat <- function(.data, variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL) { + .abundance = NULL, + exclude_priors = NULL) { .count <- enquo(.count) .sample <- enquo(.sample) @@ -310,7 +317,7 @@ sccomp_estimate.Seurat <- function(.data, verbose = verbose, enable_loo = enable_loo, noise_model = noise_model, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, use_data = use_data, mcmc_seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, @@ -324,7 +331,8 @@ sccomp_estimate.Seurat <- function(.data, variational_inference = variational_inference, .sample = !!.sample, .cell_group = !!.cell_group, - .abundance = !!.abundance + .abundance = !!.abundance, + exclude_priors = exclude_priors ) } @@ -353,7 +361,7 @@ sccomp_estimate.SingleCellExperiment <- function(.data, verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -369,7 +377,8 @@ sccomp_estimate.SingleCellExperiment <- function(.data, variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL) { + .abundance = NULL, + exclude_priors = NULL) { .count <- enquo(.count) @@ -408,7 +417,7 @@ sccomp_estimate.SingleCellExperiment <- function(.data, verbose = verbose, enable_loo = enable_loo, noise_model = noise_model, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, use_data = use_data, mcmc_seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, @@ -422,7 +431,8 @@ sccomp_estimate.SingleCellExperiment <- function(.data, variational_inference = variational_inference, .sample = !!.sample, .cell_group = !!.cell_group, - .abundance = !!.abundance + .abundance = !!.abundance, + exclude_priors = exclude_priors ) } @@ -451,7 +461,7 @@ sccomp_estimate.DFrame <- function(.data, verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -467,7 +477,8 @@ sccomp_estimate.DFrame <- function(.data, variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL) { + .abundance = NULL, + exclude_priors = NULL) { .count <- enquo(.count) .sample <- enquo(.sample) @@ -497,7 +508,7 @@ sccomp_estimate.DFrame <- function(.data, verbose = verbose, enable_loo = enable_loo, noise_model = noise_model, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, use_data = use_data, mcmc_seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, @@ -511,7 +522,8 @@ sccomp_estimate.DFrame <- function(.data, variational_inference = variational_inference, .sample = !!.sample, .cell_group = !!.cell_group, - .abundance = !!.abundance + .abundance = !!.abundance, + exclude_priors = exclude_priors ) } @@ -543,7 +555,7 @@ sccomp_estimate.data.frame <- function(.data, verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -559,7 +571,8 @@ sccomp_estimate.data.frame <- function(.data, variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL) { + .abundance = NULL, + exclude_priors = NULL) { .count <- enquo(.count) @@ -582,6 +595,18 @@ sccomp_estimate.data.frame <- function(.data, details = "The argument variational_inference is now deprecated. Please use inference_method. By default, inference_method value is inferred from variational_inference") inference_method <- ifelse(variational_inference, "variational", "hmc") } + + # `exclude_priors` was renamed because it never actually excluded all priors — + # it disabled the abundance dependence in the variability prior. Forward the + # value to the new argument when supplied so old callers keep working. + if (lifecycle::is_present(exclude_priors) && !is.null(exclude_priors)) { + lifecycle::deprecate_soft( + "2.1.32", + "sccomp::sccomp_estimate(exclude_priors = )", + "sccomp::sccomp_estimate(exclude_mean_variability_association = )" + ) + exclude_mean_variability_association <- exclude_priors + } # Handle deprecated column arguments if (lifecycle::is_present(.sample) && @@ -664,7 +689,7 @@ sccomp_estimate.data.frame <- function(.data, output_directory = output_directory, verbose = verbose, enable_loo = enable_loo, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, use_data = use_data, mcmc_seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, @@ -695,7 +720,7 @@ sccomp_estimate.data.frame <- function(.data, output_directory = output_directory, verbose = verbose, enable_loo = enable_loo, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, use_data = use_data, mcmc_seed = mcmc_seed, max_sampling_iterations = max_sampling_iterations, @@ -756,7 +781,7 @@ sccomp_glm_data_frame_raw = function(.data, test_composition_above_logit_fold_change = 0.1, .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", verbose = FALSE, - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, bimodal_mean_variability_association = FALSE, enable_loo = FALSE, use_data = TRUE, @@ -833,7 +858,7 @@ sccomp_glm_data_frame_raw = function(.data, percent_false_positive = percent_false_positive, check_outliers = check_outliers, inference_method = inference_method, - exclude_priors = exclude_priors, + exclude_mean_variability_association = exclude_mean_variability_association, bimodal_mean_variability_association = bimodal_mean_variability_association, enable_loo = enable_loo, use_data = use_data, @@ -872,7 +897,7 @@ sccomp_glm_data_frame_counts = function(.data, test_composition_above_logit_fold_change = 0.1, .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", verbose = FALSE, - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, bimodal_mean_variability_association = FALSE, enable_loo = FALSE, use_data = TRUE, @@ -1033,7 +1058,7 @@ sccomp_glm_data_frame_counts = function(.data, data_for_model$prior_prec_sd = prior_overdispersion_mean_association$standard_deviation data_for_model$prior_mean_intercept = prior_mean$intercept data_for_model$prior_mean_coefficients = prior_mean$coefficients - data_for_model$exclude_priors = exclude_priors + data_for_model$exclude_mean_variability_association = exclude_mean_variability_association data_for_model$enable_loo = enable_loo # # Check that design matrix is not too big diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 887c0833..fd19f927 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -27,26 +27,40 @@ functions{ real prec_intercept_2, real prec_sd, int bimodal_mean_variability_association, - real mix_p + real mix_p, + // 0: variability prior depends on abundance via the regression slope. + // 1: drop the abundance term; the prior reduces to an intercept-only + // Normal (or two-component mixture in the bimodal case), which is + // what callers want when the mean-variability association is to be + // disabled without abandoning the rest of the hierarchical structure. + // Same name and polarity as the user-facing flag, so no inversion + // happens at the call site. + int exclude_mean_variability_association ){ + // Zeroing the slopes when the association is excluded preserves the rest + // of the lpdf expression (including the bimodal mixture) unchanged, so we + // do not duplicate the likelihood for the two cases. + real eff_slope_1 = exclude_mean_variability_association == 1 ? 0 : prec_slope_1; + real eff_slope_2 = exclude_mean_variability_association == 1 ? 0 : prec_slope_2; + real lp = 0; // If mean-variability association is bimodal such as for single-cell RNA use mixed model if(bimodal_mean_variability_association == 1){ for(m in 1:cols(variability)) lp += log_mix(mix_p, normal_lpdf(variability[m] | - abundance[m] * prec_slope_1 + prec_intercept_1, + abundance[m] * eff_slope_1 + prec_intercept_1, prec_sd), normal_lpdf(variability[m] | - abundance[m] * prec_slope_2 + prec_intercept_2, + abundance[m] * eff_slope_2 + prec_intercept_2, prec_sd) ); // If no bimodal } else { lp = normal_lpdf(variability | - abundance * prec_slope_1 + prec_intercept_1, + abundance * eff_slope_1 + prec_intercept_1, prec_sd); } @@ -306,7 +320,7 @@ data{ array[2] real prior_mean_coefficients; // Exclude priors for testing purposes - int exclude_priors; + int exclude_mean_variability_association; int bimodal_mean_variability_association; int use_data; @@ -520,30 +534,25 @@ model{ } - // Priors - // Per-effect regression (optional for testing) - if(exclude_priors == 0){ - for(a in 1:A){ - target += abundance_variability_regression( - alpha[a], - beta[variability_to_composition_map[a]], - prec_intercept_1[a], - prec_slope_1[a], - bimodal_mean_variability_association == 1 ? prec_slope_2[a] : 0, - bimodal_mean_variability_association == 1 ? prec_intercept_2[a] : 0, - prec_sd[a], - bimodal_mean_variability_association, - mix_p_scalar - ); - } - } else { - if(intercept_in_design || A > 1){ - for(a in 1:A_intercept_columns) alpha[a] ~ student_t(3, prior_prec_intercept[1], prec_sd[a]); - if(A > A_intercept_columns) - for(a in (A_intercept_columns+1):A) to_vector(alpha[a]) ~ student_t(3, 0, prec_sd[a]); - } else { - alpha[1] ~ student_t(3, prior_prec_intercept[1], prec_sd[1]); - } + // Variability prior via the mean-variability regression. + // When `exclude_mean_variability_association = 1` the regression drops the + // abundance term but keeps the hierarchical hyperpriors on + // `prec_intercept_*`, `prec_slope_*` and `prec_sd` identical across both + // modes — only the slope contribution to alpha's prior gets zeroed. This + // avoids a parallel ad-hoc prior block. + for(a in 1:A){ + target += abundance_variability_regression( + alpha[a], + beta[variability_to_composition_map[a]], + prec_intercept_1[a], + prec_slope_1[a], + bimodal_mean_variability_association == 1 ? prec_slope_2[a] : 0, + bimodal_mean_variability_association == 1 ? prec_intercept_2[a] : 0, + prec_sd[a], + bimodal_mean_variability_association, + mix_p_scalar, + exclude_mean_variability_association + ); } // Hyper priors: i1/s1 (and prec_sd) shared; bimodal adds i2/s2 and mix_p shape diff --git a/man/sccomp_estimate.Rd b/man/sccomp_estimate.Rd index a97f45d8..348a6266 100644 --- a/man/sccomp_estimate.Rd +++ b/man/sccomp_estimate.Rd @@ -23,7 +23,7 @@ sccomp_estimate( verbose = TRUE, enable_loo = FALSE, noise_model = "multi_beta_binomial", - exclude_priors = FALSE, + exclude_mean_variability_association = FALSE, use_data = TRUE, mcmc_seed = sample_seed(), max_sampling_iterations = 20000, @@ -37,7 +37,8 @@ sccomp_estimate( variational_inference = NULL, .sample = NULL, .cell_group = NULL, - .abundance = NULL + .abundance = NULL, + exclude_priors = NULL ) } \arguments{ @@ -76,7 +77,12 @@ abundance column (counts or proportions), and factor columns.} \item{noise_model}{A character string specifying the noise model (e.g., 'multi_beta_binomial').} -\item{exclude_priors}{Logical, whether to run a prior-free model.} +\item{exclude_mean_variability_association}{Logical. When \code{TRUE}, the prior +on the variability parameters does not depend on the abundance: the +mean-variability regression is reduced to an intercept-only Normal (or a +two-component mixture when \code{bimodal_mean_variability_association = TRUE}) +while the rest of the hierarchical prior structure stays unchanged. +Default is \code{FALSE}.} \item{use_data}{Logical, whether to run the model data-free.} @@ -116,6 +122,8 @@ clear error when recorded Stan output paths are missing unless draws were incorp \item{.cell_group}{\strong{DEPRECATED}. Use \code{cell_group} instead.} \item{.abundance}{\strong{DEPRECATED}. Use \code{abundance} instead.} + +\item{exclude_priors}{\strong{DEPRECATED}. Use \code{exclude_mean_variability_association} instead.} } \value{ A tibble (\code{tbl}), with the following columns: From a938c4243300e36aba195f3697b7b6fc53dbceb2 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 19:23:35 +0930 Subject: [PATCH 52/68] Update prior_overdispersion_mean_association parameters in sccomp_estimate functions This commit modifies the 'prior_overdispersion_mean_association' parameters across multiple sccomp_estimate functions, adjusting the intercept, slope, and standard deviation values for improved model performance. The changes ensure consistency in parameter settings throughout the codebase. --- R/sccomp_estimate.R | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index a8c0ea30..e38b0800 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -159,9 +159,9 @@ sccomp_estimate <- function(.data, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), prior_overdispersion_mean_association = list( - intercept = c(5, 2), - slope = c(0, 0.6), - standard_deviation = c(10, 20) + intercept = c(4, 2), + slope = c(0, 2), + standard_deviation = c(1, 0.5) ), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", @@ -253,9 +253,9 @@ sccomp_estimate.Seurat <- function(.data, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), prior_overdispersion_mean_association = list( - intercept = c(5, 2), - slope = c(0, 0.6), - standard_deviation = c(10, 20) + intercept = c(4, 2), + slope = c(0, 2), + standard_deviation = c(1, 0.5) ), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", @@ -352,9 +352,9 @@ sccomp_estimate.SingleCellExperiment <- function(.data, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), prior_overdispersion_mean_association = list( - intercept = c(5, 2), - slope = c(0, 0.6), - standard_deviation = c(10, 20) + intercept = c(4, 2), + slope = c(0, 2), + standard_deviation = c(1, 0.5) ), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", @@ -452,9 +452,9 @@ sccomp_estimate.DFrame <- function(.data, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), prior_overdispersion_mean_association = list( - intercept = c(5, 2), - slope = c(0, 0.6), - standard_deviation = c(10, 20) + intercept = c(4, 2), + slope = c(0, 2), + standard_deviation = c(1, 0.5) ), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", @@ -546,9 +546,9 @@ sccomp_estimate.data.frame <- function(.data, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), prior_overdispersion_mean_association = list( - intercept = c(5, 2), - slope = c(0, 0.6), - standard_deviation = c(10, 20) + intercept = c(4, 2), + slope = c(0, 2), + standard_deviation = c(1, 0.5) ), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", @@ -773,7 +773,7 @@ sccomp_glm_data_frame_raw = function(.data, # Secondary arguments contrasts = NULL, prior_mean = list(intercept = c(0,1), coefficients = c(0,1)), - prior_overdispersion_mean_association = list(intercept = c(5, 2), slope = c(0, 0.6), standard_deviation = c(20, 40)), + prior_overdispersion_mean_association = list(intercept = c(4, 2), slope = c(0, 2), standard_deviation = c(1, 0.5)), percent_false_positive = 5, check_outliers = TRUE, variational_inference = NULL, @@ -889,7 +889,7 @@ sccomp_glm_data_frame_counts = function(.data, contrasts = NULL, #.grouping_for_random_effect = NULL, prior_mean = list(intercept = c(0,1), coefficients = c(0,1)), - prior_overdispersion_mean_association = list(intercept = c(5, 2), slope = c(0, 0.6), standard_deviation = c(20, 40)), + prior_overdispersion_mean_association = list(intercept = c(4, 2), slope = c(0, 2), standard_deviation = c(1, 0.5)), percent_false_positive = 5, check_outliers = TRUE, variational_inference = NULL, From 046c14e25b47b302c90aebdd649553742f7ec657 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 19:31:06 +0930 Subject: [PATCH 53/68] Refactor precision parameters in glm_multi_beta_binomial Stan model This commit updates the precision parameters for intercepts and slopes in the glm_multi_beta_binomial Stan model to utilize prior values instead of hardcoded constants. The changes enhance model flexibility and consistency by allowing the use of user-defined prior distributions for better performance in Bayesian inference. --- inst/stan/glm_multi_beta_binomial.stan | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index fd19f927..39bf84c9 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -564,20 +564,20 @@ model{ for(a in 1:A){ // If design has intercept, first column gets intercept-centred prior, others are centred at 0. if(intercept_in_design == 1 && a == 1){ - prec_intercept[a][1] ~ student_t(3, 4, 2); + prec_intercept[a][1] ~ student_t(3, prior_prec_intercept[1], prior_prec_intercept[2]); if(bimodal_mean_variability_association == 1) - prec_intercept[a][2] ~ student_t(3, 4, 2); + prec_intercept[a][2] ~ student_t(3, prior_prec_intercept[1], prior_prec_intercept[2]); } else { - prec_intercept[a][1] ~ student_t(3, 0, 2); + prec_intercept[a][1] ~ student_t(3, 0, prior_prec_intercept[2]); if(bimodal_mean_variability_association == 1) - prec_intercept[a][2] ~ student_t(3, 0, 2); + prec_intercept[a][2] ~ student_t(3, 0, prior_prec_intercept[2]); } - prec_slope_1[a] ~ student_t(3, 0, 2); // s1 + prec_slope_1[a] ~ student_t(3, prior_prec_slope[1], prior_prec_slope[2]); // s1 if(bimodal_mean_variability_association == 1){ - prec_slope_2[a] ~ student_t(3, 0, 2); // s2 + prec_slope_2[a] ~ student_t(3, prior_prec_slope[1], prior_prec_slope[2]); // s2 } } - for(a in 1:A) log_prec_sd[a] ~ normal(1, 0.5); + for(a in 1:A) log_prec_sd[a] ~ normal(prior_prec_sd[1], prior_prec_sd[2]); // // Priors abundance - use correct scale for sum_to_zero_vector for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); From 9d160b3996cb06fae037f2a0e3f7b996b03c2417 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Mon, 11 May 2026 19:41:47 +0930 Subject: [PATCH 54/68] document --- man/sccomp_estimate.Rd | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/man/sccomp_estimate.Rd b/man/sccomp_estimate.Rd index 348a6266..a12eb3dd 100644 --- a/man/sccomp_estimate.Rd +++ b/man/sccomp_estimate.Rd @@ -16,8 +16,8 @@ sccomp_estimate( percent_false_positive = 5, inference_method = "pathfinder", prior_mean = list(intercept = c(0, 1), coefficients = c(0, 1)), - prior_overdispersion_mean_association = list(intercept = c(5, 2), slope = c(0, 0.6), - standard_deviation = c(10, 20)), + prior_overdispersion_mean_association = list(intercept = c(4, 2), slope = c(0, 2), + standard_deviation = c(1, 0.5)), .sample_cell_group_pairs_to_exclude = NULL, output_directory = "sccomp_draws_files", verbose = TRUE, @@ -81,8 +81,7 @@ abundance column (counts or proportions), and factor columns.} on the variability parameters does not depend on the abundance: the mean-variability regression is reduced to an intercept-only Normal (or a two-component mixture when \code{bimodal_mean_variability_association = TRUE}) -while the rest of the hierarchical prior structure stays unchanged. -Default is \code{FALSE}.} +while the rest of the hierarchical prior structure stays unchanged.} \item{use_data}{Logical, whether to run the model data-free.} From 97468899783dacae25f3d8d87de24343d8eae7f4 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 12 May 2026 00:07:40 +0930 Subject: [PATCH 55/68] Enhance documentation for prior_overdispersion_mean_association parameter in sccomp_estimate This commit updates the documentation for the 'prior_overdispersion_mean_association' parameter in the sccomp_estimate function, providing detailed information on its structure and usage. Additionally, unnecessary commented-out code has been removed from the glm_multi_beta_binomial Stan model to improve code clarity. --- R/sccomp_estimate.R | 9 ++++++--- inst/stan/glm_multi_beta_binomial.stan | 9 --------- man/sccomp_estimate.Rd | 7 ++++++- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index e38b0800..e8455bcf 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -34,7 +34,12 @@ #' @param cores Number of cores to use for parallel calculations. #' @param bimodal_mean_variability_association Logical, whether to model mean-variability as bimodal. #' @param prior_mean A list specifying prior knowledge about the mean distribution, including intercept and coefficients. -#' @param prior_overdispersion_mean_association A list specifying prior knowledge about mean/variability association. +#' @param prior_overdispersion_mean_association A named list with numeric length-2 vectors +#' `intercept`, `slope`, and `standard_deviation` passed to the Stan Student-t / Normal +#' hyperpriors on `prec_intercept`, `prec_slope`, and `log_prec_sd`. Use `NULL` for +#' package defaults. A scalar logical such as `FALSE` is not meaningful here and is treated +#' as `NULL` after a message; to disable abundance dependence in the variability prior, +#' use `exclude_mean_variability_association = TRUE` instead. #' @param percent_false_positive A real number between 0 and 100 for outlier identification. #' @param inference_method Character string specifying the inference method to use ('pathfinder', 'hmc', or 'variational'). Replaces the deprecated `approximate_posterior_inference` and `variational_inference`. #' @param .sample_cell_group_pairs_to_exclude A column name indicating sample/cell-group pairs to exclude. @@ -875,8 +880,6 @@ sccomp_glm_data_frame_raw = function(.data, ) } - - sccomp_glm_data_frame_counts = function(.data, formula_composition = ~ 1 , formula_variability = ~ 1, diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 39bf84c9..4fb09326 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -522,15 +522,6 @@ model{ ); - // print("2---", reduce_sum( - // partial_sum_lupmf, - // y_array[truncation_not_idx], - // grainsize, - // exposure_array[truncation_not_idx], - // mu_array[truncation_not_idx], - // precision_array[truncation_not_idx] - // )); - } diff --git a/man/sccomp_estimate.Rd b/man/sccomp_estimate.Rd index a12eb3dd..c49b6bf2 100644 --- a/man/sccomp_estimate.Rd +++ b/man/sccomp_estimate.Rd @@ -65,7 +65,12 @@ abundance column (counts or proportions), and factor columns.} \item{prior_mean}{A list specifying prior knowledge about the mean distribution, including intercept and coefficients.} -\item{prior_overdispersion_mean_association}{A list specifying prior knowledge about mean/variability association.} +\item{prior_overdispersion_mean_association}{A named list with numeric length-2 vectors +\code{intercept}, \code{slope}, and \code{standard_deviation} passed to the Stan Student-t / Normal +hyperpriors on \code{prec_intercept}, \code{prec_slope}, and \code{log_prec_sd}. Use \code{NULL} for +package defaults. A scalar logical such as \code{FALSE} is not meaningful here and is treated +as \code{NULL} after a message; to disable abundance dependence in the variability prior, +use \code{exclude_mean_variability_association = TRUE} instead.} \item{.sample_cell_group_pairs_to_exclude}{A column name indicating sample/cell-group pairs to exclude.} From f2d97ce24a7802faebd05d6d9a7fcccf26f0f839 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 12 May 2026 00:11:44 +0930 Subject: [PATCH 56/68] fix normalisation if I don't have association --- R/sccomp_test.R | 30 +++++- tests/testthat/helper-precomputed-estimates.R | 72 +++++++++++++ ...est-exclude-mean-variability-association.R | 100 ++++++++++++++++++ tests/testthat/test-plot.R | 59 +---------- 4 files changed, 199 insertions(+), 62 deletions(-) create mode 100644 tests/testthat/helper-precomputed-estimates.R create mode 100644 tests/testthat/test-exclude-mean-variability-association.R diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 70dea1ce..973632a9 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -230,6 +230,26 @@ summarise_stan_matrix_for_estimate <- function( #' This mirrors `summarise_stan_matrix_for_estimate()` but computes quantiles for #' alpha_normalised from derived draws, while borrowing convergence diagnostics #' (rhat/ESS) from the corresponding `alpha` elements. +#' +#' @keywords internal +#' @noRd +get_variability_draws_for_test <- function(fit, model_input, alpha_variable_subset = NULL) { + + if (isTRUE(as.logical(model_input$exclude_mean_variability_association))) { + alpha_var <- if (is.null(alpha_variable_subset)) "alpha" else alpha_variable_subset + return( + draws_to_tibble_x_y(fit, alpha_var, "C", "M") |> + dplyr::mutate(.variable = "alpha_normalised") + ) + } + + compute_alpha_normalised_draws( + fit = fit, + model_input = model_input, + alpha_variable_subset = alpha_variable_subset + ) +} + #' #' @keywords internal #' @noRd @@ -256,8 +276,10 @@ summarise_alpha_normalised_for_estimate <- function( g <- expand.grid(C = C_idx, M = seq_len(n_M), stringsAsFactors = FALSE) alpha_subset <- sprintf("alpha[%d,%d]", g$C, g$M) - # Compute alpha_normalised summaries from derived R-side draws. - draws_summary <- compute_alpha_normalised_draws( + # Compute variability summaries from derived R-side draws. + # If mean-variability association is excluded, this returns raw alpha draws + # (relabelled for downstream schema parity); otherwise alpha_normalised draws. + draws_summary <- get_variability_draws_for_test( fit = fit, model_input = model_input, alpha_variable_subset = alpha_subset @@ -730,12 +752,12 @@ get_variability_contrast_draws = function(.data, contrasts){ } draws = - compute_alpha_normalised_draws( + get_variability_draws_for_test( fit = .data |> attr("fit"), model_input = model_input, alpha_variable_subset = alpha_variable_subset ) |> - + # We want variability, not concentration mutate(.value = -.value) diff --git a/tests/testthat/helper-precomputed-estimates.R b/tests/testthat/helper-precomputed-estimates.R new file mode 100644 index 00000000..57887343 --- /dev/null +++ b/tests/testthat/helper-precomputed-estimates.R @@ -0,0 +1,72 @@ +# Expensive pre-fitted sccomp objects shared by plot and association tests. +# Helpers run before any `test_*.R` file so objects exist regardless of +# alphabetical test order. + +if (requireNamespace("instantiate", quietly = TRUE) && instantiate::stan_cmdstan_exists()) { + data("seurat_obj", package = "sccomp", envir = environment()) + + n_iterations <- 1000L + set.seed(42) + + my_estimate <- + seurat_obj |> + sccomp::sccomp_estimate( + formula_composition = ~ continuous_covariate * type, + formula_variability = ~ 1, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + verbose = FALSE + ) + + my_estimate_with_variance <- + seurat_obj |> + sccomp::sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ type, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + verbose = FALSE + ) + + my_estimate_exclude_mean_variability_association <- + seurat_obj |> + sccomp::sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ type, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + exclude_mean_variability_association = TRUE, + verbose = FALSE + ) + + my_estimate_with_variance_bimodal <- + seurat_obj |> + sccomp::sccomp_estimate( + formula_composition = ~ type, + formula_variability = ~ type, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + bimodal_mean_variability_association = TRUE, + verbose = FALSE + ) + + my_estimate_intercept_only <- + seurat_obj |> + sccomp::sccomp_estimate( + formula_composition = ~ 1, + formula_variability = ~ 1, + "sample", "cell_group", + cores = 1, + inference_method = "pathfinder", + max_sampling_iterations = n_iterations, + verbose = FALSE + ) +} diff --git a/tests/testthat/test-exclude-mean-variability-association.R b/tests/testthat/test-exclude-mean-variability-association.R new file mode 100644 index 00000000..5bc795b5 --- /dev/null +++ b/tests/testthat/test-exclude-mean-variability-association.R @@ -0,0 +1,100 @@ +## Paired pre-fits: `my_estimate_with_variance` (association on) vs +## `my_estimate_exclude_mean_variability_association` (association off in the +## prior) — same composition and variability formulas. Defined in `test-plot.R` +## when CmdStan is available. + +test_that("exclude_mean_variability_association is stored and passed to Stan", { + skip_cmdstan() + + ex <- attr(my_estimate_exclude_mean_variability_association, "model_input")$exclude_mean_variability_association + expect_true(isTRUE(ex) || identical(as.integer(ex), 1L)) + + def <- attr(my_estimate_with_variance, "model_input")$exclude_mean_variability_association + expect_true(isFALSE(def) || identical(as.integer(def), 0L)) +}) + +test_that("exclude_mean_variability_association: prec_sd and alpha Stan summaries are finite", { + skip_cmdstan() + + fit_ex <- attr(my_estimate_exclude_mean_variability_association, "fit") + fit_def <- attr(my_estimate_with_variance, "fit") + + for (nm in c("prec_sd", "prec_slope_1", "prec_intercept_1")) { + s_ex <- fit_ex$summary(variables = nm) + s_def <- fit_def$summary(variables = nm) + expect_true(all(is.finite(s_ex$mean))) + expect_true(all(is.finite(s_def$mean))) + rh <- intersect(names(s_ex), c("rhat", "Rhat")) + if (length(rh) == 1L) { + expect_true(all(s_ex[[rh]] < 1.05, na.rm = TRUE)) + expect_true(all(s_def[[rh]] < 1.05, na.rm = TRUE)) + } + } + + sa_ex <- fit_ex$summary(variables = "alpha") + sa_def <- fit_def$summary(variables = "alpha") + expect_true(all(is.finite(sa_ex$mean))) + expect_true(all(is.finite(sa_def$mean))) +}) + +test_that("exclude_mean_variability_association: sccomp_test and 2D interval plot build cleanly", { + skip_cmdstan() + + tested_ex <- my_estimate_exclude_mean_variability_association |> sccomp_test() + tested_def <- my_estimate_with_variance |> sccomp_test() + + expect_true(all(is.finite(tested_ex$v_effect), na.rm = TRUE)) + expect_true(all(is.finite(tested_ex$v_lower), na.rm = TRUE)) + expect_true(all(is.finite(tested_ex$v_upper), na.rm = TRUE)) + expect_true(all(is.finite(tested_def$v_effect), na.rm = TRUE)) + + p_ex <- sccomp_plot_intervals_2D(tested_ex, add_marginal_density = FALSE) + p_def <- sccomp_plot_intervals_2D(tested_def, add_marginal_density = FALSE) + + expect_s3_class(p_ex, "ggplot") + expect_s3_class(p_def, "ggplot") + + gb_ex <- ggplot2::ggplot_build(p_ex) + gb_def <- ggplot2::ggplot_build(p_def) + + y_spans_ex <- vapply( + gb_ex$layout$panel_params, + function(p) diff(p$y.range), + numeric(1) + ) + y_spans_def <- vapply( + gb_def$layout$panel_params, + function(p) diff(p$y.range), + numeric(1) + ) + + expect_true(all(is.finite(y_spans_ex))) + expect_true(all(is.finite(y_spans_def))) + expect_true(all(y_spans_ex > 0)) + expect_true(all(y_spans_def > 0)) +}) + +test_that("exclude_mean_variability_association: v_* intervals match raw alpha and don't inflate", { + # Regression guard: when the mean-variability association is excluded, the + # Stan model fixes the slope contribution to zero in the variability prior + # but leaves `prec_slope_*` sampled from its (wide) prior. If + # `compute_alpha_normalised_draws()` ever resumes applying the + # `alpha - beta * prec_slope` correction in this mode, every v_* interval + # picks up prior-sized noise scaled by |beta| (5-10x inflation on real data). + # We tie the v_* width to the raw alpha 95% width so any regression is + # caught immediately. + skip_cmdstan() + + fit_ex <- attr(my_estimate_exclude_mean_variability_association, "fit") + tested_ex <- my_estimate_exclude_mean_variability_association |> sccomp_test() + tested_def <- my_estimate_with_variance |> sccomp_test() + + alpha_summary <- fit_ex$summary(variables = "alpha") + alpha_95_width <- 3.92 * mean(alpha_summary$sd, na.rm = TRUE) + + v_width_ex <- mean(tested_ex$v_upper - tested_ex$v_lower, na.rm = TRUE) + v_width_def <- mean(tested_def$v_upper - tested_def$v_lower, na.rm = TRUE) + + expect_lt(abs(v_width_ex - alpha_95_width) / alpha_95_width, 0.25) + expect_lt(v_width_ex / max(v_width_def, .Machine$double.eps), 3) +}) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index b6d0aaac..d7235cbb 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -11,64 +11,7 @@ counts_obj = mutate(count = count+1) |> with_groups("sample", ~ .x |> mutate(proportion = count/sum(count))) -set.seed(42) - -n_iterations = 1000 - -if (instantiate::stan_cmdstan_exists()){ - - my_estimate = - seurat_obj |> - sccomp_estimate( - formula_composition = ~ continuous_covariate * type , - formula_variability = ~ 1, - "sample", "cell_group", - - cores = 1, - inference_method = "pathfinder", - max_sampling_iterations = n_iterations, verbose=FALSE - ) - - my_estimate_with_variance = - seurat_obj |> - sccomp_estimate( - formula_composition = ~ type, - formula_variability = ~ type, - "sample", "cell_group", - - cores = 1, - inference_method = "pathfinder", - max_sampling_iterations = n_iterations, verbose=FALSE - ) - - # Bimodal mean-variability association: exercises the two-component code - # paths in sccomp_plot_intervals_2D (per-cell component assignment in the - # "raw" panel, two regression lines, two-component side densities). - my_estimate_with_variance_bimodal = - seurat_obj |> - sccomp_estimate( - formula_composition = ~ type, - formula_variability = ~ type, - "sample", "cell_group", - cores = 1, - inference_method = "pathfinder", - max_sampling_iterations = n_iterations, - bimodal_mean_variability_association = TRUE, - verbose = FALSE - ) - - my_estimate_intercept_only = - seurat_obj |> - sccomp_estimate( - formula_composition = ~ 1, - formula_variability = ~ 1, - "sample", "cell_group", - cores = 1, - inference_method = "pathfinder", - max_sampling_iterations = n_iterations, - verbose = FALSE - ) -} +# Precomputed CmdStan fits: `helper-precomputed-estimates.R` # Test for plot_1d_intervals function test_that("plot_1d_intervals function works correctly", { From ff3a94a88ebc7173f5d55b2c3c122faf78bcc5dd Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sat, 16 May 2026 11:36:29 +0930 Subject: [PATCH 57/68] allow for up to 4 random effect, in perspective of allowing spline , which requires random effects --- .gitignore | 1 + R/model_fitting.R | 36 ++- R/sccomp_estimate.R | 4 +- R/sccomp_remove_outliers.R | 119 +++++----- R/sccomp_replicate.R | 240 +++++++++---------- R/sccomp_test.R | 213 ++++++----------- R/utilities.R | 201 ++++++++-------- inst/stan/common_functions.stan | 35 +++ inst/stan/glm_multi_beta_binomial.stan | 305 +++++++++++++++---------- 9 files changed, 571 insertions(+), 583 deletions(-) diff --git a/.gitignore b/.gitignore index b631b214..f8e2c429 100644 --- a/.gitignore +++ b/.gitignore @@ -50,3 +50,4 @@ docs **/*.quarto_ipynb .Renviron *.exe +sccomp.Rcheck* diff --git a/R/model_fitting.R b/R/model_fitting.R index da509819..e463af97 100644 --- a/R/model_fitting.R +++ b/R/model_fitting.R @@ -69,30 +69,22 @@ fit_model = function( init_list$prec_slope_2 = rep(0, data_for_model$A) } - if(data_for_model$n_random_eff>0){ - init_list$random_effect_raw = matrix(0, data_for_model$ncol_X_random_eff[1] , data_for_model$M) - init_list$random_effect_sigma_raw = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[1]) - init_list$sigma_correlation_factor = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[1], - data_for_model$how_many_factors_in_random_design[1] - )) - - # init_list$random_effect_sigma_mu = 0.5 |> as.array() - # init_list$random_effect_sigma_sigma = 0.2 |> as.array() + # Random effect inits - 4 uniform slots (one per non-empty random-effect block). + # Each slot gets zero-initialised raws + an identity-like correlation Cholesky. + if (data_for_model$n_random_eff > 0) { init_list$zero_random_effect = rep(0, size = 1) |> as.array() - } - - if(data_for_model$n_random_eff>1){ - init_list$random_effect_raw_2 = matrix(0, data_for_model$ncol_X_random_eff[2] , data_for_model$M) - init_list$random_effect_sigma_raw_2 = matrix(0, data_for_model$M , data_for_model$how_many_factors_in_random_design[2]) - init_list$sigma_correlation_factor_2 = array(0, dim = c( - data_for_model$M, - data_for_model$how_many_factors_in_random_design[2], - data_for_model$how_many_factors_in_random_design[2] - )) - + for (k in seq_len(4L)) { + if (data_for_model$ncol_X_random_eff[k] == 0) next + K = data_for_model$how_many_factors_in_random_design[k] + + init_list[[paste0("random_effect_raw_", k)]] = + matrix(0, data_for_model$ncol_X_random_eff[k], data_for_model$M) + init_list[[paste0("random_effect_sigma_raw_", k)]] = + matrix(0, data_for_model$M, K) + init_list[[paste0("sigma_correlation_factor_", k)]] = + array(0, dim = c(data_for_model$M, K, K)) + } } init = map(1:chains, ~ init_list) %>% diff --git a/R/sccomp_estimate.R b/R/sccomp_estimate.R index e8455bcf..1a326688 100644 --- a/R/sccomp_estimate.R +++ b/R/sccomp_estimate.R @@ -1085,8 +1085,8 @@ sccomp_glm_data_frame_counts = function(.data, "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", - "random_effect", "random_effect_2", - "random_effect_sigma", "random_effect_sigma_2", + # Random effect outputs - one per slot (1..4) + "random_effect_1", "random_effect_2", "random_effect_3", "random_effect_4", "log_lik" ), sig_figs = sig_figs, diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index 84b53e6d..039c8848 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -198,33 +198,38 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, data = .estimate |> attr("model_input") |> - c(list( - - # Add subset of coefficients - X_original = data_for_model$X, - N_original = data_for_model$N, - length_X_which = ncol(data_for_model$X), - length_XA_which = ncol(data_for_model$XA), - X_which = seq_len(ncol(data_for_model$X)) |> as.array(), - XA_which = seq_len(ncol(data_for_model$Xa)) |> as.array(), - - # Random intercept common variable between grouping 1 and 2 - ncol_X_random_eff_new = ncol(data_for_model$X_random_effect) |> c(ncol(data_for_model$X_random_effect_2) ), # I could put this in the intial data - length_X_random_effect_which = ncol(data_for_model$X_random_effect) |> c(ncol(data_for_model$X_random_effect_2)), - - # Grouping 1 - X_random_effect_which = seq_len(ncol(data_for_model$X_random_effect)) |> as.array(), - - # Grouping 2 - Random intercept DUPLICATED - X_random_effect_which_2 = seq_len(ncol(data_for_model$X_random_effect_2)) |> as.array(), - - # Initialize unseen random effect variables - ncol_X_random_eff_unseen = c(0, 0), - X_random_effect_unseen = matrix(0, nrow = nrow(data_for_model$X), ncol = 0), - X_random_effect_2_unseen = matrix(0, nrow = nrow(data_for_model$X), ncol = 0), - - create_intercept = FALSE - )), + c( + list( + # Add subset of coefficients + X_original = data_for_model$X, + N_original = data_for_model$N, + length_X_which = ncol(data_for_model$X), + length_XA_which = ncol(data_for_model$XA), + X_which = seq_len(ncol(data_for_model$X)) |> as.array(), + XA_which = seq_len(ncol(data_for_model$Xa)) |> as.array(), + + # Per-slot random-effect pass-throughs (the outlier model uses the + # same design, so X_random_effect_which_k is just an identity over + # the slot's columns; unseen matrices are empty). + ncol_X_random_eff_new = data_for_model$ncol_X_random_eff, + length_X_random_effect_which = data_for_model$ncol_X_random_eff, + ncol_X_random_eff_unseen = rep(0L, 4L), + + create_intercept = FALSE + ), + # Identity which-indices per slot, generated programmatically + setNames( + lapply(seq_len(4L), function(k) + seq_len(data_for_model$ncol_X_random_eff[k]) |> as.array()), + paste0("X_random_effect_which_", seq_len(4L)) + ), + # Empty unseen design matrices per slot + setNames( + replicate(4L, matrix(0, nrow = nrow(data_for_model$X), ncol = 0), + simplify = FALSE), + paste0("X_random_effect_", seq_len(4L), "_unseen") + ) + ), parallel_chains = ifelse( inference_method %in% c("variational", "pathfinder") | @@ -332,7 +337,7 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, pars = c( "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", - "random_effect", "random_effect_2" + "random_effect_1", "random_effect_2", "random_effect_3", "random_effect_4" ), sig_figs = sig_figs, cache_stan_model = cache_stan_model, @@ -345,34 +350,34 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, fit2$draws(format = "matrix"), # This is for the new data generation with selected factors to do adjustment - data = data_for_model |> c(list( - - # Add subset of coefficients - X_original = data_for_model$X, - N_original = data_for_model$N, - length_X_which = ncol(data_for_model$X), - length_XA_which = ncol(data_for_model$XA), - X_which = seq_len(ncol(data_for_model$X)) |> as.array(), - XA_which = seq_len(ncol(data_for_model$Xa)) |> as.array(), - - # Random intercept common variable between grouping 1 and 2 - ncol_X_random_eff_new = ncol(data_for_model$X_random_effect) |> c(ncol(data_for_model$X_random_effect_2) ), # I could put this in the intial data - length_X_random_effect_which = ncol(data_for_model$X_random_effect) |> c(ncol(data_for_model$X_random_effect_2)), - - # Grouping 1 - X_random_effect_which = seq_len(ncol(data_for_model$X_random_effect)) |> as.array(), - - # Grouping 2 - Random intercept DUPLICATED - X_random_effect_which_2 = seq_len(ncol(data_for_model$X_random_effect_2)) |> as.array(), - - # Initialize unseen random effect variables - ncol_X_random_eff_unseen = c(0, 0), - X_random_effect_unseen = matrix(0, nrow = nrow(data_for_model$X), ncol = 0), - X_random_effect_2_unseen = matrix(0, nrow = nrow(data_for_model$X), ncol = 0), - - create_intercept = FALSE - - )), + data = data_for_model |> c( + list( + # Add subset of coefficients + X_original = data_for_model$X, + N_original = data_for_model$N, + length_X_which = ncol(data_for_model$X), + length_XA_which = ncol(data_for_model$XA), + X_which = seq_len(ncol(data_for_model$X)) |> as.array(), + XA_which = seq_len(ncol(data_for_model$Xa)) |> as.array(), + + # Per-slot random-effect pass-throughs (see notes in the first call site) + ncol_X_random_eff_new = data_for_model$ncol_X_random_eff, + length_X_random_effect_which = data_for_model$ncol_X_random_eff, + ncol_X_random_eff_unseen = rep(0L, 4L), + + create_intercept = FALSE + ), + setNames( + lapply(seq_len(4L), function(k) + seq_len(data_for_model$ncol_X_random_eff[k]) |> as.array()), + paste0("X_random_effect_which_", seq_len(4L)) + ), + setNames( + replicate(4L, matrix(0, nrow = nrow(data_for_model$X), ncol = 0), + simplify = FALSE), + paste0("X_random_effect_", seq_len(4L), "_unseen") + ) + ), parallel_chains = ifelse(inference_method %in% c("variational", "pathfinder"), 1, fit2$num_chains()), threads_per_chain = cores, @@ -468,7 +473,7 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, pars = c( "beta", "alpha", "prec_intercept_1", "prec_slope_1", "prec_intercept_2", "prec_slope_2", "prec_sd", - "random_effect", "random_effect_2", "log_lik" + "random_effect_1", "random_effect_2", "random_effect_3", "random_effect_4", "log_lik" ), cache_stan_model = cache_stan_model, ... diff --git a/R/sccomp_replicate.R b/R/sccomp_replicate.R index 0c785feb..a23af89c 100644 --- a/R/sccomp_replicate.R +++ b/R/sccomp_replicate.R @@ -126,8 +126,8 @@ sccomp_replicate.sccomp_tbl = function(fit, #' @param Xa Original variability design matrix #' @param N Original number of samples #' @param intercept_in_design Whether intercept is in design -#' @param X_random_effect Original random effect design matrix -#' @param X_random_effect_2 Original second random effect design matrix +#' @param X_random_effect_slots Length-4 list of original random-effect design +#' matrices (one per slot). Empty slots are zero-column matrices. #' @param .sample Quosure for the sample identifier column #' @param .cell_group Quosure for the cell group column #' @param .count Quosure for the count column @@ -140,8 +140,7 @@ sccomp_replicate.sccomp_tbl = function(fit, #' - model_input: The prepared model input data #' - X_which: Indices for the composition design matrix #' - XA_which: Indices for the variability design matrix -#' - X_random_effect_which: Indices for the first random effect design matrix -#' - X_random_effect_which_2: Indices for the second random effect design matrix +#' - X_random_effect_which_1..4: per-slot indices into the original RE design matrix #' - create_intercept: Boolean indicating if intercept should be created #' #' @noRd @@ -149,8 +148,7 @@ prepare_replicate_data = function(X, Xa, N, intercept_in_design, - X_random_effect, - X_random_effect_2, + X_random_effect_slots, .sample, .cell_group, .count, @@ -291,137 +289,111 @@ prepare_replicate_data = function(X, "(Intercept)" %in% colnames(new_X) if(create_intercept) warning("sccomp says: your estimated model is intercept free, while your desired replicated data do have an intercept term. The intercept estimate will be calculated averaging your first factor in your formula ~ 0 + . If you don't know the meaning of this warning, this is likely undesired, and please reconsider your formula for replicate_data()") - # Original grouping - original_grouping_names = original_formula_composition |> formula_to_random_effect_formulae() |> pull(grouping) + # Original grouping (one entry per RE clause in the original formula) + original_grouping_names = original_formula_composition |> + formula_to_random_effect_formulae() |> + pull(grouping) - # Random intercept + # Parse the (possibly new) composition formula to find RE clauses in new_data random_effect_elements = parse_formula_random_effect(formula_composition) - - # Initialize unseen random effect variables - new_X_random_effect_unseen = matrix(rep(0, nrow_new_data))[,0, drop=FALSE] - new_X_random_effect_2_unseen = matrix(rep(0, nrow_new_data))[,0, drop=FALSE] - - # Set default random intercept - X_random_effect_which = array()[0] - new_X_random_effect = matrix(rep(0, nrow_new_data))[,0, drop=FALSE] - - # setup default unknown_grouping variable for generated quantities - unknown_grouping = c(FALSE, FALSE) - - #check_random_effect_design(.data_spread, any_of(factor_names), random_effect_elements, formula, X) - random_effect_grouping = + random_effect_grouping = formula_composition |> formula_to_random_effect_formulae() |> mutate(design = map2( formula, grouping, - ~ get_random_effect_design3(new_data, .x, .y, !!.sample, - accept_NA_as_average_effect = TRUE ) + ~ get_random_effect_design3(new_data, .x, .y, !!.sample, + accept_NA_as_average_effect = TRUE) )) - - - if((random_effect_grouping$grouping %in% original_grouping_names[1]) |> any() && !unknown_grouping[1]) { - new_X_random_effect = - random_effect_grouping |> - filter(grouping==original_grouping_names[1]) |> - mutate(design_matrix = map( - design, - ~ ..1 |> - select(!!.sample, group___label, value) |> - - # Some combinations might not have been present in a specific group so the parameter does not exist - filter(group___label %in% colnames(X_random_effect)) |> - - pivot_wider(names_from = group___label, values_from = value) |> - mutate(across(everything(), ~ .x |> replace_na(0))) - )) |> - # Merge - pull(design_matrix) |> - _[[1]] |> - column_to_rownames(quo_name(.sample)) |> - tail(nrow_new_data) + # ---------------------------------------------------------------------- + # Build the per-slot replicate design matrices. + # + # For each of the 4 slots: if the slot was active in the original fit + # (original_grouping_names[k] exists) and the new formula references it, + # build a new design matrix restricted to the columns the model saw, and + # an index vector mapping new columns back to those of the original matrix. + # Otherwise emit an empty placeholder. + # ---------------------------------------------------------------------- + empty_mat_new = matrix(rep(0, nrow_new_data))[, 0, drop = FALSE] + empty_which_new = array()[0] + + build_replicate_slot = function(slot_idx) { + grouping_for_slot = original_grouping_names[slot_idx] # NA if slot wasn't used originally + X_original_slot = X_random_effect_slots[[slot_idx]] - # Separate NA group column into new_X_random_effect_unseen - new_X_random_effect_unseen = new_X_random_effect[, colnames(new_X_random_effect) |> str_detect("___NA$"), drop = FALSE] - new_X_random_effect = new_X_random_effect[, !colnames(new_X_random_effect) |> str_detect("___NA$"), drop = FALSE] + slot_is_active = !is.na(grouping_for_slot) && + any(random_effect_grouping$grouping %in% grouping_for_slot) - # Check that all effect combination were present when the model was fitted - check_missing_parameters( - new_X_random_effect |> colnames(), - X_random_effect |> colnames() - ) + if (!slot_is_active) { + return(list( + X = empty_mat_new, + X_unseen = empty_mat_new, + which = empty_which_new + )) + } - X_random_effect_which = - colnames(new_X_random_effect) |> - match( - X_random_effect %>% - colnames() - ) |> - as.array() - } - - # Set default X random intercept - X_random_effect_which_2 = array()[0] - new_X_random_effect_2 = matrix(rep(0, nrow_new_data))[,0, drop=FALSE] - - if((random_effect_grouping$grouping %in% original_grouping_names[2]) |> any()){ - new_X_random_effect_2 = - random_effect_grouping |> - filter(grouping==original_grouping_names[2]) |> + X_new = random_effect_grouping |> + filter(grouping == grouping_for_slot) |> mutate(design_matrix = map( design, ~ ..1 |> select(!!.sample, group___label, value) |> - - # Some combinations might not have been present in a specific group so the parameter does not exist - filter(group___label %in% colnames(X_random_effect_2)) |> - + # Combinations not present in the original fit have no parameters + filter(group___label %in% colnames(X_original_slot)) |> pivot_wider(names_from = group___label, values_from = value) |> mutate(across(everything(), ~ .x |> replace_na(0))) )) |> - # Merge - pull(design_matrix) |> - _[[1]] |> - column_to_rownames(quo_name(.sample)) |> + pull(design_matrix) |> + _[[1]] |> + column_to_rownames(quo_name(.sample)) |> tail(nrow_new_data) - # Separate NA group column into new_X_random_effect_2_unseen - new_X_random_effect_2_unseen = new_X_random_effect_2[, colnames(new_X_random_effect_2) |> str_detect("___NA$"), drop = FALSE] - new_X_random_effect_2 = new_X_random_effect_2[, !colnames(new_X_random_effect_2) |> str_detect("___NA$"), drop = FALSE] + is_NA_col = str_detect(colnames(X_new), "___NA$") + X_new_unseen = X_new[, is_NA_col, drop = FALSE] + X_new = X_new[, !is_NA_col, drop = FALSE] - # Check that all effect combination were present when the model was fitted - check_missing_parameters( - new_X_random_effect_2 |> colnames(), - X_random_effect_2 |> colnames() - ) + check_missing_parameters(colnames(X_new), colnames(X_original_slot)) - X_random_effect_which_2 = - colnames(new_X_random_effect_2) |> - match( - X_random_effect_2 %>% - colnames() - ) |> + which_idx = colnames(X_new) |> + match(colnames(X_original_slot)) |> as.array() + + list(X = X_new, X_unseen = X_new_unseen, which = which_idx) } - # Prepare the list of inputs to the model + replicate_slots = map(seq_len(4L), build_replicate_slot) + + # setup default unknown_grouping variable for generated quantities + unknown_grouping = c(FALSE, FALSE, FALSE, FALSE) + list( - X = new_X, - Xa = new_Xa, - N = nrow_new_data, + X = new_X, + Xa = new_Xa, + N = nrow_new_data, exposure = new_exposure, - X_random_effect = new_X_random_effect, - X_random_effect_2 = new_X_random_effect_2, - X_random_effect_unseen = new_X_random_effect_unseen, - X_random_effect_2_unseen = new_X_random_effect_2_unseen, - ncol_X_random_eff_new = c(ncol(new_X_random_effect), ncol(new_X_random_effect_2)), - unknown_grouping = unknown_grouping, - ncol_X_random_eff_unseen = c(ncol(new_X_random_effect_unseen), ncol(new_X_random_effect_2_unseen)), - X_which = X_which, - XA_which = XA_which, - X_random_effect_which = X_random_effect_which, - X_random_effect_which_2 = X_random_effect_which_2, + # Per-slot design + unseen-column matrices + index vectors + X_random_effect_1 = replicate_slots[[1]]$X, + X_random_effect_2 = replicate_slots[[2]]$X, + X_random_effect_3 = replicate_slots[[3]]$X, + X_random_effect_4 = replicate_slots[[4]]$X, + + X_random_effect_1_unseen = replicate_slots[[1]]$X_unseen, + X_random_effect_2_unseen = replicate_slots[[2]]$X_unseen, + X_random_effect_3_unseen = replicate_slots[[3]]$X_unseen, + X_random_effect_4_unseen = replicate_slots[[4]]$X_unseen, + + X_random_effect_which_1 = replicate_slots[[1]]$which, + X_random_effect_which_2 = replicate_slots[[2]]$which, + X_random_effect_which_3 = replicate_slots[[3]]$which, + X_random_effect_which_4 = replicate_slots[[4]]$which, + + ncol_X_random_eff_new = map_int(replicate_slots, ~ ncol(.x$X)), + ncol_X_random_eff_unseen = map_int(replicate_slots, ~ ncol(.x$X_unseen)), + unknown_grouping = unknown_grouping, + + X_which = X_which, + XA_which = XA_which, create_intercept = create_intercept ) @@ -474,14 +446,14 @@ replicate_data = function(.data, # create model input model_input = attr(.data, "model_input") - # Prepare data + # Prepare data - pass the per-slot original RE design matrices as a list prepared_data = prepare_replicate_data( X = model_input$X, Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = lapply(seq_len(4L), function(k) + model_input[[paste0("X_random_effect_", k)]]), .sample = !!.sample, .cell_group = !!.cell_group, .count = !!.count, @@ -495,37 +467,35 @@ replicate_data = function(.data, .subset(!!.sample) ) - # Original input + # Original input model_input$X_original = model_input$X model_input$N_original = model_input$N # New input - model_input$X = prepared_data$X - model_input$Xa = prepared_data$Xa - model_input$N = prepared_data$N + model_input$X = prepared_data$X + model_input$Xa = prepared_data$Xa + model_input$N = prepared_data$N model_input$exposure = prepared_data$exposure - model_input$X_random_effect = prepared_data$X_random_effect - model_input$X_random_effect_2 = prepared_data$X_random_effect_2 - model_input$X_random_effect_unseen = prepared_data$X_random_effect_unseen - model_input$X_random_effect_2_unseen = prepared_data$X_random_effect_2_unseen - model_input$ncol_X_random_eff_new = prepared_data$ncol_X_random_eff_new - model_input$unknown_grouping = prepared_data$unknown_grouping + + # Per-slot RE design + unseen + which-indices (4 slots) + for (k in seq_len(4L)) { + model_input[[paste0("X_random_effect_", k)]] = prepared_data[[paste0("X_random_effect_", k)]] + model_input[[paste0("X_random_effect_", k, "_unseen")]] = prepared_data[[paste0("X_random_effect_", k, "_unseen")]] + model_input[[paste0("X_random_effect_which_", k)]] = prepared_data[[paste0("X_random_effect_which_", k)]] + } + model_input$ncol_X_random_eff_new = prepared_data$ncol_X_random_eff_new model_input$ncol_X_random_eff_unseen = prepared_data$ncol_X_random_eff_unseen + model_input$unknown_grouping = prepared_data$unknown_grouping - # Add subset of coefficients - # Add subset of coefficients - model_input$length_X_which = length(prepared_data$X_which) + # Subset of coefficients + model_input$length_X_which = length(prepared_data$X_which) model_input$length_XA_which = length(prepared_data$XA_which) - model_input$X_which = prepared_data$X_which - model_input$XA_which = prepared_data$XA_which - - # Add random effect coefficients - model_input$X_random_effect_which = prepared_data$X_random_effect_which - model_input$X_random_effect_which_2 = prepared_data$X_random_effect_which_2 - model_input$length_X_random_effect_which = c( - length(prepared_data$X_random_effect_which), - length(prepared_data$X_random_effect_which_2) - ) + model_input$X_which = prepared_data$X_which + model_input$XA_which = prepared_data$XA_which + + # Length-4 vector of which-index lengths for the random-effect slots + model_input$length_X_random_effect_which = + map_int(seq_len(4L), ~ length(prepared_data[[paste0("X_random_effect_which_", .x)]])) # Should I create an intercept for generate quantities? model_input$create_intercept = prepared_data$create_intercept diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 973632a9..3c77931a 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -352,27 +352,17 @@ sccomp_summarise_posterior_for_estimate <- function( prefix = "c_" ) ) - if (model_input$n_random_eff > 0) { + # Random effect blocks: append a summary for each non-empty slot (1..4). + for (k in seq_len(4L)) { + if (model_input$ncol_X_random_eff[k] == 0) next + X_slot <- model_input[[paste0("X_random_effect_", k)]] abundance_parts <- c( abundance_parts, list(summarise_stan_matrix_for_estimate( fit = fit, model_input = model_input, - stan_parameter = "random_effect", - parameter_names = colnames(model_input$X_random_effect), - probs = probs, - prefix = "c_" - )) - ) - } - if (model_input$n_random_eff > 1) { - abundance_parts <- c( - abundance_parts, - list(summarise_stan_matrix_for_estimate( - fit = fit, - model_input = model_input, - stan_parameter = "random_effect_2", - parameter_names = colnames(model_input$X_random_effect_2), + stan_parameter = paste0("random_effect_", k), + parameter_names = colnames(X_slot), probs = probs, prefix = "c_" )) @@ -555,148 +545,81 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ - # Random effect - - random_effect_covariates = model_input %$% X_random_effect |> colnames() - beta_random_effect_subset <- build_stan_parameter_subset( - contrasts = contrasts, - design_columns = random_effect_covariates, - stan_parameter = "random_effect", - model_input = model_input - ) - beta_random_effect_parameters <- beta_random_effect_subset |> dplyr::pull("parameter") |> unique() - beta_random_effect_variables <- beta_random_effect_subset |> dplyr::pull("variable") |> unique() - - if( - .data |> attr("model_input") %$% n_random_eff > 0 && - ( - contrasts |> is.null() || - length(beta_random_effect_parameters) > 0 - ) - ){ - + # ---------------------------------------------------------------------- + # Random effect draws: extract one slot at a time (1..4) and left-join into + # `draws`. Per-slot logic is identical, so we loop over a helper instead of + # duplicating the block once per slot. + # ---------------------------------------------------------------------- + extract_random_effect_slot = function(slot_idx) { + if (model_input$ncol_X_random_eff[slot_idx] == 0) + return(list(draws = draws, covariates = character(0))) - beta_random_effect = - .data |> - attr("fit") %>% - draws_to_tibble_x_y(beta_random_effect_variables, "C", "M" ) + re_covariates = model_input[[paste0("X_random_effect_", slot_idx)]] |> colnames() + re_subset = build_stan_parameter_subset( + contrasts = contrasts, + design_columns = re_covariates, + stan_parameter = paste0("random_effect_", slot_idx), + model_input = model_input + ) + re_parameters = re_subset |> dplyr::pull("parameter") |> unique() + re_variables = re_subset |> dplyr::pull("variable") |> unique() - # Add last component - other_group_random_effect = - beta_random_effect |> - with_groups(c(C, .chain, .iteration, .draw, .variable ), ~ .x |> summarise(.value = sum(.value))) |> - mutate(.value = -.value, M = beta_random_effect |> pull(M) |> max() + 1) + # No-op when contrasts filter out everything in this slot + if (!is.null(contrasts) && length(re_parameters) == 0) + return(list(draws = draws, covariates = re_covariates)) + re_draws = + .data |> attr("fit") %>% + draws_to_tibble_x_y(re_variables, "C", "M") - beta_random_effect = - beta_random_effect |> - bind_rows( other_group_random_effect ) + # Reconstruct the omitted last cell-group (sum-to-zero closure) + other_group_re = + re_draws |> + with_groups(c(C, .chain, .iteration, .draw, .variable), + ~ .x |> summarise(.value = sum(.value))) |> + mutate(.value = -.value, M = re_draws |> pull(M) |> max() + 1) + re_draws = bind_rows(re_draws, other_group_re) - # Reshape - # Speed up if I have contrasts - if(!contrasts |> is.null()) - beta_random_effect = - beta_random_effect |> - left_join( - random_effect_covariates |> enframe(name = "C", value = "parameters_name"), - by = "C" - ) |> - filter(parameters_name %in% beta_random_effect_parameters) |> - select(-C) |> - pivot_wider(names_from = parameters_name, values_from = .value) + if (!is.null(contrasts)) { + re_draws = re_draws |> + left_join( + re_covariates |> enframe(name = "C", value = "parameters_name"), + by = "C" + ) |> + filter(parameters_name %in% re_parameters) |> + select(-C) |> + pivot_wider(names_from = parameters_name, values_from = .value) + } else { + re_draws = re_draws |> + pivot_wider(names_from = C, values_from = .value) %>% + setNames(colnames(.)[1:5] |> c(re_covariates)) + } - else - beta_random_effect = - beta_random_effect |> - pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(random_effect_covariates)) - - # If I don't have fix nor 1st level random effect - if(draws |> nrow() == 0) - draws = select(beta_random_effect, -.variable) - else - draws = draws |> - left_join(select(beta_random_effect, -.variable), - by = c("M", ".chain", ".iteration", ".draw") - ) + new_draws = + if (nrow(draws) == 0) + select(re_draws, -.variable) + else + draws |> + left_join(select(re_draws, -.variable), + by = c("M", ".chain", ".iteration", ".draw")) - } else { - random_effect_covariates = "" + list(draws = new_draws, covariates = re_covariates) } - # Second random effect. IN THE FUTURE THIS WILL BE VECTORISED TO ARBUTRARY GRI+OUING - random_effect_covariates_2 = model_input %$% X_random_effect_2 |> colnames() - beta_random_effect_subset_2 <- build_stan_parameter_subset( - contrasts = contrasts, - design_columns = random_effect_covariates_2, - stan_parameter = "random_effect_2", - model_input = model_input - ) - beta_random_effect_parameters_2 <- beta_random_effect_subset_2 |> dplyr::pull("parameter") |> unique() - beta_random_effect_variables_2 <- beta_random_effect_subset_2 |> dplyr::pull("variable") |> unique() - - if( - .data |> attr("model_input") %$% n_random_eff > 1 && - ( - contrasts |> is.null() || - length(beta_random_effect_parameters_2) > 0 - ) - ){ - - beta_random_effect_2 = - .data |> - attr("fit") %>% - draws_to_tibble_x_y( beta_random_effect_variables_2, "C", "M" ) - - # Add last component - other_group_random_effect = - beta_random_effect_2 |> - with_groups(c(C, .chain, .iteration, .draw, .variable ), ~ .x |> summarise(.value = sum(.value))) |> - mutate(.value = -.value, M = beta_random_effect_2 |> pull(M) |> max() + 1) - - beta_random_effect_2 = - beta_random_effect_2 |> - bind_rows( other_group_random_effect ) - - # Reshape - # Speed up if I have contrasts - if(!contrasts |> is.null()) - beta_random_effect_2 = - beta_random_effect_2 |> - left_join( - random_effect_covariates_2 |> enframe(name = "C", value = "parameters_name"), - by = "C" - ) |> - filter(parameters_name %in% beta_random_effect_parameters_2) |> - select(-C) |> - pivot_wider(names_from = parameters_name, values_from = .value) - - else - beta_random_effect_2 = - beta_random_effect_2 |> - pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(random_effect_covariates_2)) - - # If I don't have fix nor 1st level random effect - if(draws |> nrow() == 0) - draws = select(beta_random_effect_2, -.variable) - else - draws = draws |> - left_join(select(beta_random_effect_2, -.variable), - by = c("M", ".chain", ".iteration", ".draw") - ) - } else { - random_effect_covariates_2 = "" + random_effect_covariates_all = character(0) + for (k in seq_len(4L)) { + res = extract_random_effect_slot(k) + draws = res$draws + random_effect_covariates_all = c(random_effect_covariates_all, res$covariates) } - - # If I have constrasts calculate - if(!is.null(contrasts)) - draws = - draws |> + # If I have contrasts, calculate + if (!is.null(contrasts)) + draws = + draws |> mutate_from_expr_list(contrasts, ignore_errors = FALSE) |> - select(- any_of(c(beta_covariates, random_effect_covariates) |> setdiff(contrasts)) ) + select(- any_of(c(beta_covariates, random_effect_covariates_all) |> setdiff(contrasts))) draws = draws |> diff --git a/R/utilities.R b/R/utilities.R index e734c20b..45d85d5d 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -149,14 +149,12 @@ incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c "prec_slope_2", "prec_sd", "mix_p", - "random_effect_raw", - "random_effect_raw_2", + # Random effect parameters - one set per slot (1..4) + "random_effect_raw_1", "random_effect_raw_2", "random_effect_raw_3", "random_effect_raw_4", + "random_effect_sigma_raw_1", "random_effect_sigma_raw_2", "random_effect_sigma_raw_3", "random_effect_sigma_raw_4", + "sigma_correlation_factor_1", "sigma_correlation_factor_2", "sigma_correlation_factor_3", "sigma_correlation_factor_4", "random_effect_sigma_mu", "random_effect_sigma_sigma", - "random_effect_sigma_raw", - "sigma_correlation_factor", - "random_effect_sigma_raw_2", - "sigma_correlation_factor_2", "zero_random_effect", # Transformed parameters "beta", @@ -1055,109 +1053,118 @@ data_spread_to_model_input = factor_names_variability = parse_formula(formula_variability) cell_cluster_names = .data_spread %>% select(-!!.sample, -any_of(factor_names), -exposure, -!!.grouping_for_random_effect) %>% colnames() - # Random intercept - if(nrow(random_effect_elements)>0 ) { + # ---------------------------------------------------------------------- + # Random effect blocks: 4 uniform "slots", one block per slot. + # + # Each random-effect clause in the formula (e.g. `(1 + age | tissue)` and + # `(1 | dataset)`) becomes one slot. Slots are independent: each has its + # own n_factors and its own group structure, so no padding across slots. + # + # `prepare_re_slot()` builds one slot from the per-clause design tibble; + # we then map over the parsed clauses and pad to N_RE_SLOTS empty slots, + # so the Stan-side data list is uniformly shaped regardless of how many + # clauses the user wrote. + # ---------------------------------------------------------------------- + N_RE_SLOTS = 4L + n_rows_design = nrow(.data_spread) + + empty_re_slot = list( + X = matrix(0, nrow = n_rows_design, ncol = 0), + X_unseen = matrix(0, nrow = n_rows_design, ncol = 0), + ncol = 0L, + gfi = matrix(integer(0), nrow = 0, ncol = 0), + n_groups = 0L, + n_factors = 0L + ) + + prepare_re_slot = function(design_matrix_tbl, sample_name) { + X = design_matrix_tbl |> column_to_rownames(sample_name) + + is_NA_col = str_detect(colnames(X), "___NA$") + X_unseen = X[, is_NA_col, drop = FALSE] + X = X[, !is_NA_col, drop = FALSE] + + if (ncol(X) == 0) return(empty_re_slot) + gfi = colnames(X) |> + enframe(value = "parameter", name = "order") |> + separate(parameter, c("factor", "group"), "___", remove = FALSE) |> + complete(factor, group, fill = list(order = 0)) |> + select(-parameter) |> + pivot_wider(names_from = group, values_from = order) |> + column_to_rownames("factor") |> + as.matrix() + + list( + X = X, + X_unseen = X_unseen, + ncol = ncol(X), + gfi = gfi, + n_groups = ncol(gfi), + n_factors = nrow(gfi) + ) + } + + if (nrow(random_effect_elements) > 0) { - #check_random_effect_design(.data_spread, any_of(factor_names), random_effect_elements, formula, X) random_effect_grouping = formula |> formula_to_random_effect_formulae() |> mutate(design = map2( formula, grouping, - ~ { - get_random_effect_design3(.data_spread, .x, .y, !!.sample ) - })) + ~ get_random_effect_design3(.data_spread, .x, .y, !!.sample) + )) + + if (nrow(random_effect_grouping) > N_RE_SLOTS) { + stop(sprintf( + "sccomp says: at the moment sccomp supports up to %d random-effect groupings; the formula has %d. Combine related clauses or split the model.", + N_RE_SLOTS, nrow(random_effect_grouping) + )) + } - # Actual parameters, excluding for the sum to one parameters is_random_effect = 1 + n_random_eff = nrow(random_effect_grouping) - random_effect_grouping = - random_effect_grouping |> + random_effect_grouping = random_effect_grouping |> mutate(design_matrix = map( design, ~ ..1 |> select(!!.sample, group___label, value) |> pivot_wider(names_from = group___label, values_from = value) |> mutate(across(everything(), ~ .x |> replace_na(0))) - )) - - - X_random_effect = - random_effect_grouping |> - pull(design_matrix) |> - _[[1]] |> - column_to_rownames(quo_name(.sample)) - - # Separate NA group column into X_random_effect_unseen - X_random_effect_unseen = X_random_effect[, colnames(X_random_effect) |> str_detect("___NA$"), drop = FALSE] - X_random_effect = X_random_effect[, !colnames(X_random_effect) |> str_detect("___NA$"), drop = FALSE] - - # For now that stan does not have tuples, I just allow max two levels - if(random_effect_grouping |> nrow() > 2) stop("sccomp says: at the moment sccomp allow max two groupings") - # This will be modularised with the new stan - if(random_effect_grouping |> nrow() > 1){ - X_random_effect_2 = - random_effect_grouping |> - pull(design_matrix) |> - _[[2]] |> - column_to_rownames(quo_name(.sample)) - - # Separate NA group column into X_random_effect_2_unseen - X_random_effect_2_unseen = X_random_effect_2[, colnames(X_random_effect_2) |> str_detect("___NA$"), drop = FALSE] - X_random_effect_2 = X_random_effect_2[, !colnames(X_random_effect_2) |> str_detect("___NA$"), drop = FALSE] - } - - else X_random_effect_2 = X_random_effect[,0,drop=FALSE] - - n_random_eff = random_effect_grouping |> nrow() - - ncol_X_random_eff = c(ncol(X_random_effect), ncol(X_random_effect_2)) - - # TEMPORARY - group_factor_indexes_for_covariance = - X_random_effect |> - colnames() |> - enframe(value = "parameter", name = "order") |> - separate(parameter, c("factor", "group"), "___", remove = FALSE) |> - complete(factor, group, fill = list(order=0)) |> - select(-parameter) |> - pivot_wider(names_from = group, values_from = order) |> - column_to_rownames("factor") |> as.matrix() - - - - n_groups = group_factor_indexes_for_covariance |> ncol() - - # This will be modularised with the new stan - if(random_effect_grouping |> nrow() > 1) - group_factor_indexes_for_covariance_2 = - X_random_effect_2 |> - colnames() |> - enframe(value = "parameter", name = "order") |> - separate(parameter, c("factor", "group"), "___", remove = FALSE) |> - complete(factor, group, fill = list(order=0)) |> - select(-parameter) |> - pivot_wider(names_from = group, values_from = order) |> - column_to_rownames("factor") |> as.matrix() - else group_factor_indexes_for_covariance_2 = matrix()[0,0, drop=FALSE] - - n_groups = n_groups |> c(group_factor_indexes_for_covariance_2 |> ncol()) - - how_many_factors_in_random_design = list(group_factor_indexes_for_covariance, group_factor_indexes_for_covariance_2) |> map_int(nrow) + )) + re_slots = random_effect_grouping$design_matrix |> + map(prepare_re_slot, sample_name = quo_name(.sample)) } else { - X_random_effect = matrix(rep(1, nrow(.data_spread)))[,0, drop=FALSE] - X_random_effect_2 = matrix(rep(1, nrow(.data_spread)))[,0, drop=FALSE] # This will be modularised with the new stan is_random_effect = 0 - ncol_X_random_eff = c(0,0) - n_random_eff = 0 - n_groups = c(0,0) - how_many_factors_in_random_design = c(0,0) - group_factor_indexes_for_covariance = matrix()[0,0, drop=FALSE] - group_factor_indexes_for_covariance_2 = matrix()[0,0, drop=FALSE] # This will be modularised with the new stan + n_random_eff = 0 + re_slots = list() } + # Pad to exactly N_RE_SLOTS so the Stan data list is uniformly shaped + while (length(re_slots) < N_RE_SLOTS) re_slots = c(re_slots, list(empty_re_slot)) + + # Per-slot variables. Kept as separate names (mirroring the Stan side) + # so each slot is locally inspectable; no clever data structure required. + X_random_effect_1 = re_slots[[1]]$X + X_random_effect_2 = re_slots[[2]]$X + X_random_effect_3 = re_slots[[3]]$X + X_random_effect_4 = re_slots[[4]]$X + + # NOTE: per-slot $X_unseen matrices are available in `re_slots[[k]]$X_unseen` + # but are not shipped via data_for_model (downstream replicate / outlier + # pipelines build their own from new_data). + + group_factor_indexes_for_covariance_1 = re_slots[[1]]$gfi + group_factor_indexes_for_covariance_2 = re_slots[[2]]$gfi + group_factor_indexes_for_covariance_3 = re_slots[[3]]$gfi + group_factor_indexes_for_covariance_4 = re_slots[[4]]$gfi + + ncol_X_random_eff = map_int(re_slots, "ncol") + n_groups = map_int(re_slots, "n_groups") + how_many_factors_in_random_design = map_int(re_slots, "n_factors") + y = .data_spread %>% select(-any_of(factor_names), -exposure, -!!.grouping_for_random_effect) %>% column_to_rownames(quo_name(.sample)) %>% as.matrix() @@ -1192,16 +1199,20 @@ data_spread_to_model_input = bimodal_mean_variability_association = bimodal_mean_variability_association, use_data = use_data, - # Random intercept + # Random intercept - 4 uniform slots (see Stan glm_multi_beta_binomial.stan) is_random_effect = is_random_effect, - ncol_X_random_eff = ncol_X_random_eff, - n_random_eff = n_random_eff, - n_groups = n_groups, - X_random_effect = X_random_effect, + n_random_eff = n_random_eff, + ncol_X_random_eff = ncol_X_random_eff, # length 4 + n_groups = n_groups, # length 4 + how_many_factors_in_random_design = how_many_factors_in_random_design, # length 4 + X_random_effect_1 = X_random_effect_1, X_random_effect_2 = X_random_effect_2, - group_factor_indexes_for_covariance = group_factor_indexes_for_covariance, + X_random_effect_3 = X_random_effect_3, + X_random_effect_4 = X_random_effect_4, + group_factor_indexes_for_covariance_1 = group_factor_indexes_for_covariance_1, group_factor_indexes_for_covariance_2 = group_factor_indexes_for_covariance_2, - how_many_factors_in_random_design = how_many_factors_in_random_design, + group_factor_indexes_for_covariance_3 = group_factor_indexes_for_covariance_3, + group_factor_indexes_for_covariance_4 = group_factor_indexes_for_covariance_4, # For parallel chains grainsize = 1, diff --git a/inst/stan/common_functions.stan b/inst/stan/common_functions.stan index 8f5f8a3d..dc2a35df 100644 --- a/inst/stan/common_functions.stan +++ b/inst/stan/common_functions.stan @@ -90,6 +90,41 @@ ); } + /** + * Build the per-category random-effect matrix for one block (slot). + * + * Combines: (a) hierarchical non-centered build of the per-category SD vector + * from `(sigma_mu, sigma_sigma, sigma_raw[m])`, and (b) `get_random_effect_matrix(...)` + * to apply the LKJ-Cholesky x SD covariance structure to the raw effects. + * One call replaces ~12 lines of per-block code in `transformed parameters`. + * + * Works uniformly for any `n_factors >= 1`. When `n_factors == 1` the + * Cholesky factor is 1x1 = [[1]], the LKJ prior contributes 0 free params, + * and the construction collapses to a per-category scalar `sigma_m * raw`. + */ + matrix build_re_block( + int M, // # of categories/outcomes + int n_groups, // # of groups in this block + int n_factors, // # of factors (>=1) + int ncol, // # cols in this block's design matrix + array[,] int group_factor_indexes, // factor x group -> col index + array[] vector raw_vec, // length ncol, each length M + real sigma_mu, // hierarchical hyperprior mean + real sigma_sigma, // hierarchical hyperprior SD + array[] vector sigma_raw, // length M, each length n_factors + array[] matrix corr_chol // length M, each n_factors x n_factors + ) { + // Per-category SD vector via non-centered hierarchical parameterisation + array[M] vector[n_factors] sigma_vec; + for (m in 1:M) + sigma_vec[m] = exp((sigma_mu + sigma_sigma * sigma_raw[m]) / 3.0); + + return get_random_effect_matrix( + M, n_groups, n_factors, 1, ncol, + group_factor_indexes, raw_vec, sigma_vec, corr_chol + ); + } + // QR-based sum-to-zero functions removed - now using sum_to_zero_vector[K] type row_vector average_by_col(matrix X) { diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 4fb09326..e74600de 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -88,27 +88,30 @@ functions{ matrix beta, int M, - // Random effects - array[] int ncol_X_random_eff, - matrix X_random_effect, // Sliced - matrix X_random_effect_2, // Sliced - matrix random_effect, - matrix random_effect_2, - - // truncation - array[,] int truncation_not_idx_minimal - - ){ - - int N = end-start+1; - - // mu - matrix[M, N] mu = (X[idx_y,] * beta)'; - if(ncol_X_random_eff[1]> 0) - mu = mu + (X_random_effect[idx_y,] * random_effect)'; - - if(ncol_X_random_eff[2]>0 ) - mu = mu + (X_random_effect_2[idx_y,] * random_effect_2)'; + // Random effects (up to 4 uniform slots) + array[] int ncol_X_random_eff, + matrix X_random_effect_1, // Sliced + matrix X_random_effect_2, // Sliced + matrix X_random_effect_3, // Sliced + matrix X_random_effect_4, // Sliced + matrix random_effect_1, + matrix random_effect_2, + matrix random_effect_3, + matrix random_effect_4, + + // truncation + array[,] int truncation_not_idx_minimal + + ){ + + int N = end-start+1; + + // mu = fixed effects + each non-empty random-effect slot + matrix[M, N] mu = (X[idx_y,] * beta)'; + if(ncol_X_random_eff[1]>0) mu = mu + (X_random_effect_1[idx_y,] * random_effect_1)'; + if(ncol_X_random_eff[2]>0) mu = mu + (X_random_effect_2[idx_y,] * random_effect_2)'; + if(ncol_X_random_eff[3]>0) mu = mu + (X_random_effect_3[idx_y,] * random_effect_3)'; + if(ncol_X_random_eff[4]>0) mu = mu + (X_random_effect_4[idx_y,] * random_effect_4)'; for(n in 1:N) mu[,n] = softmax(mu[,n]); @@ -330,21 +333,33 @@ data{ // Does the design icludes intercept int intercept_in_design; - // Random intercept - - // Is the parameters in random effect matrix, minus ther sub to zero parameters, for example if I have four groups, this will be 3 + // ---------------------------------------------------------------------- + // Random effect blocks: up to 4 uniform "slots", one block per slot. + // Each slot has its own n_factors (K) so that no padding is needed across + // slots. A slot with ncol_X_random_eff[k] == 0 is unused (its arrays have + // length 0 and no parameters get sampled). + // + // slot 1 -> *_1 slot 2 -> *_2 slot 3 -> *_3 slot 4 -> *_4 + // + // To go past 4 slots, paste another "slot 4" block in this file and bump + // the array length below from 4 to 5. There is no other architectural + // limit. + // ---------------------------------------------------------------------- int is_random_effect; - // Is the parameters in random effect matrix - array[2] int ncol_X_random_eff; - matrix[N, ncol_X_random_eff[1]] X_random_effect; + array[4] int ncol_X_random_eff; + matrix[N, ncol_X_random_eff[1]] X_random_effect_1; matrix[N, ncol_X_random_eff[2]] X_random_effect_2; + matrix[N, ncol_X_random_eff[3]] X_random_effect_3; + matrix[N, ncol_X_random_eff[4]] X_random_effect_4; - // Covariance setup - array[2] int n_groups; - array[2] int how_many_factors_in_random_design; - array[how_many_factors_in_random_design[1], n_groups[1]] int group_factor_indexes_for_covariance; + // Covariance setup (per slot) + array[4] int n_groups; + array[4] int how_many_factors_in_random_design; + array[how_many_factors_in_random_design[1], n_groups[1]] int group_factor_indexes_for_covariance_1; array[how_many_factors_in_random_design[2], n_groups[2]] int group_factor_indexes_for_covariance_2; + array[how_many_factors_in_random_design[3], n_groups[3]] int group_factor_indexes_for_covariance_3; + array[how_many_factors_in_random_design[4], n_groups[4]] int group_factor_indexes_for_covariance_4; // LOO int enable_loo; @@ -352,9 +367,13 @@ data{ } transformed data{ - // EXCEPTION MADE FOR WINDOWS GENERATE QUANTITIES IF RANDOM EFFECT DO NOT EXIST - int ncol_X_random_eff_WINDOWS_BUG_FIX = max(ncol_X_random_eff[1], 1); - int ncol_X_random_eff_WINDOWS_BUG_FIX_2 = max(ncol_X_random_eff[2], 1); + // Floors of 1 so the per-slot random_effect matrices can be declared + // without a 0-row size on Windows (Stan generates degenerate code there). + // The matrices remain logically empty when the slot is unused. + int ncol_X_random_eff_safe_1 = max(ncol_X_random_eff[1], 1); + int ncol_X_random_eff_safe_2 = max(ncol_X_random_eff[2], 1); + int ncol_X_random_eff_safe_3 = max(ncol_X_random_eff[3], 1); + int ncol_X_random_eff_safe_4 = max(ncol_X_random_eff[4], 1); // For parallelisation array[N] int array_N; @@ -377,23 +396,43 @@ parameters{ array[A] real log_prec_sd; real mix_p; - // Random intercept // array of sum_to_zero_vector for each random effect - array[ncol_X_random_eff[1] * (is_random_effect>0)] sum_to_zero_vector[M] random_effect_raw; + // ---------------------------------------------------------------------- + // Random effect parameters - 4 uniform slots. + // + // For each slot k: + // * random_effect_raw_k : sum_to_zero_vector[M] per design column + // * random_effect_sigma_raw_k : per-category raw SD vector (length n_factors[k]) + // * sigma_correlation_factor_k: per-category Cholesky of correlation matrix + // (n_factors[k] x n_factors[k]; 1x1 = no LKJ work) + // + // Hyperprior scalars sigma_mu / sigma_sigma are shared in length-4 arrays. + // ---------------------------------------------------------------------- + + // Slot 1 + array[ncol_X_random_eff[1] * (ncol_X_random_eff[1]>0)] sum_to_zero_vector[M] random_effect_raw_1; + array[M * (ncol_X_random_eff[1]>0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma_raw_1; + array[M * (ncol_X_random_eff[1]>0)] cholesky_factor_corr[how_many_factors_in_random_design[1] * (ncol_X_random_eff[1]>0)] sigma_correlation_factor_1; + + // Slot 2 array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] sum_to_zero_vector[M] random_effect_raw_2; + array[M * (ncol_X_random_eff[2]>0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_raw_2; + array[M * (ncol_X_random_eff[2]>0)] cholesky_factor_corr[how_many_factors_in_random_design[2] * (ncol_X_random_eff[2]>0)] sigma_correlation_factor_2; - // sd of random intercept - array[2 * (is_random_effect>0)] real random_effect_sigma_mu; - array[2 * (is_random_effect>0)] real random_effect_sigma_sigma; + // Slot 3 + array[ncol_X_random_eff[3] * (ncol_X_random_eff[3]>0)] sum_to_zero_vector[M] random_effect_raw_3; + array[M * (ncol_X_random_eff[3]>0)] vector[how_many_factors_in_random_design[3]] random_effect_sigma_raw_3; + array[M * (ncol_X_random_eff[3]>0)] cholesky_factor_corr[how_many_factors_in_random_design[3] * (ncol_X_random_eff[3]>0)] sigma_correlation_factor_3; - // Covariance - array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma_raw; - array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[1] * (is_random_effect>0)] sigma_correlation_factor; + // Slot 4 + array[ncol_X_random_eff[4] * (ncol_X_random_eff[4]>0)] sum_to_zero_vector[M] random_effect_raw_4; + array[M * (ncol_X_random_eff[4]>0)] vector[how_many_factors_in_random_design[4]] random_effect_sigma_raw_4; + array[M * (ncol_X_random_eff[4]>0)] cholesky_factor_corr[how_many_factors_in_random_design[4] * (ncol_X_random_eff[4]>0)] sigma_correlation_factor_4; - // Covariance - array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_raw_2; - array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[2] * (is_random_effect>0)] sigma_correlation_factor_2; + // Shared hyperprior scalars (one mu, one sigma per slot) + array[4 * (is_random_effect>0)] real random_effect_sigma_mu; + array[4 * (is_random_effect>0)] real random_effect_sigma_sigma; - // If I have just one group + // For models with a single group (kept from the original design) array[is_random_effect>0] real zero_random_effect; @@ -421,69 +460,61 @@ transformed parameters{ real mix_p_scalar = bimodal_mean_variability_association == 1 ? mix_p : 0.5; - // Non centered parameterisation SD of random effects - array[M * (ncol_X_random_eff[1]> 0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma; - if(ncol_X_random_eff[1]> 0) for(m in 1:(M)) random_effect_sigma[m] = random_effect_sigma_mu[1] + random_effect_sigma_sigma[1] * random_effect_sigma_raw[m]; - if(ncol_X_random_eff[1]> 0) for(m in 1:(M)) random_effect_sigma[m] = exp(random_effect_sigma[m]/3.0); - - // Non centered parameterisation SD of random effects 2 - array[M * (ncol_X_random_eff[2]> 0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_2; - if(ncol_X_random_eff[2]> 0) for(m in 1:(M)) random_effect_sigma_2[m] = random_effect_sigma_mu[2] + random_effect_sigma_sigma[2] * random_effect_sigma_raw_2[m]; - if(ncol_X_random_eff[2]> 0) for(m in 1:(M)) random_effect_sigma_2[m] = exp(random_effect_sigma_2[m]/3.0); - - - // avoid 0 - matrix[ncol_X_random_eff_WINDOWS_BUG_FIX * (is_random_effect>0), M] random_effect; - matrix[ncol_X_random_eff_WINDOWS_BUG_FIX_2 * (is_random_effect>0), M] random_effect_2; - - - // random intercept - if(ncol_X_random_eff[1]> 0){ - - // Convert sum_to_zero_vector array to vector array for function call - array[ncol_X_random_eff[1]] vector[M] random_effect_raw_vec; - for(i in 1:ncol_X_random_eff[1]) { - random_effect_raw_vec[i] = to_vector(random_effect_raw[i]); - } - - // Covariate setup - random_effect = - get_random_effect_matrix( - M, - n_groups[1], - how_many_factors_in_random_design[1], - is_random_effect, - ncol_X_random_eff[1], - group_factor_indexes_for_covariance, - random_effect_raw_vec, - random_effect_sigma, - sigma_correlation_factor - ); - + // ---------------------------------------------------------------------- + // Random effect contributions: one matrix per slot. + // + // Per slot, build_re_block() does the per-category SD non-centered build + // and the LKJ-Cholesky x SD covariance construction. Slots with + // ncol_X_random_eff[k] == 0 keep an unused 1xM placeholder (Windows guard) + // and never get touched. + // ---------------------------------------------------------------------- + matrix[ncol_X_random_eff_safe_1 * (is_random_effect>0), M] random_effect_1; + matrix[ncol_X_random_eff_safe_2 * (is_random_effect>0), M] random_effect_2; + matrix[ncol_X_random_eff_safe_3 * (is_random_effect>0), M] random_effect_3; + matrix[ncol_X_random_eff_safe_4 * (is_random_effect>0), M] random_effect_4; + + if (ncol_X_random_eff[1] > 0) { + array[ncol_X_random_eff[1]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[1]) raw_vec[i] = to_vector(random_effect_raw_1[i]); + random_effect_1 = build_re_block( + M, n_groups[1], how_many_factors_in_random_design[1], ncol_X_random_eff[1], + group_factor_indexes_for_covariance_1, raw_vec, + random_effect_sigma_mu[1], random_effect_sigma_sigma[1], + random_effect_sigma_raw_1, sigma_correlation_factor_1 + ); } - // random intercept - if(ncol_X_random_eff[2]>0 ){ + if (ncol_X_random_eff[2] > 0) { + array[ncol_X_random_eff[2]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[2]) raw_vec[i] = to_vector(random_effect_raw_2[i]); + random_effect_2 = build_re_block( + M, n_groups[2], how_many_factors_in_random_design[2], ncol_X_random_eff[2], + group_factor_indexes_for_covariance_2, raw_vec, + random_effect_sigma_mu[2], random_effect_sigma_sigma[2], + random_effect_sigma_raw_2, sigma_correlation_factor_2 + ); + } - // Convert sum_to_zero_vector array to vector array for function call - array[ncol_X_random_eff[2]] vector[M] random_effect_raw_2_vec; - for(i in 1:ncol_X_random_eff[2]) { - random_effect_raw_2_vec[i] = to_vector(random_effect_raw_2[i]); - } + if (ncol_X_random_eff[3] > 0) { + array[ncol_X_random_eff[3]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[3]) raw_vec[i] = to_vector(random_effect_raw_3[i]); + random_effect_3 = build_re_block( + M, n_groups[3], how_many_factors_in_random_design[3], ncol_X_random_eff[3], + group_factor_indexes_for_covariance_3, raw_vec, + random_effect_sigma_mu[3], random_effect_sigma_sigma[3], + random_effect_sigma_raw_3, sigma_correlation_factor_3 + ); + } - // Covariate setup - random_effect_2 = - get_random_effect_matrix( - M, - n_groups[2], - how_many_factors_in_random_design[2], - is_random_effect, - ncol_X_random_eff[2], - group_factor_indexes_for_covariance_2, - random_effect_raw_2_vec, - random_effect_sigma_2, - sigma_correlation_factor_2 - ); + if (ncol_X_random_eff[4] > 0) { + array[ncol_X_random_eff[4]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[4]) raw_vec[i] = to_vector(random_effect_raw_4[i]); + random_effect_4 = build_re_block( + M, n_groups[4], how_many_factors_in_random_design[4], ncol_X_random_eff[4], + group_factor_indexes_for_covariance_4, raw_vec, + random_effect_sigma_mu[4], random_effect_sigma_sigma[4], + random_effect_sigma_raw_4, sigma_correlation_factor_4 + ); } } model{ @@ -510,12 +541,16 @@ model{ beta, M, - // Random effects + // Random effects (4 uniform slots) ncol_X_random_eff, - X_random_effect, + X_random_effect_1, X_random_effect_2, - random_effect, + X_random_effect_3, + X_random_effect_4, + random_effect_1, random_effect_2, + random_effect_3, + random_effect_4, //truncation truncation_not_idx_minimal @@ -574,24 +609,40 @@ model{ for(c in 1:B_intercept_columns) beta_raw[c] ~ normal ( prior_mean_intercept[1], prior_mean_intercept[2] * inv(sqrt(1 - inv(M))) ); if(C>B_intercept_columns) for(c in (B_intercept_columns+1):C) beta_raw[c] ~ normal ( prior_mean_coefficients[1], prior_mean_coefficients[2] * inv(sqrt(1 - inv(M))) ); - // Random intercept - if(is_random_effect>0){ - - for(m in 1:M) random_effect_raw[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); - for(m in 1:M) random_effect_sigma_raw[m] ~ std_normal(); - for(m in 1:M) sigma_correlation_factor[m] ~ lkj_corr_cholesky(2); // LKJ prior for the correlation matrix - + // ---------------------------------------------------------------------- + // Random effect priors. Per-slot block, same pattern; the `if` keeps an + // unused slot's empty-length arrays out of any prior call. The shared + // hyperprior arrays are sampled once, outside the per-slot loop. + // ---------------------------------------------------------------------- + if (is_random_effect > 0) { random_effect_sigma_mu ~ std_normal(); random_effect_sigma_sigma ~ std_normal(); - - // If I have just one group zero_random_effect ~ std_normal(); } - if(ncol_X_random_eff[2]>0){ - for(m in 1:M) random_effect_raw_2[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); - for(m in 1:M) random_effect_sigma_raw_2[m] ~ std_normal(); - for(m in 1:M) sigma_correlation_factor_2[m] ~ lkj_corr_cholesky(2); // LKJ prior for the correlation matrix - } + + if (ncol_X_random_eff[1] > 0) { + for (m in 1:M) random_effect_raw_1[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); + for (m in 1:M) random_effect_sigma_raw_1[m] ~ std_normal(); + for (m in 1:M) sigma_correlation_factor_1[m] ~ lkj_corr_cholesky(2); + } + + if (ncol_X_random_eff[2] > 0) { + for (m in 1:M) random_effect_raw_2[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); + for (m in 1:M) random_effect_sigma_raw_2[m] ~ std_normal(); + for (m in 1:M) sigma_correlation_factor_2[m] ~ lkj_corr_cholesky(2); + } + + if (ncol_X_random_eff[3] > 0) { + for (m in 1:M) random_effect_raw_3[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); + for (m in 1:M) random_effect_sigma_raw_3[m] ~ std_normal(); + for (m in 1:M) sigma_correlation_factor_3[m] ~ lkj_corr_cholesky(2); + } + + if (ncol_X_random_eff[4] > 0) { + for (m in 1:M) random_effect_raw_4[,m] ~ normal(0, inv(sqrt(1 - inv(M)))); + for (m in 1:M) random_effect_sigma_raw_4[m] ~ std_normal(); + for (m in 1:M) sigma_correlation_factor_4[m] ~ lkj_corr_cholesky(2); + } } generated quantities { // LOO @@ -607,11 +658,11 @@ generated quantities { mu = (X * beta)'; - // random intercept - if(ncol_X_random_eff[1]> 0) - mu = mu + (X_random_effect * random_effect)'; - if(ncol_X_random_eff[2]>0 ) - mu = mu + (X_random_effect_2 * random_effect_2)'; + // Each non-empty random-effect slot contributes additively + if(ncol_X_random_eff[1]>0) mu = mu + (X_random_effect_1 * random_effect_1)'; + if(ncol_X_random_eff[2]>0) mu = mu + (X_random_effect_2 * random_effect_2)'; + if(ncol_X_random_eff[3]>0) mu = mu + (X_random_effect_3 * random_effect_3)'; + if(ncol_X_random_eff[4]>0) mu = mu + (X_random_effect_4 * random_effect_4)'; // Calculate proportions From 0799b2d43149403304d2cd3df3a36e25295553bb Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sat, 16 May 2026 17:12:58 +0930 Subject: [PATCH 58/68] Enhance sccomp functions to support reproducibility and improve data handling This commit adds a seed parameter to the sccomp_remove_outliers.sccomp_tbl function to ensure reproducibility of predictive paths based on the posterior's sampling run. Additionally, it updates the unknown_grouping variable in both sccomp_replicate and utilities functions to use a consistent representation with rep(0L, 4L) for clarity. The glm_multi_beta_binomial_generate_data Stan model is also modified to accommodate up to four random effect slots, enhancing its flexibility for modeling. --- R/sccomp_remove_outliers.R | 8 +- R/sccomp_replicate.R | 2 +- R/utilities.R | 4 +- ...glm_multi_beta_binomial_generate_data.stan | 396 +++++++++--------- 4 files changed, 200 insertions(+), 210 deletions(-) diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index 039c8848..b9133be6 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -238,7 +238,10 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, attr(.estimate , "fit")$num_chains() ), threads_per_chain = cores, - sig_figs = sig_figs + sig_figs = sig_figs, + # GQ uses RNG (beta_binomial_rng). Seed with the posterior's sampling run so the + # predictive path is reproducible for a given `sccomp_estimate` draw set. + seed = attr(.estimate, "fit")$metadata()$seed ) @@ -381,7 +384,8 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, parallel_chains = ifelse(inference_method %in% c("variational", "pathfinder"), 1, fit2$num_chains()), threads_per_chain = cores, - sig_figs = sig_figs + sig_figs = sig_figs, + seed = fit2$metadata()$seed ) diff --git a/R/sccomp_replicate.R b/R/sccomp_replicate.R index a23af89c..fbc87b66 100644 --- a/R/sccomp_replicate.R +++ b/R/sccomp_replicate.R @@ -364,7 +364,7 @@ prepare_replicate_data = function(X, replicate_slots = map(seq_len(4L), build_replicate_slot) # setup default unknown_grouping variable for generated quantities - unknown_grouping = c(FALSE, FALSE, FALSE, FALSE) + unknown_grouping = rep(0L, 4L) list( X = new_X, diff --git a/R/utilities.R b/R/utilities.R index 45d85d5d..794ce9ee 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -1304,8 +1304,8 @@ data_spread_to_model_input = nrow() } - # Default all grouping known. This is used for data generation to estimate unknown groupings. - data_for_model$unknown_grouping = c(FALSE, FALSE) + # Default all grouping known (four RE slots; see glm_multi_beta_binomial_generate_data.stan) + data_for_model$unknown_grouping = rep(0L, 4L) # Return diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 5c17ffa5..55d21606 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -4,282 +4,268 @@ functions{ } data { int bimodal_mean_variability_association; - int N; - int N_original; - int M; - int C; - int A; - array[N] int exposure; + int N; + int N_original; + int M; + int C; + int A; + array[N] int exposure; + + // Which columns of fixed / variability design enter the linear predictors + int length_X_which; + int length_XA_which; + array[length_X_which] int X_which; + array[length_XA_which] int XA_which; + matrix[N, length_X_which] X; + matrix[N, length_XA_which] Xa; + + matrix[N_original, C] X_original; + int is_truncated; + real truncation_ajustment; - // Which column of design, coefficient matrices should be used to generate the data - int length_X_which; - int length_XA_which; - array[length_X_which] int X_which; - array[length_XA_which] int XA_which; - matrix[N, length_X_which] X; - matrix[N, length_XA_which] Xa; // The variability design + int is_random_effect; - matrix[N_original, C] X_original; - int is_truncated; - real truncation_ajustment; + // Four uniform random-effect slots (same layout as glm_multi_beta_binomial.stan) + array[4] int ncol_X_random_eff; + array[4] int ncol_X_random_eff_new; - // Random intercept + matrix[N, ncol_X_random_eff_new[1]] X_random_effect_1; + matrix[N, ncol_X_random_eff_new[2]] X_random_effect_2; + matrix[N, ncol_X_random_eff_new[3]] X_random_effect_3; + matrix[N, ncol_X_random_eff_new[4]] X_random_effect_4; - int is_random_effect; + array[4] int n_groups; + array[4] int how_many_factors_in_random_design; - array[2] int length_X_random_effect_which; - array[length_X_random_effect_which[1]] int X_random_effect_which; - array[2] int ncol_X_random_eff; - array[2] int ncol_X_random_eff_new; - matrix[N, ncol_X_random_eff_new[1]] X_random_effect; - matrix[N, ncol_X_random_eff_new[2]] X_random_effect_2; - array[length_X_random_effect_which[2]] int X_random_effect_which_2; + array[how_many_factors_in_random_design[1], n_groups[1]] int group_factor_indexes_for_covariance_1; + array[how_many_factors_in_random_design[2], n_groups[2]] int group_factor_indexes_for_covariance_2; + array[how_many_factors_in_random_design[3], n_groups[3]] int group_factor_indexes_for_covariance_3; + array[how_many_factors_in_random_design[4], n_groups[4]] int group_factor_indexes_for_covariance_4; + + // Per-slot column counts for X_random_effect_which_* arrays (from R: ncol per slot) + array[4] int length_X_random_effect_which; + array[length_X_random_effect_which[1]] int X_random_effect_which_1; + array[length_X_random_effect_which[2]] int X_random_effect_which_2; + array[length_X_random_effect_which[3]] int X_random_effect_which_3; + array[length_X_random_effect_which[4]] int X_random_effect_which_4; - // Should I create intercept for generate quantities int create_intercept; int A_intercept_columns; - // Covariance setup - array[2] int n_groups; - array[2] int how_many_factors_in_random_design; - array[how_many_factors_in_random_design[1], n_groups[1]] int group_factor_indexes_for_covariance; - array[how_many_factors_in_random_design[2], n_groups[2]] int group_factor_indexes_for_covariance_2; + array[4] int unknown_grouping; - array[2] int unknown_grouping; - - // Dimensions for unseen random effects - array[2] int ncol_X_random_eff_unseen; - - // Matrix for unseen random effects - matrix[N, ncol_X_random_eff_unseen[1]] X_random_effect_unseen; + array[4] int ncol_X_random_eff_unseen; + matrix[N, ncol_X_random_eff_unseen[1]] X_random_effect_1_unseen; matrix[N, ncol_X_random_eff_unseen[2]] X_random_effect_2_unseen; + matrix[N, ncol_X_random_eff_unseen[3]] X_random_effect_3_unseen; + matrix[N, ncol_X_random_eff_unseen[4]] X_random_effect_4_unseen; } -transformed data{ - // If needed recreate the intercept +transformed data { matrix[N,1] X_intercept; - - // EXCEPTION MADE FOR WINDOWS GENERATE QUANTITIES IF RANDOM EFFECT DO NOT EXIST - int ncol_X_random_eff_WINDOWS_BUG_FIX = max(ncol_X_random_eff[1], 1); - int ncol_X_random_eff_WINDOWS_BUG_FIX_2 = max(ncol_X_random_eff[2], 1); - X_intercept = to_matrix(rep_vector(1, N)); -} + int ncol_X_random_eff_safe_1 = max(ncol_X_random_eff[1], 1); + int ncol_X_random_eff_safe_2 = max(ncol_X_random_eff[2], 1); + int ncol_X_random_eff_safe_3 = max(ncol_X_random_eff[3], 1); + int ncol_X_random_eff_safe_4 = max(ncol_X_random_eff[4], 1); +} parameters { - - // Keep names/dimensions compatible with fitted draws, but avoid strict - // sum_to_zero validation when reading rounded CSVs in generated quantities. + // Unconstrained vectors so posterior CSVs (rounded sig_figs) still validate; + // we apply sum-to-zero in transformed parameters (same idea as the old GQ model). array[C] vector[M] beta_raw; - matrix[A, M] alpha; // Variability + matrix[A, M] alpha; array[A] ordered[1 + bimodal_mean_variability_association] prec_intercept; array[A] real prec_slope_1; array[A * bimodal_mean_variability_association] real prec_slope_2; array[A] real log_prec_sd; real mix_p; - // Random intercept - array[ncol_X_random_eff[1] * (is_random_effect>0)] vector[M] random_effect_raw; - array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] vector[M] random_effect_raw_2; + array[ncol_X_random_eff[1] * (ncol_X_random_eff[1]>0)] vector[M] random_effect_raw_1; + array[M * (ncol_X_random_eff[1]>0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma_raw_1; + array[M * (ncol_X_random_eff[1]>0)] cholesky_factor_corr[how_many_factors_in_random_design[1] * (ncol_X_random_eff[1]>0)] sigma_correlation_factor_1; - // sd of random intercept - array[2 * (is_random_effect>0)] real random_effect_sigma_mu; - array[2 * (is_random_effect>0)] real random_effect_sigma_sigma; + array[ncol_X_random_eff[2] * (ncol_X_random_eff[2]>0)] vector[M] random_effect_raw_2; + array[M * (ncol_X_random_eff[2]>0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_raw_2; + array[M * (ncol_X_random_eff[2]>0)] cholesky_factor_corr[how_many_factors_in_random_design[2] * (ncol_X_random_eff[2]>0)] sigma_correlation_factor_2; - // Covariance - array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma_raw; - array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[1] * (is_random_effect>0)] sigma_correlation_factor; + array[ncol_X_random_eff[3] * (ncol_X_random_eff[3]>0)] vector[M] random_effect_raw_3; + array[M * (ncol_X_random_eff[3]>0)] vector[how_many_factors_in_random_design[3]] random_effect_sigma_raw_3; + array[M * (ncol_X_random_eff[3]>0)] cholesky_factor_corr[how_many_factors_in_random_design[3] * (ncol_X_random_eff[3]>0)] sigma_correlation_factor_3; - // Covariance - array[M * (is_random_effect>0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_raw_2; - array[M * (is_random_effect>0)] cholesky_factor_corr[how_many_factors_in_random_design[2] * (is_random_effect>0)] sigma_correlation_factor_2; + array[ncol_X_random_eff[4] * (ncol_X_random_eff[4]>0)] vector[M] random_effect_raw_4; + array[M * (ncol_X_random_eff[4]>0)] vector[how_many_factors_in_random_design[4]] random_effect_sigma_raw_4; + array[M * (ncol_X_random_eff[4]>0)] cholesky_factor_corr[how_many_factors_in_random_design[4] * (ncol_X_random_eff[4]>0)] sigma_correlation_factor_4; - // If I have just one group + array[4 * (is_random_effect>0)] real random_effect_sigma_mu; + array[4 * (is_random_effect>0)] real random_effect_sigma_sigma; array[is_random_effect>0] real zero_random_effect; - } - transformed parameters { array[A] real prec_intercept_1; array[A * bimodal_mean_variability_association] real prec_intercept_2; + array[A] real prec_sd; for (a in 1:A) { prec_intercept_1[a] = prec_intercept[a][1]; + prec_sd[a] = exp(log_prec_sd[a]); if (bimodal_mean_variability_association == 1) prec_intercept_2[a] = prec_intercept[a][2]; } -} - -generated quantities{ - - array[N, M] int counts_uncorrected; - - // Matrix for correcting for exposure - matrix[N, M] counts; - - // Vector of the generated exposure - array[N] real generated_exposure; matrix[C,M] beta; - - // Convert vectors to matrix and enforce sum-to-zero numerically. - for(c in 1:C) { + for (c in 1:C) { beta[c,] = to_row_vector(normalize_sum_to_zero(beta_raw[c])); } - // Subset for mean and deviation - matrix[length_X_which,M] my_beta = beta[X_which,]; - matrix[length_XA_which,M] my_alpha = alpha[XA_which,]; + real mix_p_scalar = bimodal_mean_variability_association == 1 ? mix_p : 0.5; + + matrix[ncol_X_random_eff_safe_1 * (is_random_effect>0), M] random_effect_1; + matrix[ncol_X_random_eff_safe_2 * (is_random_effect>0), M] random_effect_2; + matrix[ncol_X_random_eff_safe_3 * (is_random_effect>0), M] random_effect_3; + matrix[ncol_X_random_eff_safe_4 * (is_random_effect>0), M] random_effect_4; + + if (ncol_X_random_eff[1] > 0) { + array[ncol_X_random_eff[1]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[1]) raw_vec[i] = normalize_sum_to_zero(random_effect_raw_1[i]); + random_effect_1 = build_re_block( + M, n_groups[1], how_many_factors_in_random_design[1], ncol_X_random_eff[1], + group_factor_indexes_for_covariance_1, raw_vec, + random_effect_sigma_mu[1], random_effect_sigma_sigma[1], + random_effect_sigma_raw_1, sigma_correlation_factor_1 + ); + } + if (ncol_X_random_eff[2] > 0) { + array[ncol_X_random_eff[2]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[2]) raw_vec[i] = normalize_sum_to_zero(random_effect_raw_2[i]); + random_effect_2 = build_re_block( + M, n_groups[2], how_many_factors_in_random_design[2], ncol_X_random_eff[2], + group_factor_indexes_for_covariance_2, raw_vec, + random_effect_sigma_mu[2], random_effect_sigma_sigma[2], + random_effect_sigma_raw_2, sigma_correlation_factor_2 + ); + } + if (ncol_X_random_eff[3] > 0) { + array[ncol_X_random_eff[3]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[3]) raw_vec[i] = normalize_sum_to_zero(random_effect_raw_3[i]); + random_effect_3 = build_re_block( + M, n_groups[3], how_many_factors_in_random_design[3], ncol_X_random_eff[3], + group_factor_indexes_for_covariance_3, raw_vec, + random_effect_sigma_mu[3], random_effect_sigma_sigma[3], + random_effect_sigma_raw_3, sigma_correlation_factor_3 + ); + } + if (ncol_X_random_eff[4] > 0) { + array[ncol_X_random_eff[4]] vector[M] raw_vec; + for (i in 1:ncol_X_random_eff[4]) raw_vec[i] = normalize_sum_to_zero(random_effect_raw_4[i]); + random_effect_4 = build_re_block( + M, n_groups[4], how_many_factors_in_random_design[4], ncol_X_random_eff[4], + group_factor_indexes_for_covariance_4, raw_vec, + random_effect_sigma_mu[4], random_effect_sigma_sigma[4], + random_effect_sigma_raw_4, sigma_correlation_factor_4 + ); + } +} +model { +} +generated quantities { + array[N, M] int counts_uncorrected; + matrix[N, M] counts; + array[N] real generated_exposure; - matrix[M,N] mu; - matrix[M,N] precision; + matrix[length_X_which, M] my_beta = beta[X_which, ]; + matrix[length_XA_which, M] my_alpha = alpha[XA_which, ]; - // If needed recreate the intercept - if(create_intercept == 1){ + matrix[M, N] mu; + matrix[M, N] precision; - // Create mean and deviation + if (create_intercept == 1) { mu = ( append_col( - to_matrix(rep_vector(1, N)), // Intercept - X // Rest + to_matrix(rep_vector(1, N)), + X ) * append_row( - average_by_col(beta[1:A_intercept_columns,]), // Intercept - my_beta // Rest + average_by_col(beta[1:A_intercept_columns, ]), + my_beta ) )'; precision = ( append_col( - to_matrix(rep_vector(1, N)), // Intercept - Xa // Rest + to_matrix(rep_vector(1, N)), + Xa ) * append_row( - average_by_col(alpha[1:A_intercept_columns,]), // Intercept - my_alpha // Rest + average_by_col(alpha[1:A_intercept_columns, ]), + my_alpha ) )' / (is_truncated ? truncation_ajustment : 1); - - } - else { - // Create mean and deviation + } else { mu = (X * my_beta)'; precision = (Xa * my_alpha)' / (is_truncated ? truncation_ajustment : 1); - } - // Non centered parameterisation SD of random effects - array[M * (ncol_X_random_eff[1]> 0)] vector[how_many_factors_in_random_design[1]] random_effect_sigma; - if(ncol_X_random_eff[1]> 0) for(m in 1:M) random_effect_sigma[m] = random_effect_sigma_mu[1] + random_effect_sigma_sigma[1] * random_effect_sigma_raw[m]; - if(ncol_X_random_eff[1]> 0) for(m in 1:M) random_effect_sigma[m] = exp(random_effect_sigma[m]/3.0); - - // Non centered parameterisation SD of random effects 2 - array[M * (ncol_X_random_eff[2]> 0)] vector[how_many_factors_in_random_design[2]] random_effect_sigma_2; - if(ncol_X_random_eff[2]> 0) for(m in 1:M) random_effect_sigma_2[m] = random_effect_sigma_mu[2] + random_effect_sigma_sigma[2] * random_effect_sigma_raw_2[m]; - if(ncol_X_random_eff[2]> 0) for(m in 1:M) random_effect_sigma_2[m] = exp(random_effect_sigma_2[m]/3.0); - - // Random intercept - matrix[ncol_X_random_eff[1] * (is_random_effect>0), M] random_effect; - matrix[ncol_X_random_eff[2] * (is_random_effect>0), M] random_effect_2; - - // For first random effect - if(length_X_random_effect_which[1]>0) { - - // Convert vector array and enforce sum-to-zero numerically - array[ncol_X_random_eff[1]] vector[M] random_effect_raw_vec; - for(i in 1:ncol_X_random_eff[1]) { - random_effect_raw_vec[i] = normalize_sum_to_zero(random_effect_raw[i]); + if (ncol_X_random_eff[1] > 0) { + mu = mu + (X_random_effect_1 * random_effect_1[X_random_effect_which_1, ])'; + if (ncol_X_random_eff_unseen[1] > 0) { + matrix[ncol_X_random_eff_unseen[1], M] unseen = + to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[1] * M), + ncol_X_random_eff_unseen[1], M); + for (i in 1:ncol_X_random_eff_unseen[1]) + unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); + mu = mu + (X_random_effect_1_unseen * unseen)'; } - - // Generate random effects matrix - either from fitted effects or random draws - - // Get transformed random effects - random_effect = get_random_effect_matrix( - M, - n_groups[1], - how_many_factors_in_random_design[1], - is_random_effect, - ncol_X_random_eff[1], - group_factor_indexes_for_covariance, - random_effect_raw_vec, - random_effect_sigma, - sigma_correlation_factor - ); - - // Apply random effects - mu = mu + (X_random_effect * random_effect[X_random_effect_which,])'; - - // Add random effects for unseen groups if they exist - if(ncol_X_random_eff_unseen[1] > 0) { - matrix[ncol_X_random_eff_unseen[1], M] unseen_random_effect = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[1] * M), ncol_X_random_eff_unseen[1], M); - - // Apply sum-to-zero constraint to unseen random effects - for(i in 1:ncol_X_random_eff_unseen[1]) { - unseen_random_effect[i,] = to_row_vector(normalize_sum_to_zero(to_vector(unseen_random_effect[i,]))); - } - - mu = mu + (X_random_effect_unseen * unseen_random_effect)'; + } + if (ncol_X_random_eff[2] > 0) { + mu = mu + (X_random_effect_2 * random_effect_2[X_random_effect_which_2, ])'; + if (ncol_X_random_eff_unseen[2] > 0) { + matrix[ncol_X_random_eff_unseen[2], M] unseen = + to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[2] * M), + ncol_X_random_eff_unseen[2], M); + for (i in 1:ncol_X_random_eff_unseen[2]) + unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); + mu = mu + (X_random_effect_2_unseen * unseen)'; } } - - // For second random effect - if(length_X_random_effect_which[2]>0) { - - // Convert vector array and enforce sum-to-zero numerically - array[ncol_X_random_eff[2]] vector[M] random_effect_raw_2_vec; - for(i in 1:ncol_X_random_eff[2]) { - random_effect_raw_2_vec[i] = normalize_sum_to_zero(random_effect_raw_2[i]); + if (ncol_X_random_eff[3] > 0) { + mu = mu + (X_random_effect_3 * random_effect_3[X_random_effect_which_3, ])'; + if (ncol_X_random_eff_unseen[3] > 0) { + matrix[ncol_X_random_eff_unseen[3], M] unseen = + to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[3] * M), + ncol_X_random_eff_unseen[3], M); + for (i in 1:ncol_X_random_eff_unseen[3]) + unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); + mu = mu + (X_random_effect_3_unseen * unseen)'; } - // Generate random effects matrix - either from fitted effects or random draws - - // Get transformed random effects - random_effect_2 = get_random_effect_matrix( - M, - n_groups[2], - how_many_factors_in_random_design[2], - is_random_effect, - ncol_X_random_eff[2], - group_factor_indexes_for_covariance_2, - random_effect_raw_2_vec, - random_effect_sigma_2, - sigma_correlation_factor_2 - ); - - // Apply random effects - mu = mu + (X_random_effect_2 * random_effect_2[X_random_effect_which_2,])'; - - // Add random effects for unseen groups if they exist - if(ncol_X_random_eff_unseen[2] > 0) { - matrix[ncol_X_random_eff_unseen[2], M] unseen_random_effect_2 = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[2] * M), ncol_X_random_eff_unseen[2], M); - - // Apply sum-to-zero constraint to unseen random effects - for(i in 1:ncol_X_random_eff_unseen[2]) { - unseen_random_effect_2[i,] = to_row_vector(normalize_sum_to_zero(to_vector(unseen_random_effect_2[i,]))); - } - - mu = mu + (X_random_effect_2_unseen * unseen_random_effect_2)'; + } + if (ncol_X_random_eff[4] > 0) { + mu = mu + (X_random_effect_4 * random_effect_4[X_random_effect_which_4, ])'; + if (ncol_X_random_eff_unseen[4] > 0) { + matrix[ncol_X_random_eff_unseen[4], M] unseen = + to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[4] * M), + ncol_X_random_eff_unseen[4], M); + for (i in 1:ncol_X_random_eff_unseen[4]) + unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); + mu = mu + (X_random_effect_4_unseen * unseen)'; } } - // Save unconstrained predictors before softmax - matrix[M,N] mu_unconstrained = mu; + matrix[M, N] mu_unconstrained = mu; - // Calculate proportions - for(i in 1:N) mu[,i] = softmax(mu[,i]); + for (i in 1:N) { + mu[, i] = softmax(mu[, i]); + } - // Generate - for(i in 1:N) { - counts_uncorrected[i,] = beta_binomial_rng( - exposure[i], - mu[,i] .* exp(precision[,i]), - (1.0 - mu[,i]) .* exp(precision[,i]) - ); - } + for (i in 1:N) { + counts_uncorrected[i, ] = beta_binomial_rng( + exposure[i], + mu[, i] .* exp(precision[, i]), + (1.0 - mu[, i]) .* exp(precision[, i]) + ); + } - // Calculate the generated exposure - for(n in 1:N) generated_exposure[n] = max( sum(counts_uncorrected[n]), 1); // avoid dividing by zero - for(n in 1:N) counts[n] = to_row_vector(counts_uncorrected[n]) / generated_exposure[n] * exposure[n]; + for (n in 1:N) + generated_exposure[n] = fmax(sum(to_vector(counts_uncorrected[n])), 1); + for (n in 1:N) + counts[n] = to_row_vector(counts_uncorrected[n]) / generated_exposure[n] * exposure[n]; } - - From f130eee1aa4bc9945a2f699e47a0f580f820c694 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sat, 16 May 2026 18:20:04 +0930 Subject: [PATCH 59/68] Refactor glm_multi_beta_binomial_generate_data Stan model to modularize random effect contributions This commit introduces two new functions, add_seen_random_effect_contribution and add_unseen_random_effect_contribution_rng, to streamline the addition of seen and unseen random effects in the glm_multi_beta_binomial_generate_data Stan model. This refactoring enhances code readability and maintainability while preserving the model's functionality for handling multiple random effects. --- ...glm_multi_beta_binomial_generate_data.stan | 76 ++++++++++--------- 1 file changed, 40 insertions(+), 36 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial_generate_data.stan b/inst/stan/glm_multi_beta_binomial_generate_data.stan index 55d21606..4427d86c 100755 --- a/inst/stan/glm_multi_beta_binomial_generate_data.stan +++ b/inst/stan/glm_multi_beta_binomial_generate_data.stan @@ -1,6 +1,26 @@ functions{ #include common_functions.stan + // Linear predictor contributions for random-effect design blocks; mu is M × N (types × samples). + matrix add_seen_random_effect_contribution(matrix mu_mn, + matrix x_n_times_k, + matrix re_all_rows_times_m, + array[] int re_row_index) { + return mu_mn + (x_n_times_k * re_all_rows_times_m[re_row_index, ])'; + } + + matrix add_unseen_random_effect_contribution_rng(matrix mu_mn, + matrix x_unseen_n_times_u, + int ncol_u, + int M_param) { + matrix[ncol_u, M_param] unseen = + to_matrix(rep_vector(std_normal_rng(), ncol_u * M_param), + ncol_u, M_param); + for (i in 1:ncol_u) + unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); + return mu_mn + (x_unseen_n_times_u * unseen)'; + } + } data { int bimodal_mean_variability_association; @@ -206,48 +226,32 @@ generated quantities { } if (ncol_X_random_eff[1] > 0) { - mu = mu + (X_random_effect_1 * random_effect_1[X_random_effect_which_1, ])'; - if (ncol_X_random_eff_unseen[1] > 0) { - matrix[ncol_X_random_eff_unseen[1], M] unseen = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[1] * M), - ncol_X_random_eff_unseen[1], M); - for (i in 1:ncol_X_random_eff_unseen[1]) - unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); - mu = mu + (X_random_effect_1_unseen * unseen)'; - } + mu = add_seen_random_effect_contribution(mu, X_random_effect_1, random_effect_1, + X_random_effect_which_1); + if (ncol_X_random_eff_unseen[1] > 0) + mu = add_unseen_random_effect_contribution_rng(mu, X_random_effect_1_unseen, + ncol_X_random_eff_unseen[1], M); } if (ncol_X_random_eff[2] > 0) { - mu = mu + (X_random_effect_2 * random_effect_2[X_random_effect_which_2, ])'; - if (ncol_X_random_eff_unseen[2] > 0) { - matrix[ncol_X_random_eff_unseen[2], M] unseen = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[2] * M), - ncol_X_random_eff_unseen[2], M); - for (i in 1:ncol_X_random_eff_unseen[2]) - unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); - mu = mu + (X_random_effect_2_unseen * unseen)'; - } + mu = add_seen_random_effect_contribution(mu, X_random_effect_2, random_effect_2, + X_random_effect_which_2); + if (ncol_X_random_eff_unseen[2] > 0) + mu = add_unseen_random_effect_contribution_rng(mu, X_random_effect_2_unseen, + ncol_X_random_eff_unseen[2], M); } if (ncol_X_random_eff[3] > 0) { - mu = mu + (X_random_effect_3 * random_effect_3[X_random_effect_which_3, ])'; - if (ncol_X_random_eff_unseen[3] > 0) { - matrix[ncol_X_random_eff_unseen[3], M] unseen = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[3] * M), - ncol_X_random_eff_unseen[3], M); - for (i in 1:ncol_X_random_eff_unseen[3]) - unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); - mu = mu + (X_random_effect_3_unseen * unseen)'; - } + mu = add_seen_random_effect_contribution(mu, X_random_effect_3, random_effect_3, + X_random_effect_which_3); + if (ncol_X_random_eff_unseen[3] > 0) + mu = add_unseen_random_effect_contribution_rng(mu, X_random_effect_3_unseen, + ncol_X_random_eff_unseen[3], M); } if (ncol_X_random_eff[4] > 0) { - mu = mu + (X_random_effect_4 * random_effect_4[X_random_effect_which_4, ])'; - if (ncol_X_random_eff_unseen[4] > 0) { - matrix[ncol_X_random_eff_unseen[4], M] unseen = - to_matrix(rep_vector(std_normal_rng(), ncol_X_random_eff_unseen[4] * M), - ncol_X_random_eff_unseen[4], M); - for (i in 1:ncol_X_random_eff_unseen[4]) - unseen[i, ] = to_row_vector(normalize_sum_to_zero(to_vector(unseen[i, ]))); - mu = mu + (X_random_effect_4_unseen * unseen)'; - } + mu = add_seen_random_effect_contribution(mu, X_random_effect_4, random_effect_4, + X_random_effect_which_4); + if (ncol_X_random_eff_unseen[4] > 0) + mu = add_unseen_random_effect_contribution_rng(mu, X_random_effect_4_unseen, + ncol_X_random_eff_unseen[4], M); } matrix[M, N] mu_unconstrained = mu; From b72e378571dc420180235d60f5602075df2ceb29 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sat, 16 May 2026 18:38:27 +0930 Subject: [PATCH 60/68] Add debug print statement for y values in glm_multi_beta_binomial Stan model This commit introduces a debug print statement to output the values of y for filtered indices in the glm_multi_beta_binomial Stan model. This addition aims to assist in troubleshooting and verifying the data being processed during model execution. --- inst/stan/glm_multi_beta_binomial.stan | 3 +++ 1 file changed, 3 insertions(+) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 4fb09326..7a715856 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -120,6 +120,9 @@ functions{ vector[N*M] precision_array = to_vector(exp(precision)); int W = count_filtered_indices(truncation_not_idx_minimal, idx_y); + // Debug + print(to_array_1d(y[idx_y,])); + // truncation if(W == 0){ From d5c4445dc6f66ff5c38ece5a1844a91d24b3a998 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sat, 16 May 2026 18:39:47 +0930 Subject: [PATCH 61/68] Remove debug print statement for y values in glm_multi_beta_binomial Stan model This commit removes the previously added debug print statement that outputted the values of y for filtered indices in the glm_multi_beta_binomial Stan model. The removal aims to clean up the code and eliminate unnecessary output during model execution. --- inst/stan/glm_multi_beta_binomial.stan | 3 --- 1 file changed, 3 deletions(-) diff --git a/inst/stan/glm_multi_beta_binomial.stan b/inst/stan/glm_multi_beta_binomial.stan index 7a715856..4fb09326 100755 --- a/inst/stan/glm_multi_beta_binomial.stan +++ b/inst/stan/glm_multi_beta_binomial.stan @@ -120,9 +120,6 @@ functions{ vector[N*M] precision_array = to_vector(exp(precision)); int W = count_filtered_indices(truncation_not_idx_minimal, idx_y); - // Debug - print(to_array_1d(y[idx_y,])); - // truncation if(W == 0){ From 104c0dc8fd4dac1561271fe16fde11e3cf57dd1e Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sun, 17 May 2026 13:13:27 +0930 Subject: [PATCH 62/68] Update scatterplot and boxplot functions to use 'linewidth' and 'median.linewidth' parameters This commit modifies the 'plot_scatterplot' and 'plot_boxplot' functions to replace the 'fatten' parameter with 'linewidth' and 'median.linewidth', respectively. These changes enhance the clarity of the code and improve the visual representation of the plots. --- R/plot_scatterplot.R | 2 +- R/sccomp_boxplot.R | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/plot_scatterplot.R b/R/plot_scatterplot.R index 32e24502..d09b73e1 100644 --- a/R/plot_scatterplot.R +++ b/R/plot_scatterplot.R @@ -147,7 +147,7 @@ plot_scatterplot = function( geom_smooth( aes(!!as.symbol(factor_of_interest), proportion, fill = name), data = data_proportion , - fatten = 0.5, + linewidth = 0.5, lwd=0.5, color = "black", span = 1 diff --git a/R/sccomp_boxplot.R b/R/sccomp_boxplot.R index bf9d0a24..600b968b 100644 --- a/R/sccomp_boxplot.R +++ b/R/sccomp_boxplot.R @@ -283,7 +283,7 @@ plot_boxplot = function( aes(!!as.symbol(factor_of_interest), generated_proportions), fun.data = calc_boxplot_stat, geom = "boxplot", - fatten = 0.5, + median.linewidth = 0.5, lwd = 0.2, data = simulated_proportion %>% inner_join(data_proportion %>% distinct(!!as.symbol(factor_of_interest), !!.cell_group)), @@ -307,7 +307,7 @@ plot_boxplot = function( data = data_proportion |> mutate(!!as.symbol(factor_of_interest) := as.character(!!as.symbol(factor_of_interest))) , - fatten = 0.5, + median.linewidth = 0.5, lwd=0.5 ) } else { @@ -321,7 +321,7 @@ plot_boxplot = function( data_proportion |> mutate(!!as.symbol(factor_of_interest) := as.character(!!as.symbol(factor_of_interest))) %>% left_join(significance_colors, by = c(quo_name(.cell_group), factor_of_interest)), - fatten = 0.5, + median.linewidth = 0.5, lwd=0.5 ) } From a06e0339fee3ec0742a986457c9628bcc93cd671 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sun, 17 May 2026 13:14:17 +0930 Subject: [PATCH 63/68] Implement random effect draws extraction and enhance contrast handling in sccomp functions This commit introduces the `add_random_effect_draws` function to streamline the extraction of random effect draws, improving efficiency by avoiding code duplication. It also enhances the handling of contrasts in the `get_abundance_contrast_draws` function, including a warning for missing parameters in the model. These changes improve code clarity and maintainability while ensuring better data handling for random effects. --- R/sccomp_test.R | 155 +++++++++++++++++++++++++----------------------- 1 file changed, 81 insertions(+), 74 deletions(-) diff --git a/R/sccomp_test.R b/R/sccomp_test.R index 3c77931a..f9208b84 100644 --- a/R/sccomp_test.R +++ b/R/sccomp_test.R @@ -494,6 +494,68 @@ build_stan_parameter_subset <- function(contrasts, design_columns, stan_paramete ) } +# ---------------------------------------------------------------------- +# Random effect draws: extract one slot at a time (1..4) and left-join into +# `draws`. Per-slot logic is identical, so we loop over a helper instead of +# duplicating the block once per slot. +# ---------------------------------------------------------------------- +# This is still inefficient as it is drawing all random effects regardless of the ciontrasts +add_random_effect_draws = function(draws, contrasts, model_input, slot_idx, fit) { + + re_covariates = model_input[[paste0("X_random_effect_", slot_idx)]] |> colnames() + re_subset = build_stan_parameter_subset( + contrasts = contrasts, + design_columns = re_covariates, + stan_parameter = paste0("random_effect_", slot_idx), + model_input = model_input + ) + re_parameters = re_subset |> dplyr::pull("parameter") |> unique() + re_variables = re_subset |> dplyr::pull("variable") |> unique() + + # No-op when contrasts filter out everything in this slot + if (!is.null(contrasts) && length(re_parameters) == 0) + return(list(draws = draws, covariates = re_covariates)) + + re_draws = + fit |> + draws_to_tibble_x_y(re_variables, "C", "M") + + # Reconstruct the omitted last cell-group (sum-to-zero closure) + other_group_re = + re_draws |> + with_groups(c(C, .chain, .iteration, .draw, .variable), + ~ .x |> summarise(.value = sum(.value))) |> + mutate(.value = -.value, M = re_draws |> pull(M) |> max() + 1) + + re_draws = bind_rows(re_draws, other_group_re) + + if (!is.null(contrasts)) { + re_draws = re_draws |> + left_join( + re_covariates |> enframe(name = "C", value = "parameters_name"), + by = "C" + ) |> + filter(parameters_name %in% re_parameters) |> + select(-C) |> + pivot_wider(names_from = parameters_name, values_from = .value) + } else { + re_draws = re_draws |> + pivot_wider(names_from = C, values_from = .value) %>% + setNames(colnames(.)[1:5] |> c(re_covariates)) + } + + new_draws = + if (nrow(draws) == 0) + select(re_draws, -.variable) + else + draws |> + left_join(select(re_draws, -.variable), + by = c("M", ".chain", ".iteration", ".draw")) + + list(draws = new_draws, covariates = re_covariates) +} + + # this can be helpful if we want to draw PCA with uncertainty get_abundance_contrast_draws = function(.data, contrasts = NULL){ @@ -530,7 +592,9 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ beta_parameters <- beta_subset |> dplyr::pull("parameter") |> unique() beta_variable_subset <- beta_subset |> dplyr::pull("variable") |> unique() - + if(length(beta_variable_subset) == 0 ) + warning(sprintf("sccomp says: These components of your contrasts are not present in the model as parameters: %s. Factors including special characters, e.g. \"(Intercept)\" require backquotes e.g. \"`(Intercept)`\" ", paste(contrasts, sep = ", "))) + draws = .data |> attr("fit") %>% @@ -543,85 +607,27 @@ get_abundance_contrast_draws = function(.data, contrasts = NULL){ pivot_wider(names_from = parameters_name, values_from = .value) |> select(-.variable) - - - # ---------------------------------------------------------------------- - # Random effect draws: extract one slot at a time (1..4) and left-join into - # `draws`. Per-slot logic is identical, so we loop over a helper instead of - # duplicating the block once per slot. - # ---------------------------------------------------------------------- - extract_random_effect_slot = function(slot_idx) { - if (model_input$ncol_X_random_eff[slot_idx] == 0) - return(list(draws = draws, covariates = character(0))) - - re_covariates = model_input[[paste0("X_random_effect_", slot_idx)]] |> colnames() - re_subset = build_stan_parameter_subset( - contrasts = contrasts, - design_columns = re_covariates, - stan_parameter = paste0("random_effect_", slot_idx), - model_input = model_input - ) - re_parameters = re_subset |> dplyr::pull("parameter") |> unique() - re_variables = re_subset |> dplyr::pull("variable") |> unique() + # RANDOM EFFECTS - # No-op when contrasts filter out everything in this slot - if (!is.null(contrasts) && length(re_parameters) == 0) - return(list(draws = draws, covariates = re_covariates)) - - re_draws = - .data |> attr("fit") %>% - draws_to_tibble_x_y(re_variables, "C", "M") - - # Reconstruct the omitted last cell-group (sum-to-zero closure) - other_group_re = - re_draws |> - with_groups(c(C, .chain, .iteration, .draw, .variable), - ~ .x |> summarise(.value = sum(.value))) |> - mutate(.value = -.value, M = re_draws |> pull(M) |> max() + 1) - - re_draws = bind_rows(re_draws, other_group_re) - - if (!is.null(contrasts)) { - re_draws = re_draws |> - left_join( - re_covariates |> enframe(name = "C", value = "parameters_name"), - by = "C" - ) |> - filter(parameters_name %in% re_parameters) |> - select(-C) |> - pivot_wider(names_from = parameters_name, values_from = .value) - } else { - re_draws = re_draws |> - pivot_wider(names_from = C, values_from = .value) %>% - setNames(colnames(.)[1:5] |> c(re_covariates)) - } - - new_draws = - if (nrow(draws) == 0) - select(re_draws, -.variable) - else - draws |> - left_join(select(re_draws, -.variable), - by = c("M", ".chain", ".iteration", ".draw")) - - list(draws = new_draws, covariates = re_covariates) - } - random_effect_covariates_all = character(0) + for (k in seq_len(4L)) { - res = extract_random_effect_slot(k) - draws = res$draws - random_effect_covariates_all = c(random_effect_covariates_all, res$covariates) + if (model_input$ncol_X_random_eff[k] == 0) next + res <- add_random_effect_draws(draws, contrasts, model_input, k, attr(.data, "fit")) + draws <- res$draws + random_effect_covariates_all <- c(random_effect_covariates_all, res$covariates) } - # If I have contrasts, calculate - if (!is.null(contrasts)) + # CALCULATE CONTRAST + if (!is.null(contrasts)){ draws = - draws |> - mutate_from_expr_list(contrasts, ignore_errors = FALSE) |> - select(- any_of(c(beta_covariates, random_effect_covariates_all) |> setdiff(contrasts))) - + draws |> + mutate_from_expr_list(contrasts, ignore_errors = FALSE) |> + select(- any_of(c(beta_covariates, random_effect_covariates_all) |> setdiff(contrasts))) + + } + # RESHAPE draws = draws |> pivot_longer(-c(1:4), names_to = "parameter", values_to = ".value") |> @@ -776,7 +782,7 @@ mutate_from_expr_list = function(x, formula_expr, ignore_errors = TRUE){ # Check if all elements of contrasts are in the parameter parameter_names = x |> colnames() - + # Check is backquoted are not used require_back_quotes = !contrasts_elements |> str_remove_all("`") |> contains_only_valid_chars_for_column() has_left_back_quotes = contrasts_elements |> str_detect("^`") @@ -797,6 +803,7 @@ mutate_from_expr_list = function(x, formula_expr, ignore_errors = TRUE){ if(length(contrasts_not_in_the_model) > 0 & !ignore_errors) warning(sprintf("sccomp says: These components of your contrasts are not present in the model as parameters: %s. Factors including special characters, e.g. \"(Intercept)\" require backquotes e.g. \"`(Intercept)`\" ", paste(contrasts_not_in_the_model, sep = ", "))) + # Calculate if(ignore_errors) my_mutate = mutate_ignore_error else my_mutate = mutate From 80aa801688610414a227a3a97eff112ca6c6e542 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Sun, 17 May 2026 18:55:25 +0930 Subject: [PATCH 64/68] Refactors the `incorporate_parameters_into_fit_object` and `incorporate_parameters_into_sccomp_object` functions to allow for optional parameter loading, enhancing flexibility in handling Stan model parameters. Additionally, it updates related tests to reflect these changes. --- DESCRIPTION | 4 +- R/utilities.R | 65 ++-- tests/testthat/test-incorporate-parameters.R | 27 +- tests/testthat/test-replicate_data.R | 322 +++++++++---------- 4 files changed, 184 insertions(+), 234 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0b98f9f1..da8a8cb7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -60,6 +60,6 @@ VignetteBuilder: knitr URL: https://github.com/MangiolaLaboratory/sccomp, https://mangiolalaboratory.github.io/sccomp/ BugReports: https://github.com/MangiolaLaboratory/sccomp/issues Config/testthat/edition: 3 -Config/testthat/parallel: true -Config/testthat/snapshot/parallel: true +Config/testthat/parallel: false +Config/testthat/snapshot/parallel: false Config/testthat/snapshot/parallel/workers: 2 diff --git a/R/utilities.R b/R/utilities.R index 794ce9ee..1c0b633f 100755 --- a/R/utilities.R +++ b/R/utilities.R @@ -90,36 +90,36 @@ subset_results_by_factor = function(.data, factor = NULL, keep_intercept = FALSE filter(`factor` == !!factor) } -#' Incorporate all Stan model parameters into fit object +#' Incorporate Stan draws into fit object #' #' @description -#' This function loads all parameters from the Stan model into the fit object. -#' This is necessary before cleaning up CSV draw files to ensure all parameters -#' are available for later retrieval even after the CSV files are deleted. -#' -#' The function calls fit$draws() for all parameters, which forces cmdstanr -#' to read the CSV files and cache the draws in memory. This way, when the -#' CSV files are later deleted (via portable = TRUE), the draws -#' remain accessible through the fit object. -#' -#' This function is really needed for LOO usage and outlier removal usage. +#' Loads parameters (and generated quantities in the CSV) into the fit object by +#' calling \code{fit$draws()}, so CmdStanR reads chain files and caches draws in memory. +#' Needed before deleting draw CSVs (\code{portable = TRUE}) and for downstream uses +#' such as \code{fit$draws(format = "matrix")} in outlier removal. #' #' @param fit A cmdstanr fit object +#' @param parameters_to_load Character vector of Stan \emph{base} names (no indices), or +#' \code{NULL} (default) to load every variable reported in \code{fit$metadata()$model_params}. #' -#' @return The same fit object (invisibly), with all parameters loaded into memory +#' @return The same fit object, with requested draws loaded into memory #' #' @keywords internal #' @noRd -incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { +incorporate_parameters_into_fit_object = function(fit, parameters_to_load = NULL) { model_params <- fit$metadata()$model_params model_params_base <- unique(sub("(\\[.*\\])?$", "", model_params)) - parameters_present <- intersect(parameters_to_load, model_params_base) - - # Load parameters by calling draws() - # This forces cmdstanr to read from CSV and store in memory - fit$draws(variables = parameters_present, format = "draws_df") - + parameters_present <- if (is.null(parameters_to_load)) { + model_params_base + } else { + intersect(parameters_to_load, model_params_base) + } + + if (length(parameters_present) > 0L) { + fit$draws(variables = parameters_present, format = "draws_df") + } + fit } @@ -132,35 +132,14 @@ incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { #' object (and attributes) are retained. #' #' @param obj An object with a \code{"fit"} attribute (typically a \code{sccomp_tbl}). +#' @param parameters_to_load Passed to \code{incorporate_parameters_into_fit_object()}; +#' use \code{NULL} (default) to load all variables from the fit metadata. #' #' @return \code{obj} with an updated \code{"fit"} attribute. #' #' @keywords internal #' @noRd -incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = c( - # Parameters block - "beta_raw", - "alpha", - "prec_intercept", - "log_prec_sd", - "prec_intercept_1", - "prec_slope_1", - "prec_intercept_2", - "prec_slope_2", - "prec_sd", - "mix_p", - # Random effect parameters - one set per slot (1..4) - "random_effect_raw_1", "random_effect_raw_2", "random_effect_raw_3", "random_effect_raw_4", - "random_effect_sigma_raw_1", "random_effect_sigma_raw_2", "random_effect_sigma_raw_3", "random_effect_sigma_raw_4", - "sigma_correlation_factor_1", "sigma_correlation_factor_2", "sigma_correlation_factor_3", "sigma_correlation_factor_4", - "random_effect_sigma_mu", - "random_effect_sigma_sigma", - "zero_random_effect", - # Transformed parameters - "beta", - # Generated quantities - "log_lik" - )) { +incorporate_parameters_into_sccomp_object = function(obj, parameters_to_load = NULL) { fit <- attr(obj, "fit") if (is.null(fit)) { diff --git a/tests/testthat/test-incorporate-parameters.R b/tests/testthat/test-incorporate-parameters.R index 9140f69c..e72f0bc8 100644 --- a/tests/testthat/test-incorporate-parameters.R +++ b/tests/testthat/test-incorporate-parameters.R @@ -44,30 +44,6 @@ estimate_for_draw_tests_hmc_minimal <- function(output_directory, portable = FAL ) } -test_that("non-portable estimate: deleting Stan output files before sccomp_test() errors without incorporation", { - skip_cmdstan() - - test_output_dir <- tempfile("sccomp_test_draws_no_incorp_") - dir.create(test_output_dir) - on.exit(unlink(test_output_dir, recursive = TRUE), add = TRUE) - - result <- estimate_for_draw_tests(test_output_dir, portable = FALSE) - fit <- attr(result, "fit") - - paths <- fit$output_files(include_failed = TRUE) - paths <- paths[file.exists(paths)] - expect_gt(length(paths), 0L, label = "Stan output files on disk") - - ok <- file.remove(paths) - expect_true(all(ok), label = "removing Stan chain/output files") - expect_false(any(file.exists(paths)), label = "recorded Stan paths should not exist after deletion") - - expect_error( - sccomp_test(result), - "Stan output files for this fit are not on disk" - ) -}) - # With HMC, `sccomp_summarise_posterior_for_estimate()` only touches `fit$summary()` for `beta` / # `alpha_normalised` (etc.); `prec_sd` is not loaded then. After deleting chain CSVs, `prec_sd` # must be read from disk and fails (same class of error as copying an RDS to another machine @@ -221,8 +197,9 @@ test_that("incorporate_parameters_into_sccomp_object forwards fit and writes bac class(obj) <- c("sccomp_tbl", class(obj)) local_mocked_bindings( - incorporate_parameters_into_fit_object = function(fit) { + incorporate_parameters_into_fit_object = function(fit, parameters_to_load) { expect_identical(fit, fit_in) + expect_null(parameters_to_load) fit$incorporated <- TRUE fit }, diff --git a/tests/testthat/test-replicate_data.R b/tests/testthat/test-replicate_data.R index 9a7899cd..34e12e52 100644 --- a/tests/testthat/test-replicate_data.R +++ b/tests/testthat/test-replicate_data.R @@ -3,6 +3,11 @@ library(dplyr) library(tidyr) library(sccomp) +# Four-slot RE design (see prepare_replicate_data(X_random_effect_slots = )) +re_slots_from_mi <- function(mi) { + lapply(seq_len(4L), function(k) mi[[paste0("X_random_effect_", k)]]) +} + test_that("replicate_data works correctly", { skip_cmdstan() # Load test data @@ -44,8 +49,7 @@ test_that("replicate_data works correctly", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -75,16 +79,16 @@ test_that("replicate_data works correctly", { expect_equal(ncol(result$X), ncol(model_input$X)) # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with random intercept model", { @@ -134,8 +138,7 @@ test_that("replicate_data works with random intercept model", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -158,22 +161,22 @@ test_that("replicate_data works with random intercept model", { expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) - print('ncol(result$X_random_effect):'); print(ncol(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) + print('ncol(result$X_random_effect_1):'); print(ncol(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with random slope model", { @@ -229,8 +232,7 @@ test_that("replicate_data works with random slope model", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -253,22 +255,22 @@ test_that("replicate_data works with random slope model", { expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) - print('ncol(result$X_random_effect):'); print(ncol(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) + print('ncol(result$X_random_effect_1):'); print(ncol(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with random slope model and type NA", { @@ -340,8 +342,7 @@ new_data = Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -364,22 +365,22 @@ new_data = expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) # Find a column with 'type' in its name - col_type <- grep("type", colnames(result$X_random_effect), value = TRUE)[1] - col_intercept <- grep("Intercept", colnames(result$X_random_effect), value = TRUE)[1] - print(paste('result$X_random_effect[1,', col_type, ']:')); print(result$X_random_effect[1, col_type]) - print(paste('result$X_random_effect[1,', col_intercept, ']:')); print(result$X_random_effect[1, col_intercept]) - expect_equal(result$X_random_effect[1, col_type], 0.5) - expect_equal(result$X_random_effect[1, col_intercept], 1) + col_type <- grep("type", colnames(result$X_random_effect_1), value = TRUE)[1] + col_intercept <- grep("Intercept", colnames(result$X_random_effect_1), value = TRUE)[1] + print(paste('result$X_random_effect_1[1,', col_type, ']:')); print(result$X_random_effect_1[1, col_type]) + print(paste('result$X_random_effect_1[1,', col_intercept, ']:')); print(result$X_random_effect_1[1, col_intercept]) + expect_equal(result$X_random_effect_1[1, col_type], 0.5) + expect_equal(result$X_random_effect_1[1, col_intercept], 1) # Check that X_random_effect_unseen has the expected number of 1s - print('result$X_random_effect_unseen[rownames(result$X_random_effect_unseen) == sample_with_na, "(Intercept)___NA"]:') + print('result$X_random_effect_1_unseen[rownames(result$X_random_effect_1_unseen) == sample_with_na, "(Intercept)___NA"]:') # Check if X_random_effect_unseen has the expected column - expect_equal(ncol(result$X_random_effect_unseen), 0) + expect_equal(ncol(result$X_random_effect_1_unseen), 0) }) test_that("replicate_data works with nested random effects", { @@ -435,8 +436,7 @@ test_that("replicate_data works with nested random effects", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -459,26 +459,26 @@ test_that("replicate_data works with nested random effects", { expect_true("create_intercept" %in% names(result)) # Check random effect design matrices - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) print('is.null(result$X_random_effect_2):'); print(is.null(result$X_random_effect_2)) expect_true(!is.null(result$X_random_effect_2)) - print('ncol(result$X_random_effect):'); print(ncol(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + print('ncol(result$X_random_effect_1):'); print(ncol(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) print('ncol(result$X_random_effect_2):'); print(ncol(result$X_random_effect_2)) expect_true(ncol(result$X_random_effect_2) > 0) # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with NA values in grouping", { @@ -546,8 +546,7 @@ test_that("replicate_data works with NA values in grouping", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -570,45 +569,45 @@ test_that("replicate_data works with NA values in grouping", { expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) - print('ncol(result$X_random_effect):'); print(ncol(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) + print('ncol(result$X_random_effect_1):'); print(ncol(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) # Check that NA values are handled correctly - print('all(!is.na(result$X_random_effect))'); print(all(!is.na(result$X_random_effect))) - expect_true(all(!is.na(result$X_random_effect))) + print('all(!is.na(result$X_random_effect_1))'); print(all(!is.na(result$X_random_effect_1))) + expect_true(all(!is.na(result$X_random_effect_1))) # Check that the design matrix dimensions are correct - print('nrow(result$X_random_effect):'); print(nrow(result$X_random_effect)) + print('nrow(result$X_random_effect_1):'); print(nrow(result$X_random_effect_1)) print('nrow(distinct(test_data, sample))'); print(nrow(test_data |> distinct(sample))) - expect_equal(nrow(result$X_random_effect), nrow(test_data |> distinct(sample))) + expect_equal(nrow(result$X_random_effect_1), nrow(test_data |> distinct(sample))) # Check that X_random_effect has only one 0 for the expected sample group1_samples <- test_data |> filter(group__ == "GROUP1") |> distinct(sample) |> pull(sample) - if ("(Intercept)___GROUP1" %in% colnames(result$X_random_effect)) { - print('result$X_random_effect[group1_samples, "(Intercept)___GROUP1"]:') - print(result$X_random_effect[group1_samples, "(Intercept)___GROUP1"]) - expect_true(all(result$X_random_effect[group1_samples, "(Intercept)___GROUP1"] == 1)) + if ("(Intercept)___GROUP1" %in% colnames(result$X_random_effect_1)) { + print('result$X_random_effect_1[group1_samples, "(Intercept)___GROUP1"]:') + print(result$X_random_effect_1[group1_samples, "(Intercept)___GROUP1"]) + expect_true(all(result$X_random_effect_1[group1_samples, "(Intercept)___GROUP1"] == 1)) } # Check that X_random_effect_unseen has the expected number of 1s - print('result$X_random_effect_unseen[rownames(result$X_random_effect_unseen) == sample_with_na, "(Intercept)___NA"]:') + print('result$X_random_effect_1_unseen[rownames(result$X_random_effect_1_unseen) == sample_with_na, "(Intercept)___NA"]:') # Check if X_random_effect_unseen has the expected column - expect_equal(ncol(result$X_random_effect_unseen), 0) + expect_equal(ncol(result$X_random_effect_1_unseen), 0) # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with NA values in grouping and random effects", { @@ -679,8 +678,7 @@ test_that("replicate_data works with NA values in grouping and random effects", Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -702,90 +700,90 @@ test_that("replicate_data works with NA values in grouping and random effects", expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - print('is.null(result$X_random_effect):'); print(is.null(result$X_random_effect)) - expect_true(!is.null(result$X_random_effect)) - print('ncol(result$X_random_effect):'); print(ncol(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + print('is.null(result$X_random_effect_1):'); print(is.null(result$X_random_effect_1)) + expect_true(!is.null(result$X_random_effect_1)) + print('ncol(result$X_random_effect_1):'); print(ncol(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) # Check that NA values are handled correctly in random effects - print('all(!is.na(result$X_random_effect))'); print(all(!is.na(result$X_random_effect))) - expect_true(all(!is.na(result$X_random_effect))) + print('all(!is.na(result$X_random_effect_1))'); print(all(!is.na(result$X_random_effect_1))) + expect_true(all(!is.na(result$X_random_effect_1))) # Check that the design matrix dimensions are correct - print('nrow(result$X_random_effect):'); print(nrow(result$X_random_effect)) + print('nrow(result$X_random_effect_1):'); print(nrow(result$X_random_effect_1)) print('nrow(distinct(test_data, sample))'); print(nrow(test_data |> distinct(sample))) - expect_equal(nrow(result$X_random_effect), nrow(test_data |> distinct(sample))) + expect_equal(nrow(result$X_random_effect_1), nrow(test_data |> distinct(sample))) # Check that the random effect design matrix has the correct structure - print('any(grepl("type", colnames(result$X_random_effect)))'); print(any(grepl("type", colnames(result$X_random_effect)))) - expect_true(any(grepl("type", colnames(result$X_random_effect)))) - print('any(grepl("Intercept", colnames(result$X_random_effect)))'); print(any(grepl("Intercept", colnames(result$X_random_effect)))) - expect_true(any(grepl("Intercept", colnames(result$X_random_effect)))) + print('any(grepl("type", colnames(result$X_random_effect_1)))'); print(any(grepl("type", colnames(result$X_random_effect_1)))) + expect_true(any(grepl("type", colnames(result$X_random_effect_1)))) + print('any(grepl("Intercept", colnames(result$X_random_effect_1)))'); print(any(grepl("Intercept", colnames(result$X_random_effect_1)))) + expect_true(any(grepl("Intercept", colnames(result$X_random_effect_1)))) # Test the properties of X_random_effect_unseen - print('all(!is.na(result$X_random_effect_unseen))'); print(all(!is.na(result$X_random_effect_unseen))) - expect_true(all(!is.na(result$X_random_effect_unseen))) - print('nrow(result$X_random_effect_unseen):'); print(nrow(result$X_random_effect_unseen)) + print('all(!is.na(result$X_random_effect_1_unseen))'); print(all(!is.na(result$X_random_effect_1_unseen))) + expect_true(all(!is.na(result$X_random_effect_1_unseen))) + print('nrow(result$X_random_effect_1_unseen):'); print(nrow(result$X_random_effect_1_unseen)) print('nrow(distinct(test_data, sample)):'); print(nrow(test_data |> distinct(sample))) - expect_equal(nrow(result$X_random_effect_unseen), nrow(test_data |> distinct(sample))) - print('ncol(result$X_random_effect_unseen):'); print(ncol(result$X_random_effect_unseen)) + expect_equal(nrow(result$X_random_effect_1_unseen), nrow(test_data |> distinct(sample))) + print('ncol(result$X_random_effect_1_unseen):'); print(ncol(result$X_random_effect_1_unseen)) # When new_data is NULL, X_random_effect_unseen should be empty (0 columns) # even if the original data has NA values in grouping - expect_equal(ncol(result$X_random_effect_unseen), 0) - print('rownames(result$X_random_effect_unseen):'); print(rownames(result$X_random_effect_unseen)) - print('rownames(result$X_random_effect):'); print(rownames(result$X_random_effect)) - expect_equal(rownames(result$X_random_effect_unseen), rownames(result$X_random_effect)) + expect_equal(ncol(result$X_random_effect_1_unseen), 0) + print('rownames(result$X_random_effect_1_unseen):'); print(rownames(result$X_random_effect_1_unseen)) + print('rownames(result$X_random_effect_1):'); print(rownames(result$X_random_effect_1)) + expect_equal(rownames(result$X_random_effect_1_unseen), rownames(result$X_random_effect_1)) # Since X_random_effect_unseen is empty, we can't check for NA columns - # print('all(grepl("___NA$", colnames(result$X_random_effect_unseen)))'); print(all(grepl("___NA$", colnames(result$X_random_effect_unseen)))) - # expect_true(all(grepl("___NA$", colnames(result$X_random_effect_unseen)))) - print('all(grepl("___GROUP", colnames(result$X_random_effect)))'); print(all(grepl("___GROUP", colnames(result$X_random_effect)))) - expect_true(all(grepl("___GROUP", colnames(result$X_random_effect)))) + # print('all(grepl("___NA$", colnames(result$X_random_effect_1_unseen)))'); print(all(grepl("___NA$", colnames(result$X_random_effect_1_unseen)))) + # expect_true(all(grepl("___NA$", colnames(result$X_random_effect_1_unseen)))) + print('all(grepl("___GROUP", colnames(result$X_random_effect_1)))'); print(all(grepl("___GROUP", colnames(result$X_random_effect_1)))) + expect_true(all(grepl("___GROUP", colnames(result$X_random_effect_1)))) # Since X_random_effect_unseen is empty, we can't check sums of NA columns - # print('sum(result$X_random_effect_unseen[, "typecancer___NA"]):'); print(sum(as.vector(result$X_random_effect_unseen[, "typecancer___NA"]))) + # print('sum(result$X_random_effect_1_unseen[, "typecancer___NA"]):'); print(sum(as.vector(result$X_random_effect_1_unseen[, "typecancer___NA"]))) # expect_equal( - # as.vector(result$X_random_effect_unseen[, "typecancer___NA"]) |> sum(), + # as.vector(result$X_random_effect_1_unseen[, "typecancer___NA"]) |> sum(), # 1 # ) # - # print('sum(result$X_random_effect_unseen[, "(Intercept)___NA"]):'); print(sum(as.vector(result$X_random_effect_unseen[, "(Intercept)___NA"]))) + # print('sum(result$X_random_effect_1_unseen[, "(Intercept)___NA"]):'); print(sum(as.vector(result$X_random_effect_1_unseen[, "(Intercept)___NA"]))) # expect_equal( - # as.vector(result$X_random_effect_unseen[, "(Intercept)___NA"]) |> sum(), + # as.vector(result$X_random_effect_1_unseen[, "(Intercept)___NA"]) |> sum(), # 2 # ) # Robust per-sample checks for random effect matrices - for (s in rownames(result$X_random_effect)) { + for (s in rownames(result$X_random_effect_1)) { group_val <- test_data |> filter(sample == s) |> distinct(group__) |> pull(group__) if (length(group_val) > 0 && !is.na(group_val)) { colname <- paste0("(Intercept)___", group_val) - if (colname %in% colnames(result$X_random_effect)) { - expect_equal(result$X_random_effect[s, colname], 1) + if (colname %in% colnames(result$X_random_effect_1)) { + expect_equal(result$X_random_effect_1[s, colname], 1) } } } # Since X_random_effect_unseen is empty, we can't check for NA samples - # for (s in rownames(result$X_random_effect_unseen)) { + # for (s in rownames(result$X_random_effect_1_unseen)) { # group_val <- test_data |> filter(sample == s) |> distinct(group__) |> pull(group__) # if (length(group_val) > 0 && is.na(group_val)) { - # expect_equal(result$X_random_effect_unseen[s, "(Intercept)___NA"], 1) + # expect_equal(result$X_random_effect_1_unseen[s, "(Intercept)___NA"], 1) # } # } # Print key objects for debugging - print("colnames(result$X_random_effect):") - print(colnames(result$X_random_effect)) - print("rownames(result$X_random_effect):") - print(rownames(result$X_random_effect)) - print("result$X_random_effect:") - print(result$X_random_effect) - print("colnames(result$X_random_effect_unseen):") - print(colnames(result$X_random_effect_unseen)) - print("result$X_random_effect_unseen:") - print(result$X_random_effect_unseen) + print("colnames(result$X_random_effect_1):") + print(colnames(result$X_random_effect_1)) + print("rownames(result$X_random_effect_1):") + print(rownames(result$X_random_effect_1)) + print("result$X_random_effect_1:") + print(result$X_random_effect_1) + print("colnames(result$X_random_effect_1_unseen):") + print(colnames(result$X_random_effect_1_unseen)) + print("result$X_random_effect_1_unseen:") + print(result$X_random_effect_1_unseen) }) test_that("replicate_data works with type NA and group__ NA", { @@ -854,8 +852,7 @@ test_that("replicate_data works with type NA and group__ NA", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -874,20 +871,20 @@ test_that("replicate_data works with type NA and group__ NA", { expect_true("create_intercept" %in% names(result)) # Check random effect design matrix - expect_true(!is.null(result$X_random_effect)) - expect_true(ncol(result$X_random_effect) > 0) + expect_true(!is.null(result$X_random_effect_1)) + expect_true(ncol(result$X_random_effect_1) > 0) # Check that NA values are handled correctly - expect_true(all(!is.na(result$X_random_effect))) + expect_true(all(!is.na(result$X_random_effect_1))) # Check that the design matrix dimensions are correct - expect_equal(nrow(result$X_random_effect), nrow(new_data |> distinct(sample))) + expect_equal(nrow(result$X_random_effect_1), nrow(new_data |> distinct(sample))) # Check that X_random_effect_unseen has the expected structure - expect_true(!is.null(result$X_random_effect_unseen)) - expect_true(all(!is.na(result$X_random_effect_unseen))) - expect_equal(nrow(result$X_random_effect_unseen), nrow(new_data |> distinct(sample))) - expect_true(all(grepl("___NA$", colnames(result$X_random_effect_unseen)))) + expect_true(!is.null(result$X_random_effect_1_unseen)) + expect_true(all(!is.na(result$X_random_effect_1_unseen))) + expect_equal(nrow(result$X_random_effect_1_unseen), nrow(new_data |> distinct(sample))) + expect_true(all(grepl("___NA$", colnames(result$X_random_effect_1_unseen)))) }) test_that("replicate_data works with new data containing only NA groups", { @@ -1019,8 +1016,7 @@ test_that("prepare_replicate_data handles complex design with NAs and prints new Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -1037,7 +1033,7 @@ test_that("prepare_replicate_data handles complex design with NAs and prints new # Print the new random effect design matrix (X_random_effect) cat("\nNew random effect design matrix (X_random_effect):\n") - print(result$X_random_effect) + print(result$X_random_effect_1) # Print the new random effect design matrix 2 (if present) if (!is.null(result$X_random_effect_2)) { @@ -1047,12 +1043,12 @@ test_that("prepare_replicate_data handles complex design with NAs and prints new # Evaluate structure expect_true(is.matrix(result$X) || is.data.frame(result$X)) - expect_true(is.matrix(result$X_random_effect) || is.data.frame(result$X_random_effect)) + expect_true(is.matrix(result$X_random_effect_1) || is.data.frame(result$X_random_effect_1)) expect_equal(nrow(result$X), nrow(original_count_data)) - expect_equal(nrow(result$X_random_effect), nrow(original_count_data)) + expect_equal(nrow(result$X_random_effect_1), nrow(original_count_data)) # Check that NAs are handled (no NA in design matrices) expect_true(all(!is.na(result$X))) - expect_true(all(!is.na(result$X_random_effect))) + expect_true(all(!is.na(result$X_random_effect_1))) }) test_that("prepare_replicate_data throws error for duplicate sample names", { @@ -1106,8 +1102,7 @@ test_that("prepare_replicate_data throws error for duplicate sample names", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), @@ -1134,8 +1129,7 @@ test_that("prepare_replicate_data throws error for duplicate sample names", { Xa = model_input$Xa, N = model_input$N, intercept_in_design = model_input$intercept_in_design, - X_random_effect = model_input$X_random_effect, - X_random_effect_2 = model_input$X_random_effect_2, + X_random_effect_slots = re_slots_from_mi(model_input), .sample = !!rlang::quo(sample), .cell_group = !!rlang::quo(cell_group), .count = !!rlang::quo(count), From 32011970ff7d052eead52bfb36c438fc78d14a71 Mon Sep 17 00:00:00 2001 From: Stefano Mangiola Date: Tue, 19 May 2026 22:30:22 +0930 Subject: [PATCH 65/68] This commit updates the package version to 2.1.33 and introduces functionality for handling smooth terms (`s()` and `t2()`) in sccomp formulas. Key changes include the addition of new utility functions for parsing smooth terms, modifications to existing functions to accommodate smooths, and the implementation of tests to ensure correct functionality. The vignette has also been added to demonstrate the use of smooth terms in modeling. --- DESCRIPTION | 5 +- R/sccomp_remove_outliers.R | 3 +- R/sccomp_replicate.R | 54 ++- R/smooths.R | 520 ++++++++++++++++++++++++++++ R/utilities.R | 132 ++++++- man/sccomp-package.Rd | 1 + man/sccomp_stan_models_cache_dir.Rd | 5 - tests/testthat/test-smooths.R | 418 ++++++++++++++++++++++ vignettes/splines.Rmd | 499 ++++++++++++++++++++++++++ 9 files changed, 1605 insertions(+), 32 deletions(-) create mode 100644 R/smooths.R create mode 100644 tests/testthat/test-smooths.R create mode 100644 vignettes/splines.Rmd diff --git a/DESCRIPTION b/DESCRIPTION index da8a8cb7..59410f74 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,14 +1,13 @@ Package: sccomp Type: Package Title: Differential Composition and Variability Analysis for Single-Cell Data -Version: 2.1.32 +Version: 2.1.33 Date: 2026-05-11 Authors@R: c(person("Stefano", "Mangiola", email = "stefano.mangiola@unimelb.edu.au", role = c("aut", "cre")), person("Alexandra J.", "Roth-Schulze", role = "aut"), person("Marie", "Trussart", role = "aut"), person("Enrique", "Zozaya-Valdés", role = "aut"), person("Mengyao", "Ma", role = "aut"), person("Zijie", "Gao", role = "aut"), person("Alan F.", "Rubin", role = "aut"), person("Terence P.", "Speed", role = "aut"), person("Heejung", "Shim", role = "aut"), person("Anthony T.", "Papenfuss", role = "aut")) Description: Comprehensive R package for differential composition and variability analysis in single-cell RNA sequencing, CyTOF, and microbiome data. Provides robust Bayesian modeling with outlier detection, random effects, and advanced statistical methods for cell type proportion analysis. Features include probabilistic outlier identification, mixed-effect modeling, differential variability testing, and comprehensive visualization tools. Perfect for cancer research, immunology, developmental biology, and single-cell genomics applications. License: GPL-3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 Depends: R (>= 4.3.0), instantiate (>= 0.2.3) @@ -39,6 +38,7 @@ Imports: SingleCellExperiment, posterior Suggests: + mgcv, knitr, rmarkdown, BiocStyle, @@ -63,3 +63,4 @@ Config/testthat/edition: 3 Config/testthat/parallel: false Config/testthat/snapshot/parallel: false Config/testthat/snapshot/parallel/workers: 2 +Config/roxygen2/version: 8.0.0 diff --git a/R/sccomp_remove_outliers.R b/R/sccomp_remove_outliers.R index b9133be6..9b101747 100644 --- a/R/sccomp_remove_outliers.R +++ b/R/sccomp_remove_outliers.R @@ -196,8 +196,7 @@ sccomp_remove_outliers.sccomp_tbl = function(.estimate, # This is for the new data generation with selected factors to do adjustment data = - .estimate |> - attr("model_input") |> + data_for_model |> c( list( # Add subset of coefficients diff --git a/R/sccomp_replicate.R b/R/sccomp_replicate.R index fbc87b66..941e9b3f 100644 --- a/R/sccomp_replicate.R +++ b/R/sccomp_replicate.R @@ -135,6 +135,16 @@ sccomp_replicate.sccomp_tbl = function(fit, #' @param formula_variability Formula for the variability model #' @param new_data New data to generate predictions for. If NULL, uses the original data #' @param original_count_data Original count data from the model +#' @param smooth_results Optional named list of smooth-term metadata captured +#' at fit time. In the standard call path this is read from +#' `get_smooth_results(.data)` (an attribute on `model_input`, not Stan data). +#' Contains +#' `smooth_specs`, the `mgcv::smoothCon()` objects used to evaluate bases at +#' `new_data`; `smooth_re_objs`, the parallel `mgcv::smooth2random()` results +#' used to recover the fitted `Xf` / `Xr` parameterisation; and +#' `smooth_labels`, the original term labels used to name generated smooth +#' columns so they match the fit-time design. `NULL` when the composition +#' formula has no smooths. #' #' @return A list containing: #' - model_input: The prepared model input data @@ -156,7 +166,8 @@ prepare_replicate_data = function(X, original_formula_composition, formula_variability, new_data = NULL, - original_count_data) { + original_count_data, + smooth_results = NULL) { .sample = enquo(.sample) @@ -226,13 +237,17 @@ prepare_replicate_data = function(X, new_data = old_data |> bind_rows( new_data ) + # Smooth columns are evaluated separately via PredictMat below; keep the + # random-effect clauses so the later RE parsing still sees the same formula. + formula_composition = strip_smooth_terms(formula_composition) + new_X = new_data |> get_design_matrix( # Drop random intercept formula_composition |> + strip_random_effect_terms() |> as.character() |> - str_remove_all("\\+ ?\\(.+\\|.+\\)") |> paste(collapse="") |> as.formula(), !!.sample, @@ -242,6 +257,17 @@ prepare_replicate_data = function(X, # Remove columns that are not in the original design matrix .[,colnames(.) %in% colnames(X), drop=FALSE] + # Evaluate any smooth bases on the replicate rows and merge the resulting + # design pieces (unpenalised columns appended to `new_X`, one RE slot per + # penalised block) using the fit-time `smoothCon` / `smooth2random` objects. + smooth_design = build_smooth_replicate_design( + parametric_X = new_X, + new_data_tail = new_data |> tail(nrow_new_data), + smooth_results = smooth_results + ) + new_X = smooth_design$new_X + smooth_replicate_slots = smooth_design$smooth_replicate_slots + # Check that all effect combination were present when the model was fitted check_missing_parameters( new_X |> colnames(), @@ -263,8 +289,8 @@ prepare_replicate_data = function(X, get_design_matrix( # Drop random intercept formula_variability |> + strip_random_effect_terms() |> as.character() |> - str_remove_all("\\+ ?\\(.+\\|.+\\)") |> paste(collapse="") |> as.formula(), !!.sample, @@ -363,6 +389,25 @@ prepare_replicate_data = function(X, replicate_slots = map(seq_len(4L), build_replicate_slot) + # Append smooth-derived replicate slots (one per smooth term in the + # composition formula). They occupy whichever slots come after the + # explicit RE clauses, mirroring the slot ordering used at fit time. + if (length(smooth_replicate_slots) > 0) { + n_explicit_re = length(original_grouping_names) + n_smooth = length(smooth_replicate_slots) + n_used = n_explicit_re + n_smooth + if (n_used > 4L) { + stop(sprintf( + "sccomp says: the replicate model needs %d RE slot(s) but only 4 are available.", + n_used + )) + } + # Replace placeholder slots `[n_explicit_re + 1 .. n_used]` with smooths. + for (k in seq_len(n_smooth)) { + replicate_slots[[n_explicit_re + k]] = smooth_replicate_slots[[k]] + } + } + # setup default unknown_grouping variable for generated quantities unknown_grouping = rep(0L, 4L) @@ -464,7 +509,8 @@ replicate_data = function(.data, original_count_data = .data |> attr("count_data") |> - .subset(!!.sample) + .subset(!!.sample), + smooth_results = get_smooth_results(.data) ) # Original input diff --git a/R/smooths.R b/R/smooths.R new file mode 100644 index 00000000..75de99a9 --- /dev/null +++ b/R/smooths.R @@ -0,0 +1,520 @@ +# Smooth-term utilities for sccomp formulas (brms-style splines) +# +# This file implements the R-side machinery that turns smooth terms +# (`s()`, `t2()`) in a sccomp formula into design-matrix columns that the +# existing Stan model can consume without modification. +# +# The decomposition is the standard mgcv / brms one: +# * `Xf` — unpenalised null-space columns of the smooth (linear part). +# These are appended to the fixed-effect design matrix `X` and +# estimated as ordinary `beta` coefficients. +# * `Xr` — penalised "wiggly" basis columns. These occupy a sccomp +# random-effect slot with `n_factors = 1` and `n_groups = ncol(Xr)`, +# so the slot's per-cell-group SD plays the role of brms's `sds_*`. +# +# Built via: +# 1. `mgcv::smoothCon(s(...), data, absorb.cons = TRUE, +# diagonal.penalty = TRUE)[[1]]` — basis + penalty. +# 2. `mgcv::smooth2random(sm, vnames = "", type = 2)` — re-parameterise +# into `Xf` + standardised `rand$Xr` (so the wiggly coefficients have +# a `N(0, sds * I)` prior). +# +# At prediction time, `predict_smooth_at_newdata()` evaluates the basis at +# new covariate values via `mgcv::PredictMat()` and re-applies the same +# `trans.D` (diagonal rescaling) and `trans.U` (orthonormal rotation) +# captured at fit time, so the new columns line up with the columns the +# model was trained on. + +#' Detect smooth specials in a formula +#' +#' @param fm A one-sided formula. +#' @return TRUE if `fm` contains any `s(...)` or `t2(...)` term. +#' @keywords internal +#' @noRd +has_smooth_terms <- function(fm) { + if (is.null(fm)) return(FALSE) + trm <- stats::terms(fm, specials = c("s", "t2")) + length(unlist(attr(trm, "specials"))) > 0 +} + + +#' Strip smooth specials from a formula +#' +#' Returns a new formula with `s()` / `t2()` term labels removed. All other +#' terms, including random-effect clauses (`(... | g)`), are preserved. The +#' intercept setting (`+ 0` / `- 1`) is preserved. If nothing remains, returns +#' `~ 1` (or `~ 0`). +#' +#' @param fm A one-sided formula. +#' @return A one-sided formula without smooth term labels. +#' @keywords internal +#' @noRd +strip_smooth_terms <- function(fm) { + if (is.null(fm)) return(fm) + trm <- stats::terms(fm, specials = c("s", "t2")) + smooth_idx <- unlist(attr(trm, "specials")) + + vars <- attr(trm, "variables") + smooth_labels <- if (length(smooth_idx) > 0) { + vapply( + smooth_idx + 1L, + function(i) deparse(vars[[i]], width.cutoff = 500L), + character(1) + ) + } else { + character(0) + } + + all_labels <- attr(trm, "term.labels") + keep_labels <- setdiff(all_labels, smooth_labels) + keep_labels <- ifelse(grepl("\\|", keep_labels), paste0("(", keep_labels, ")"), keep_labels) + + has_intercept <- attr(trm, "intercept") == 1L + + if (length(keep_labels) == 0) { + return(if (has_intercept) ~ 1 else ~ 0) + } + + rhs <- paste(keep_labels, collapse = " + ") + if (!has_intercept) rhs <- paste0(rhs, " + 0") + stats::as.formula(paste("~", rhs), env = environment(fm)) +} + + +#' Strip random-effect clauses from a formula +#' +#' Returns a formula with `(... | g)` term labels removed, preserving all +#' ordinary fixed-effect terms and the intercept setting. This is used just +#' before calling `model.matrix()`, which cannot evaluate sccomp/brms-style +#' random-effect clauses. +#' +#' @param fm A one-sided formula. +#' @return A one-sided formula without random-effect term labels. +#' @keywords internal +#' @noRd +strip_random_effect_terms <- function(fm) { + if (is.null(fm)) return(fm) + trm <- stats::terms(fm) + + keep_labels <- attr(trm, "term.labels") + keep_labels <- keep_labels[!grepl("\\|", keep_labels)] + + has_intercept <- attr(trm, "intercept") == 1L + + if (length(keep_labels) == 0) { + return(if (has_intercept) ~ 1 else ~ 0) + } + + rhs <- paste(keep_labels, collapse = " + ") + if (!has_intercept) rhs <- paste0(rhs, " + 0") + stats::as.formula(paste("~", rhs), env = environment(fm)) +} + + +#' Parse smooth terms from a sccomp formula +#' +#' For each `s(...)` / `t2(...)` term, builds an mgcv smooth via +#' `smoothCon(..., absorb.cons = TRUE, diagonal.penalty = TRUE)` and the +#' brms-style re-parameterisation via `smooth2random(..., type = 2)`. Single- +#' penalty smooths (e.g. plain `s(x)`) yield one penalised block; multi- +#' penalty smooths (e.g. `t2(x, y)`, `s(x, z, bs = "fs")`) yield 2+ blocks, +#' one per penalty. Each block is mapped to its own sccomp random-effect +#' slot, with its own per-cell-group smoothing SD — matching the way brms +#' generates one `sds_*` parameter per penalty. +#' +#' @param fm A one-sided formula, possibly containing `s()` / `t2()` terms. +#' @param data A data frame containing every variable referenced inside the +#' smooth terms (in the same row order as the design matrices that will be +#' built downstream). +#' @return A list with components: +#' * `parametric_formula` — `fm` with smooth specials stripped. +#' * `smooth_labels` — character vector of original smooth labels +#' (one per `s()` / `t2()` term). +#' * `Xf_list` — list of `N × Ks_k` matrices (unpenalised cols), +#' one per smooth term. +#' * `Xr_list` — **flat** list of `N × k_b` matrices, one per +#' penalty block. A single-penalty smooth contributes 1 entry; a multi- +#' penalty smooth contributes 2+. Each consumes one RE slot. +#' * `Xr_to_smooth` — integer vector parallel to `Xr_list` mapping +#' each block to its parent smooth index. +#' * `Xr_slot_labels` — character vector parallel to `Xr_list` giving +#' each block its sccomp RE-slot label: just the smooth's label for +#' single-penalty smooths, or `