From 47908d5629fc70975b007e813a8ee97c512de0ac Mon Sep 17 00:00:00 2001 From: partonzm Date: Wed, 8 Jul 2026 10:39:51 -0700 Subject: [PATCH] Added reusable volcano plotting code. Main fun returns plotly html widget. Also included function for labeling points on plot, and formatting above certain x/y values. --- NAMESPACE | 2 + R/fvolcanoPlot.R | 303 +++++++++++++++++++++++++++++ man/fvolcanoLabelChoices.Rd | 27 +++ man/fvolcanoPlot.Rd | 57 ++++++ tests/testthat/test-fvolcanoPlot.R | 97 +++++++++ 5 files changed, 486 insertions(+) create mode 100644 R/fvolcanoPlot.R create mode 100644 man/fvolcanoLabelChoices.Rd create mode 100644 man/fvolcanoPlot.Rd create mode 100644 tests/testthat/test-fvolcanoPlot.R diff --git a/NAMESPACE b/NAMESPACE index 8205541..5ae1ad8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -154,6 +154,8 @@ export(flm_def) export(fload) export(fpca) export(fsave) +export(fvolcanoLabelChoices) +export(fvolcanoPlot) export(geneset) export(genesets) export(is_anova) diff --git a/R/fvolcanoPlot.R b/R/fvolcanoPlot.R new file mode 100644 index 0000000..f872a31 --- /dev/null +++ b/R/fvolcanoPlot.R @@ -0,0 +1,303 @@ +#' Reusable volcano plot +#' +#' Builds a Plotly volcano plot from a prepared differential-statistics table. +#' Data preparation and downstream interpretation stay with the caller. +#' +#' @param dat Data frame containing the x-axis, y-metric, and key columns. +#' @param ... Passed to [FacileViz::fscatterplot()]. +#' @param x Column name for the x-axis value. +#' @param y Column name for the y-axis metric to transform with `-log10()`. +#' @param key Column name for the feature key. +#' @param labels Feature keys to label. +#' @param label_priority Ordered label columns to use before falling back to +#' `key`. +#' @param hover Columns to include in Plotly hover text. +#' @param event_source Plotly event source. +#' @param label_limit Maximum number of labeled points. +#' @param x_cutoff,y_cutoff Optional cutoffs used to color points. +#' @param width,height,webgl Passed to [FacileViz::fscatterplot()]. +#' +#' @return A Plotly htmlwidget. +#' @export +fvolcanoPlot <- function( + dat, + ..., + x = "logFC", + y = "pval", + key = "feature_id", + labels = NULL, + label_priority = c("symbol", "feature_id"), + hover = c("symbol", "logFC", "FDR"), + event_source = NULL, + label_limit = 20L, + x_cutoff = NULL, + y_cutoff = NULL, + width = NULL, + height = NULL, + webgl = TRUE +) { + assert_data_frame(dat) + assert_string(x) + assert_string(y) + assert_string(key) + assert_character(label_priority, min.len = 1L) + assert_count(label_limit, positive = TRUE) + .fvolcano_require_columns(dat, c(x, y, key)) + + dat$yaxis <- .fvolcano_y_values(dat, y) + label.dat <- .fvolcano_label_data( + dat, + dat$yaxis, + labels, + x, + key, + label_priority, + label_limit + ) + point.style <- .fvolcano_point_style( + dat, + dat$yaxis, + x_cutoff, + y_cutoff, + labels, + x, + key, + label_limit + ) + axis.ranges <- .fvolcano_axis_ranges(dat, x) + hover <- intersect(hover, colnames(dat)) + + fplot <- FacileViz::fscatterplot( + dat, + c(x, "yaxis"), + xlabel = x, + ylabel = .fvolcano_y_label(y), + width = width, + height = height, + hover = hover, + webgl = webgl, + event_source = event_source, + key = key, + ... + ) + plt <- FacileViz::plot(fplot) + plt <- .fvolcano_style_points(plt, point.style) + plotly::layout( + plt, + annotations = .fvolcano_label_annotations(label.dat, dat, x), + xaxis = list(range = axis.ranges$x), + yaxis = list(range = axis.ranges$y) + ) +} + +#' Volcano plot label choices +#' +#' @param dat Data frame containing feature labels and keys. +#' @param label_priority Ordered label columns to use before falling back to +#' `key`. +#' @param key Column name for the feature key. +#' +#' @return A named character vector where names are display labels and values +#' are feature keys. +#' @export +fvolcanoLabelChoices <- function( + dat, + label_priority = c("symbol", "feature_id"), + key = "feature_id" +) { + assert_data_frame(dat) + assert_character(label_priority, min.len = 1L) + assert_string(key) + .fvolcano_require_columns(dat, key) + .fvolcano_label_choices(dat, label_priority, key) +} + +.fvolcano_y_choices <- function(y) { + assert_character(y, min.len = 1L, any.missing = FALSE) + if (is.null(names(y))) { + names(y) <- y + } + y +} + +.fvolcano_y_metric <- function(metric, y) { + y <- .fvolcano_y_choices(y) + if (length(metric) != 1L || !metric %in% unname(y)) { + metric <- unname(y)[1L] + } + metric +} + +.fvolcano_y_label <- function(metric) { + sprintf("-log10(%s)", metric) +} + +.fvolcano_y_values <- function(dat, metric) { + -log10(dat[[metric]]) +} + +.fvolcano_feature_names <- function(dat, label_priority, key) { + labels <- rep(NA_character_, nrow(dat)) + for (col in label_priority) { + if (!col %in% colnames(dat)) { + next + } + vals <- as.character(dat[[col]]) + missing <- is.na(labels) | !nzchar(labels) + labels[missing] <- vals[missing] + } + missing <- is.na(labels) | !nzchar(labels) + labels[missing] <- as.character(dat[[key]][missing]) + labels +} + +.fvolcano_label_choices <- function(dat, label_priority, key) { + labels <- .fvolcano_feature_names(dat, label_priority, key) + duplicate.labels <- duplicated(labels) | duplicated(labels, fromLast = TRUE) + labels[duplicate.labels] <- paste0( + labels[duplicate.labels], + " (", + dat[[key]][duplicate.labels], + ")" + ) + stats::setNames(as.character(dat[[key]]), labels) +} + +.fvolcano_label_data <- function( + dat, y.values, selected, x, key, label_priority, label_limit +) { + if (is.null(selected)) { + selected <- character() + } + selected <- utils::head(selected, label_limit) + idx <- match(selected, as.character(dat[[key]]), nomatch = 0L) + idx <- idx[idx > 0L] + out <- dat[idx, , drop = FALSE] + out$yaxis <- y.values[idx] + out <- out[is.finite(out[[x]]) & is.finite(out$yaxis), , drop = FALSE] + out$volcano_label <- .fvolcano_feature_names(out, label_priority, key) + out +} + +.fvolcano_axis_ranges <- function(dat, x) { + padded_range <- function(vals, pad) { + rng <- suppressWarnings(range(vals, finite = TRUE)) + if (!all(is.finite(rng))) { + rng <- c(-0.5, 0.5) + } else if (diff(rng) == 0) { + rng <- rng + c(-0.5, 0.5) + } + span <- diff(rng) + rng + c(-span * pad[1L], span * pad[2L]) + } + list( + x = padded_range(dat[[x]], c(0.08, 0.18)), + y = padded_range(dat$yaxis, c(0.02, 0.14)) + ) +} + +.fvolcano_label_annotations <- function(label.dat, plot.dat, x) { + if (nrow(label.dat) == 0L) { + return(list()) + } + + lapply(seq_len(nrow(label.dat)), function(idx) { + list( + x = label.dat[[x]][idx], + y = label.dat$yaxis[idx], + xref = "x", + yref = "y", + text = htmltools::htmlEscape(label.dat$volcano_label[idx]), + showarrow = TRUE, + ax = 20, + ay = -20, + arrowhead = 0, + arrowwidth = 1, + arrowcolor = "#555555", + bgcolor = "rgba(238, 238, 238, 0.86)", + bordercolor = "#9a9a9a", + borderwidth = 1, + borderpad = 1, + font = list(size = 10, color = "#222222"), + opacity = 0.98, + captureevents = FALSE + ) + }) +} + +.fvolcano_point_palette <- list( + background = "rgba(105, 105, 105, 0.18)", + left = "rgba(0, 82, 204, 0.62)", + right = "rgba(220, 35, 35, 0.62)", + left_selected = "rgb(0, 82, 204)", + right_selected = "rgb(220, 35, 35)", + selected = "rgb(0, 0, 0)", + outline = "rgba(35, 35, 35, 0.7)", + no_outline = "rgba(0, 0, 0, 0)" +) + +.fvolcano_point_style <- function( + dat, y.values, x.cutoff, y.cutoff, selected = NULL, x, key, label_limit +) { + colors <- rep(.fvolcano_point_palette$background, nrow(dat)) + line.colors <- rep(.fvolcano_point_palette$no_outline, nrow(dat)) + line.widths <- rep(0, nrow(dat)) + left.idx <- right.idx <- rep(FALSE, nrow(dat)) + x.cutoff <- suppressWarnings(as.numeric(x.cutoff)) + y.cutoff <- suppressWarnings(as.numeric(y.cutoff)) + has.cutoffs <- length(x.cutoff) == 1L && length(y.cutoff) == 1L && + is.finite(x.cutoff) && is.finite(y.cutoff) + if (has.cutoffs) { + x.cutoff <- abs(x.cutoff) + left.idx <- dat[[x]] <= -x.cutoff & y.values >= y.cutoff + right.idx <- dat[[x]] >= x.cutoff & y.values >= y.cutoff + colors[left.idx] <- .fvolcano_point_palette$left + colors[right.idx] <- .fvolcano_point_palette$right + } + selected.idx <- rep(FALSE, nrow(dat)) + if (length(selected)) { + selected <- utils::head(selected, label_limit) + selected.idx <- as.character(dat[[key]]) %in% selected + colors[selected.idx & left.idx] <- .fvolcano_point_palette$left_selected + colors[selected.idx & right.idx] <- .fvolcano_point_palette$right_selected + colors[selected.idx & !left.idx & !right.idx] <- + .fvolcano_point_palette$selected + } + outline.idx <- left.idx | right.idx | selected.idx + line.colors[outline.idx] <- .fvolcano_point_palette$outline + line.widths[outline.idx] <- 0.5 + list(color = colors, line.color = line.colors, line.width = line.widths) +} + +.fvolcano_style_points <- function(plt, point.style) { + if (length(plt$x$data) == 0L) { + return(plt) + } + marker <- plt$x$data[[1L]]$marker + if (is.null(marker)) { + marker <- list() + } + marker$color <- point.style$color + marker$size <- 4 + marker$opacity <- 1 + marker$line <- list( + color = point.style$line.color, + width = point.style$line.width + ) + plt$x$data[[1L]]$marker <- marker + plt +} + +.fvolcano_require_columns <- function(dat, cols) { + missing <- setdiff(cols, colnames(dat)) + if (length(missing)) { + stop( + sprintf( + "Volcano data is missing required columns: %s", + paste(missing, collapse = ", ") + ), + call. = FALSE + ) + } + invisible(dat) +} diff --git a/man/fvolcanoLabelChoices.Rd b/man/fvolcanoLabelChoices.Rd new file mode 100644 index 0000000..f84227a --- /dev/null +++ b/man/fvolcanoLabelChoices.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fvolcanoPlot.R +\name{fvolcanoLabelChoices} +\alias{fvolcanoLabelChoices} +\title{Volcano plot label choices} +\usage{ +fvolcanoLabelChoices( + dat, + label_priority = c("symbol", "feature_id"), + key = "feature_id" +) +} +\arguments{ +\item{dat}{Data frame containing feature labels and keys.} + +\item{label_priority}{Ordered label columns to use before falling back to +\code{key}.} + +\item{key}{Column name for the feature key.} +} +\value{ +A named character vector where names are display labels and values +are feature keys. +} +\description{ +Volcano plot label choices +} diff --git a/man/fvolcanoPlot.Rd b/man/fvolcanoPlot.Rd new file mode 100644 index 0000000..963d8e2 --- /dev/null +++ b/man/fvolcanoPlot.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fvolcanoPlot.R +\name{fvolcanoPlot} +\alias{fvolcanoPlot} +\title{Reusable volcano plot} +\usage{ +fvolcanoPlot( + dat, + ..., + x = "logFC", + y = "pval", + key = "feature_id", + labels = NULL, + label_priority = c("symbol", "feature_id"), + hover = c("symbol", "logFC", "FDR"), + event_source = NULL, + label_limit = 20L, + x_cutoff = NULL, + y_cutoff = NULL, + width = NULL, + height = NULL, + webgl = TRUE +) +} +\arguments{ +\item{dat}{Data frame containing the x-axis, y-metric, and key columns.} + +\item{...}{Passed to \code{\link[FacileViz:fscatterplot]{FacileViz::fscatterplot()}}.} + +\item{x}{Column name for the x-axis value.} + +\item{y}{Column name for the y-axis metric to transform with \code{-log10()}.} + +\item{key}{Column name for the feature key.} + +\item{labels}{Feature keys to label.} + +\item{label_priority}{Ordered label columns to use before falling back to +\code{key}.} + +\item{hover}{Columns to include in Plotly hover text.} + +\item{event_source}{Plotly event source.} + +\item{label_limit}{Maximum number of labeled points.} + +\item{x_cutoff, y_cutoff}{Optional cutoffs used to color points.} + +\item{width, height, webgl}{Passed to \code{\link[FacileViz:fscatterplot]{FacileViz::fscatterplot()}}.} +} +\value{ +A Plotly htmlwidget. +} +\description{ +Builds a Plotly volcano plot from a prepared differential-statistics table. +Data preparation and downstream interpretation stay with the caller. +} diff --git a/tests/testthat/test-fvolcanoPlot.R b/tests/testthat/test-fvolcanoPlot.R new file mode 100644 index 0000000..fb34de2 --- /dev/null +++ b/tests/testthat/test-fvolcanoPlot.R @@ -0,0 +1,97 @@ +volcano_test_data <- function() { + data.frame( + symbol = c("A", "Dup", "Dup", NA_character_, ""), + feature_id = paste0("gene_", letters[1:5]), + logFC = c(-2, -1, 0, 1, 2), + pval = c(0.001, 0.01, 0.5, 0.02, 1), + FDR = c(0.005, 0.04, 0.6, 0.08, 1), + stringsAsFactors = FALSE + ) +} + +test_that("volcano metric helpers fall back and transform y values", { + y <- c("p-value" = "pval", "FDR" = "FDR") + dat <- volcano_test_data() + + expect_equal(.fvolcano_y_metric(NULL, y), "pval") + expect_equal(.fvolcano_y_metric("bad", y), "pval") + expect_equal(.fvolcano_y_metric("FDR", y), "FDR") + expect_equal(.fvolcano_y_label("FDR"), "-log10(FDR)") + expect_equal(.fvolcano_y_values(dat, "pval"), -log10(dat$pval)) +}) + +test_that("volcano labels are disambiguated and limited", { + dat <- volcano_test_data() + choices <- fvolcanoLabelChoices( + dat, + c("symbol", "feature_id"), + "feature_id" + ) + expect_equal( + names(choices), + c("A", "Dup (gene_b)", "Dup (gene_c)", "gene_d", "gene_e") + ) + + y.values <- .fvolcano_y_values(dat, "pval") + labels <- .fvolcano_label_data( + dat, + y.values, + c("gene_a", "gene_b", "gene_c"), + "logFC", + "feature_id", + c("symbol", "feature_id"), + label_limit = 2L + ) + expect_equal(labels$feature_id, c("gene_a", "gene_b")) +}) + +test_that("volcano point styles classify cutoff and selected points", { + dat <- volcano_test_data() + y.values <- .fvolcano_y_values(dat, "pval") + style <- .fvolcano_point_style( + dat, + y.values, + x.cutoff = 1, + y.cutoff = 1.5, + selected = "gene_c", + x = "logFC", + key = "feature_id", + label_limit = 20L + ) + + expect_equal(style$color[1], .fvolcano_point_palette$left) + expect_equal(style$color[3], .fvolcano_point_palette$selected) + expect_equal(style$line.width[c(1, 3)], c(0.5, 0.5)) + expect_equal(style$line.width[5], 0) +}) + +test_that("volcano axis ranges handle empty and constant values", { + empty <- data.frame(logFC = numeric(), yaxis = numeric()) + expect_equal(.fvolcano_axis_ranges(empty, "logFC")$x, c(-0.58, 0.68)) + + constant <- data.frame(logFC = c(1, 1), yaxis = c(2, 2)) + ranges <- .fvolcano_axis_ranges(constant, "logFC") + expect_lt(ranges$x[1], 1) + expect_gt(ranges$x[2], 1) + expect_lt(ranges$y[1], 2) + expect_gt(ranges$y[2], 2) +}) + +test_that("fvolcanoPlot builds a plotly widget", { + dat <- volcano_test_data() + plt <- fvolcanoPlot( + dat, + y = "pval", + labels = "gene_a", + x_cutoff = 1, + y_cutoff = 1.5, + hover = NULL, + event_source = "volcano_test" + ) + + expect_s3_class(plt, "plotly") + annotations <- unlist( + lapply(plt$x$layoutAttrs, function(x) length(x$annotations)) + ) + expect_true(any(annotations == 1L)) +})