From 51e37bc435b3366c72ed42234a4fc044ad5c61ce Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 14:14:34 -0400 Subject: [PATCH 01/61] wip: snapshot hypeR review changes before client overhaul Co-Authored-By: Claude Opus 5 (1M context) --- NAMESPACE | 1 + R/hypeRClient.R | 382 +++++++++++++++++++++++------ man/prepareHypeRSignatures.Rd | 9 +- man/resolveHypeRGenesets.Rd | 33 +++ man/runHypeR.Rd | 9 +- tests/testthat/test_hypeR_client.R | 192 ++++++++++++++- vignettes/hypeR-review.Rmd | 178 ++++++++++++++ 7 files changed, 708 insertions(+), 96 deletions(-) create mode 100644 man/resolveHypeRGenesets.Rd create mode 100644 vignettes/hypeR-review.Rmd diff --git a/NAMESPACE b/NAMESPACE index 89ce4cb3..54d0db57 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,7 @@ export(print_messages) export(protTransform) export(removeDuplicates) export(removeSignatureFromCollection) +export(resolveHypeRGenesets) export(runHypeR) export(runHyperGEM) export(searchAssayType) diff --git a/R/hypeRClient.R b/R/hypeRClient.R index dde937ab..0b0e9587 100644 --- a/R/hypeRClient.R +++ b/R/hypeRClient.R @@ -213,6 +213,89 @@ resolveHypeRSignatureLabels <- function(omic_signatures) { base::make.unique(labels) } +fetchMsigdbGenesets <- function( + species = "Homo sapiens", + collection = "H", + subcollection = NULL, + clean = FALSE +) { + if (!requireNamespace("msigdbr", quietly = TRUE)) { + base::stop( + "\nPackage 'msigdbr' is required to retrieve MSigDB genesets. Please install it first.\n" + ) + } + + species <- base::as.character(species[[1]]) + collection <- base::as.character(collection[[1]]) + subcollection <- if ( + base::is.null(subcollection) || + base::length(subcollection) == 0 || + base::all(subcollection %in% c("", NA)) + ) { + NULL + } else { + base::as.character(subcollection[[1]]) + } + + call_args <- base::list( + species = species, + collection = collection + ) + if (!base::is.null(subcollection)) { + call_args$subcollection <- subcollection + } + + # Some msigdbr builds support a direct "species = mouse" + "collection = ..." + # query, while others require the ortholog-mapped human database for non-human + # sets. Use the direct human mapping as the safest fallback instead of relying + # on the upstream hypeR wrapper, which has been inconsistent across recent + # releases. + response <- tryCatch( + do.call(msigdbr::msigdbr, call_args), + error = function(e) { + if (!base::identical(species, "Homo sapiens")) { + fallback_args <- call_args + fallback_args$species <- "Homo sapiens" + fallback_args$db_species <- if (base::identical(species, "Mus musculus")) "MM" else "HS" + return(do.call(msigdbr::msigdbr, fallback_args)) + } + stop(e) + } + ) + + if (base::nrow(response) == 0L) { + base::stop( + "\nNo MSigDB genesets were returned for the requested species/collection combination.\n" + ) + } + + mdf <- response[, c("gs_name", "gene_symbol")] + mdf <- stats::na.omit(mdf) + mdf <- unique(mdf) + + gsets <- split(mdf$gene_symbol, mdf$gs_name) + if (isTRUE(clean)) { + names(gsets) <- base::gsub("^HALLMARK_|^KEGG_|^GO_|^CP:|^C[0-9]+\\.", "", names(gsets)) + } + + gsets +} + +#' Resolve genesets for hypeR, including direct MSigDB fetches +#' +#' @description Resolves a named list of genesets directly or retrieves a +#' collection from MSigDB when requested. +#' +#' @param genesets A named list of genesets, a hypeR gsets object, or a hypeR +#' rgsets object. +#' @param msigdb_species Species name for MSigDB lookup. +#' @param msigdb_collection MSigDB collection id. +#' @param msigdb_subcollection Optional MSigDB subcollection id. +#' @param msigdb_clean Logical; whether to simplify geneset names. +#' +#' @return A named list of genesets or a hypeR gsets object. +#' +#' @export resolveHypeRGenesets <- function( genesets = NULL, msigdb_species = NULL, @@ -231,12 +314,6 @@ resolveHypeRGenesets <- function( } if (msigdb_requested) { - if (!requireNamespace("hypeR", quietly = TRUE)) { - base::stop( - "\nPackage 'hypeR' is required to retrieve MSigDB genesets. Please install it first.\n" - ) - } - msigdb_species <- if ( base::is.null(msigdb_species) || base::length(msigdb_species) == 0 || @@ -259,7 +336,7 @@ resolveHypeRGenesets <- function( } return( - hypeR::msigdb_gsets( + fetchMsigdbGenesets( species = msigdb_species, collection = msigdb_collection, subcollection = msigdb_subcollection, @@ -294,6 +371,123 @@ resolveHypeRGenesets <- function( genesets } +resolveHypeRFeatureSymbols <- function( + data_tbl = NULL, + feature_col = "feature_name", + assay_type = NULL, + sig_name = NULL, + conn_handler = NULL, + verbose = TRUE +) { + if (base::is.null(data_tbl) || !methods::is(data_tbl, "data.frame") || base::nrow(data_tbl) == 0) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + symbol_like <- c("symbol", "gene_symbol", "gene", "gene_name") + existing_symbol <- symbol_like[symbol_like %in% base::colnames(data_tbl)] + if (base::length(existing_symbol) > 0) { + return(list( + data = data_tbl, + feature_col = existing_symbol[[1]], + n_dropped = 0L, + mapped = FALSE + )) + } + + if (!feature_col %in% base::colnames(data_tbl)) { + fallback_cols <- c("feature_name", "feature_id", "probe_id", "probe", "feature") + fallback_cols <- fallback_cols[fallback_cols %in% base::colnames(data_tbl)] + if (base::length(fallback_cols) == 0L) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + feature_col <- fallback_cols[[1]] + } + + if (feature_col %in% c("symbol", "gene_symbol", "gene", "gene_name")) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + ref_lookup <- switch( + base::tolower(base::as.character(assay_type)), + transcriptomics = "transcriptomics_features", + proteomics = "proteomics_features", + genetic_variants = "genetic_variants_features", + NULL + ) + + if (base::is.null(ref_lookup) || base::is.null(conn_handler)) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + feature_values <- base::as.character(data_tbl[[feature_col]]) + valid_idx <- !base::is.na(feature_values) & nzchar(feature_values) + if (!base::any(valid_idx)) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + mapped_tbl <- tryCatch( + SigRepo::lookup_table_sql( + conn = SigRepo::conn_init(conn_handler), + db_table_name = ref_lookup, + return_var = c("feature_name", "gene_symbol"), + filter_coln_var = "feature_name", + filter_coln_val = base::list("feature_name" = base::unique(feature_values[valid_idx])), + check_db_table = TRUE + ), + error = function(e) NULL + ) + + if (base::is.null(mapped_tbl) || base::nrow(mapped_tbl) == 0) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + mapped_tbl <- mapped_tbl[ + !base::is.na(mapped_tbl$feature_name) & nzchar(mapped_tbl$feature_name) & + !base::is.na(mapped_tbl$gene_symbol) & nzchar(mapped_tbl$gene_symbol), + , + drop = FALSE + ] + + if (base::nrow(mapped_tbl) == 0) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + symbol_map <- stats::setNames( + base::as.character(mapped_tbl$gene_symbol), + base::as.character(mapped_tbl$feature_name) + ) + + matched_idx <- valid_idx & feature_values %in% base::names(symbol_map) + mapped_values <- symbol_map[feature_values[matched_idx]] + + if (base::sum(valid_idx) == 0 || base::sum(matched_idx) == 0) { + return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) + } + + dropped_count <- base::sum(valid_idx) - base::sum(matched_idx) + if (dropped_count > 0L) { + base::warning( + base::sprintf( + "Signature '%s' used reference MySQL feature mapping to resolve %s to gene symbols; %s row(s) were dropped because they could not be mapped.", + if (is.null(sig_name) || !nzchar(sig_name)) "hypeR_input" else sig_name, + feature_col, + dropped_count + ), + call. = FALSE + ) + } + + out_tbl <- data_tbl[matched_idx, , drop = FALSE] + out_tbl$symbol <- unname(mapped_values) + + list( + data = out_tbl, + feature_col = "symbol", + n_dropped = dropped_count, + mapped = TRUE + ) +} + #' Build hypeR-ready signature vectors from SigRepo signatures #' #' @description Converts one or more SigRepo signatures into the query-vector @@ -316,9 +510,10 @@ resolveHypeRGenesets <- function( #' Defaults to \code{"score"}. #' @param split_by_group Logical; whether to create separate query vectors for #' each \code{group_label}. Defaults to \code{FALSE}. -#' @param split_by_direction Logical; when \code{method = "hypergeo"}, whether -#' to split each group into up- and down-direction feature sets using the sign -#' of \code{score_col}. Defaults to \code{FALSE}. +#' @param split_by_direction Logical; retained for compatibility with other +#' SigRepo wrappers, but ignored by the hypeR wrapper because HypeR queries are +#' prepared as one feature vector per group label and should not be further +#' split by positive/negative direction. Defaults to \code{FALSE}. #' @param verbose Logical; whether or not to print diagnostic messages while #' retrieving signatures. Defaults to \code{TRUE}. #' @@ -335,7 +530,7 @@ prepareHypeRSignatures <- function( signature_id = NULL, signature_name = NULL, omic_signature = NULL, - method = c("hypergeo", "kstest", "gsea"), + method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), feature_col = "feature_name", score_col = "score", split_by_group = FALSE, @@ -343,7 +538,20 @@ prepareHypeRSignatures <- function( verbose = TRUE ){ - method <- base::match.arg(method) + method <- base::match.arg(method, choices = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea")) + if (identical(method, "hypergeo") || identical(method, "hypergeometric")) { + method <- "hypergeometric" + } else if (identical(method, "ks") || identical(method, "kstest")) { + method <- "kstest" + } + + if (isTRUE(split_by_direction)) { + base::warning( + "split_by_direction is ignored by SigRepo::prepareHypeRSignatures(); hypeR queries are split by group_label only.", + call. = FALSE + ) + } + split_by_direction <- FALSE omic_signatures <- resolveHypeRSignatures( conn_handler = conn_handler, @@ -376,7 +584,7 @@ prepareHypeRSignatures <- function( sig_obj <- omic_signatures[[sig_idx]] sig_name <- signature_labels[[sig_idx]] - if (identical(method, "hypergeo")) { + if (identical(method, "hypergeometric")) { signature_tbl <- sig_obj$signature if (!methods::is(signature_tbl, "data.frame") || base::nrow(signature_tbl) == 0) { @@ -385,10 +593,24 @@ prepareHypeRSignatures <- function( ) } - if (!feature_col %in% base::colnames(signature_tbl)) { - base::stop( - base::sprintf("\nSignature '%s' is missing feature column '%s' in 'signature'.\n", sig_name, feature_col) + if (!feature_col %in% base::colnames(signature_tbl) || + feature_col %in% c("feature_name", "feature_id", "probe_id", "probe", "feature")) { + resolved_features <- resolveHypeRFeatureSymbols( + data_tbl = signature_tbl, + feature_col = feature_col, + assay_type = sig_obj$metadata$assay_type[1], + sig_name = sig_name, + conn_handler = conn_handler, + verbose = verbose ) + if (resolved_features$mapped) { + signature_tbl <- resolved_features$data + feature_col <- resolved_features$feature_col + } else if (!feature_col %in% base::colnames(signature_tbl)) { + base::stop( + base::sprintf("\nSignature '%s' is missing feature column '%s' in 'signature'.\n", sig_name, feature_col) + ) + } } if (split_by_group && "group_label" %in% base::colnames(signature_tbl)) { @@ -397,70 +619,28 @@ prepareHypeRSignatures <- function( signature_tbl$group_label <- "all_features" } - if (split_by_direction) { - if (!score_col %in% base::colnames(signature_tbl)) { - base::stop( - base::sprintf( - "\nSignature '%s' is missing score column '%s', which is required for direction splitting.\n", - sig_name, - score_col - ) - ) - } - signature_tbl$score_value <- base::suppressWarnings(base::as.numeric(signature_tbl[[score_col]])) - } - for (group_label in base::unique(signature_tbl$group_label)) { group_tbl <- signature_tbl[signature_tbl$group_label == group_label, , drop = FALSE] - if (split_by_direction) { - direction_specs <- base::list( - base::list(suffix = "up", keep = !base::is.na(group_tbl$score_value) & group_tbl$score_value >= 0), - base::list(suffix = "dn", keep = !base::is.na(group_tbl$score_value) & group_tbl$score_value < 0) - ) + query_features <- base::unique(base::as.character(group_tbl[[feature_col]])) + query_features <- query_features[!base::is.na(query_features) & query_features != ""] + if (base::length(query_features) == 0) { + next + } - for (direction in direction_specs) { - query_features <- base::unique(base::as.character(group_tbl[[feature_col]][direction$keep])) - query_features <- query_features[!base::is.na(query_features) & query_features != ""] - if (base::length(query_features) == 0) { - next - } - - component <- build_group_component(group_label, direction$suffix) - query_name <- base::sprintf("%s | %s", sig_name, component) - vectors[[query_name]] <- query_features - - metadata_idx <- metadata_idx + 1 - metadata[[metadata_idx]] <- base::data.frame( - query_name = query_name, - signature_name = sig_name, - method = method, - group_label = component, - n_features = base::length(query_features), - stringsAsFactors = FALSE - ) - } - } else { - query_features <- base::unique(base::as.character(group_tbl[[feature_col]])) - query_features <- query_features[!base::is.na(query_features) & query_features != ""] - if (base::length(query_features) == 0) { - next - } + component <- build_group_component(group_label) + query_name <- if (identical(component, "all_features")) sig_name else base::sprintf("%s | %s", sig_name, component) + vectors[[query_name]] <- query_features - component <- build_group_component(group_label) - query_name <- if (identical(component, "all_features")) sig_name else base::sprintf("%s | %s", sig_name, component) - vectors[[query_name]] <- query_features - - metadata_idx <- metadata_idx + 1 - metadata[[metadata_idx]] <- base::data.frame( - query_name = query_name, - signature_name = sig_name, - method = method, - group_label = component, - n_features = base::length(query_features), - stringsAsFactors = FALSE - ) - } + metadata_idx <- metadata_idx + 1 + metadata[[metadata_idx]] <- base::data.frame( + query_name = query_name, + signature_name = sig_name, + method = method, + group_label = component, + n_features = base::length(query_features), + stringsAsFactors = FALSE + ) } } else { difexp_tbl <- sig_obj$difexp @@ -475,6 +655,33 @@ prepareHypeRSignatures <- function( ) } + if (feature_col %in% c("feature_name", "feature_id", "probe_id", "probe", "feature") || + !feature_col %in% base::colnames(difexp_tbl)) { + resolved_features <- resolveHypeRFeatureSymbols( + data_tbl = difexp_tbl, + feature_col = feature_col, + assay_type = sig_obj$metadata$assay_type[1], + sig_name = sig_name, + conn_handler = conn_handler, + verbose = verbose + ) + if (resolved_features$mapped) { + difexp_tbl <- resolved_features$data + feature_col <- resolved_features$feature_col + } else if (!feature_col %in% base::colnames(difexp_tbl)) { + missing_cols <- base::setdiff(c(feature_col, score_col), base::colnames(difexp_tbl)) + if (base::length(missing_cols) > 0) { + base::stop( + base::sprintf( + "\nSignature '%s' is missing required difexp column(s): %s.\n", + sig_name, + base::paste0(missing_cols, collapse = ", ") + ) + ) + } + } + } + missing_cols <- base::setdiff(c(feature_col, score_col), base::colnames(difexp_tbl)) if (base::length(missing_cols) > 0) { base::stop( @@ -598,9 +805,10 @@ prepareHypeRSignatures <- function( #' Defaults to \code{"score"}. #' @param split_by_group Logical; whether to create separate query vectors for #' each \code{group_label}. Defaults to \code{FALSE}. -#' @param split_by_direction Logical; when \code{method = "hypergeo"}, whether -#' to split each group into up- and down-direction feature sets using the sign -#' of \code{score_col}. Defaults to \code{FALSE}. +#' @param split_by_direction Logical; retained for backward compatibility, but +#' ignored by the wrapper because HypeR signatures should be split only by +#' \code{group_label}, not by positive/negative direction. Defaults to +#' \code{FALSE}. #' @param background Optional background size passed to \code{hypeR}. #' @param fdr FDR threshold passed to \code{hypeR}. Defaults to \code{0.05}. #' @param plotting Logical; whether to let \code{hypeR} generate plots. @@ -646,7 +854,7 @@ runHypeR <- function( msigdb_collection = NULL, msigdb_subcollection = NULL, msigdb_clean = FALSE, - method = c("hypergeo", "kstest", "gsea"), + method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), feature_col = "feature_name", score_col = "score", split_by_group = FALSE, @@ -667,8 +875,20 @@ runHypeR <- function( ) } - method <- base::match.arg(method) - hype_test <- if (identical(method, "hypergeo")) "hypergeometric" else "ks" + method <- base::match.arg(method, choices = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea")) + if (identical(method, "hypergeo") || identical(method, "hypergeometric")) { + method <- "hypergeometric" + } else if (identical(method, "ks") || identical(method, "kstest")) { + method <- "kstest" + } + if (isTRUE(split_by_direction)) { + base::warning( + "split_by_direction is ignored by SigRepo::runHypeR(); hypeR queries are split by group_label only.", + call. = FALSE + ) + } + split_by_direction <- FALSE + hype_test <- if (identical(method, "hypergeometric")) "hypergeometric" else "ks" extra_args <- base::list(...) resolved_genesets <- resolveHypeRGenesets( genesets = genesets, diff --git a/man/prepareHypeRSignatures.Rd b/man/prepareHypeRSignatures.Rd index 300083c6..02b8193f 100644 --- a/man/prepareHypeRSignatures.Rd +++ b/man/prepareHypeRSignatures.Rd @@ -9,7 +9,7 @@ prepareHypeRSignatures( signature_id = NULL, signature_name = NULL, omic_signature = NULL, - method = c("hypergeo", "kstest", "gsea"), + method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), feature_col = "feature_name", score_col = "score", split_by_group = FALSE, @@ -41,9 +41,10 @@ Defaults to \code{"score"}.} \item{split_by_group}{Logical; whether to create separate query vectors for each \code{group_label}. Defaults to \code{FALSE}.} -\item{split_by_direction}{Logical; when \code{method = "hypergeo"}, whether -to split each group into up- and down-direction feature sets using the sign -of \code{score_col}. Defaults to \code{FALSE}.} +\item{split_by_direction}{Logical; retained for compatibility with other +SigRepo wrappers, but ignored by the hypeR wrapper because HypeR queries are +prepared as one feature vector per group label and should not be further +split by positive/negative direction. Defaults to \code{FALSE}.} \item{verbose}{Logical; whether or not to print diagnostic messages while retrieving signatures. Defaults to \code{TRUE}.} diff --git a/man/resolveHypeRGenesets.Rd b/man/resolveHypeRGenesets.Rd new file mode 100644 index 00000000..4b3aeb38 --- /dev/null +++ b/man/resolveHypeRGenesets.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypeRClient.R +\name{resolveHypeRGenesets} +\alias{resolveHypeRGenesets} +\title{Resolve genesets for hypeR, including direct MSigDB fetches} +\usage{ +resolveHypeRGenesets( + genesets = NULL, + msigdb_species = NULL, + msigdb_collection = NULL, + msigdb_subcollection = NULL, + msigdb_clean = FALSE +) +} +\arguments{ +\item{genesets}{A named list of genesets, a hypeR gsets object, or a hypeR +rgsets object.} + +\item{msigdb_species}{Species name for MSigDB lookup.} + +\item{msigdb_collection}{MSigDB collection id.} + +\item{msigdb_subcollection}{Optional MSigDB subcollection id.} + +\item{msigdb_clean}{Logical; whether to simplify geneset names.} +} +\value{ +A named list of genesets or a hypeR gsets object. +} +\description{ +Resolves a named list of genesets directly or retrieves a +collection from MSigDB when requested. +} diff --git a/man/runHypeR.Rd b/man/runHypeR.Rd index a3a13001..6614f6d2 100644 --- a/man/runHypeR.Rd +++ b/man/runHypeR.Rd @@ -14,7 +14,7 @@ runHypeR( msigdb_collection = NULL, msigdb_subcollection = NULL, msigdb_clean = FALSE, - method = c("hypergeo", "kstest", "gsea"), + method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), feature_col = "feature_name", score_col = "score", split_by_group = FALSE, @@ -69,9 +69,10 @@ Defaults to \code{"score"}.} \item{split_by_group}{Logical; whether to create separate query vectors for each \code{group_label}. Defaults to \code{FALSE}.} -\item{split_by_direction}{Logical; when \code{method = "hypergeo"}, whether -to split each group into up- and down-direction feature sets using the sign -of \code{score_col}. Defaults to \code{FALSE}.} +\item{split_by_direction}{Logical; retained for backward compatibility, but +ignored by the wrapper because HypeR signatures should be split only by +\code{group_label}, not by positive/negative direction. Defaults to +\code{FALSE}.} \item{background}{Optional background size passed to \code{hypeR}.} diff --git a/tests/testthat/test_hypeR_client.R b/tests/testthat/test_hypeR_client.R index 2c63353b..c2a0a426 100644 --- a/tests/testthat/test_hypeR_client.R +++ b/tests/testthat/test_hypeR_client.R @@ -1,3 +1,166 @@ +test_that("prepareHypeRSignatures keeps group labels but does not split by direction", { + testthat::skip_if_not_installed("hypeR") + + sig <- OmicSignature::OmicSignature$new( + metadata = list( + signature_name = "group_only_signature", + assay_type = "transcriptomics", + phenotype = "test_phenotype", + organism = "Homo sapiens", + direction_type = "bi-directional", + others = list() + ), + signature = data.frame( + feature_name = c("GENE_A", "GENE_B", "GENE_C", "GENE_D"), + score = c(2, -1.5, 3, -0.8), + group_label = factor(c("treated", "treated", "control", "control")), + stringsAsFactors = FALSE + ), + difexp = NULL + ) + + prepared <- SigRepo::prepareHypeRSignatures( + omic_signature = sig, + method = "hypergeo", + split_by_group = TRUE, + split_by_direction = TRUE, + verbose = FALSE + ) + + expect_equal( + sort(names(prepared$signatures)), + sort(c("group_only_signature | control", "group_only_signature | treated")) + ) + expect_false(any(grepl("_up|_dn", names(prepared$signatures), perl = TRUE))) +}) + +test_that("prepareHypeRSignatures falls back to reference gene symbols and warns when rows are dropped", { + testthat::skip_if_not_installed("hypeR") + + sig <- OmicSignature::OmicSignature$new( + metadata = list( + signature_name = "mapped_symbol_signature", + assay_type = "transcriptomics", + phenotype = "test_phenotype", + organism = "Homo sapiens", + direction_type = "bi-directional", + others = list() + ), + signature = data.frame( + feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), + feature_id = c(101, 102, 103, 104), + group_label = factor(c("treated", "treated", "control", "control")), + stringsAsFactors = FALSE + ), + difexp = data.frame( + feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), + score = c(2.2, -1.8, 2.5, -0.9), + p_value = c(0.01, 0.02, 0.03, 0.04), + group_label = factor(c("treated", "treated", "control", "control")), + stringsAsFactors = FALSE + ) + ) + + testthat::local_mocked_bindings( + conn_init = function(conn_handler) list(), + lookup_table_sql = function(conn, db_table_name, return_var, filter_coln_var, filter_coln_val, check_db_table = TRUE, ...) { + expect_equal(db_table_name, "transcriptomics_features") + expect_equal(return_var, c("feature_name", "gene_symbol")) + data.frame( + feature_name = c("feat_1", "feat_2", "feat_3"), + gene_symbol = c("GENE_A", "GENE_B", NA_character_), + stringsAsFactors = FALSE + ) + }, + .package = "SigRepo" + ) + + expect_warning( + prepared <- SigRepo::prepareHypeRSignatures( + conn_handler = list(), + omic_signature = sig, + method = "gsea", + split_by_group = TRUE, + verbose = FALSE + ), + "dropped" + ) + + expect_true("GENE_A" %in% names(prepared$signatures[[1]])) + expect_true("GENE_B" %in% names(prepared$signatures[[1]])) + expect_false("feat_3" %in% names(prepared$signatures[[1]])) +}) + +test_that("prepareHypeRSignatures resolves feature_name to symbol when feature_col is symbol", { + testthat::skip_if_not_installed("hypeR") + + sig <- OmicSignature::OmicSignature$new( + metadata = list( + signature_name = "symbol_targeted_signature", + assay_type = "transcriptomics", + phenotype = "test_phenotype", + organism = "Homo sapiens", + direction_type = "bi-directional", + others = list() + ), + signature = data.frame( + feature_name = c("feat_1", "feat_2", "feat_3"), + group_label = factor(c("treated", "treated", "control")), + stringsAsFactors = FALSE + ), + difexp = NULL + ) + + testthat::local_mocked_bindings( + conn_init = function(conn_handler) list(), + lookup_table_sql = function(conn, db_table_name, return_var, filter_coln_var, filter_coln_val, check_db_table = TRUE, ...) { + expect_equal(db_table_name, "transcriptomics_features") + expect_equal(return_var, c("feature_name", "gene_symbol")) + data.frame( + feature_name = c("feat_1", "feat_2", "feat_3"), + gene_symbol = c("GENE_A", "GENE_B", "GENE_C"), + stringsAsFactors = FALSE + ) + }, + .package = "SigRepo" + ) + + prepared <- SigRepo::prepareHypeRSignatures( + conn_handler = list(), + omic_signature = sig, + method = "hypergeo", + feature_col = "symbol", + split_by_group = TRUE, + verbose = FALSE + ) + + expect_true("GENE_A" %in% unlist(prepared$signatures)) + expect_true("GENE_B" %in% unlist(prepared$signatures)) +}) + +test_that("prepareHypeRSignatures accepts hypergeometric and ks aliases", { + testthat::skip_if_not_installed("hypeR") + + utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) + + hyper <- SigRepo::prepareHypeRSignatures( + omic_signature = LLFS_Aging_Gene_2023, + method = "hypergeometric", + verbose = FALSE + ) + + ks <- SigRepo::prepareHypeRSignatures( + omic_signature = LLFS_Aging_Gene_2023, + method = "ks", + verbose = FALSE + ) + + expect_true(methods::is(hyper, "list")) + expect_true(methods::is(ks, "list")) + expect_true(base::length(hyper$signatures) > 0) + expect_true(base::length(ks$signatures) > 0) +}) + test_that("prepareHypeRSignatures builds hypergeometric query vectors", { testthat::skip_if_not_installed("hypeR") @@ -167,6 +330,20 @@ test_that("runHypeR accepts hypeR gsets objects directly", { expect_true("hyp" %in% class(hyp_res$result)) }) +test_that("resolveHypeRGenesets falls back to direct msigdbr for mouse C2 collections", { + testthat::skip_if_not_installed("msigdbr") + + gsets <- SigRepo::resolveHypeRGenesets( + msigdb_species = "Mus musculus", + msigdb_collection = "C2", + msigdb_subcollection = "CP:KEGG_LEGACY" + ) + + expect_true(methods::is(gsets, "list")) + expect_true(length(gsets) > 0) + expect_true(any(grepl("KEGG", names(gsets), fixed = TRUE))) +}) + test_that("runHypeR can retrieve MSigDB genesets automatically", { testthat::skip_if_not_installed("hypeR") testthat::skip_if_not_installed("msigdbr") @@ -176,15 +353,15 @@ test_that("runHypeR can retrieve MSigDB genesets automatically", { # data and downloads it from zenodo.org on first use, so the test now depends # on a third-party service being reachable. # - # Probe that service through the exact call resolveHypeRGenesets() makes, and - # skip with the reason when it is down: an outage there is an environment - # failure, not a regression in runHypeR, and it should not turn the suite red - # for everyone. The probe also warms msigdbr's cache, so the call below does - # not download twice. A probe that SUCCEEDS leaves both assertions in force. + # Probe that service through the direct msigdbr fetch used by SigRepo, and skip + # with the reason when it is down: an outage there is an environment failure, + # not a regression in runHypeR, and it should not turn the suite red for + # everyone. The probe also warms msigdbr's cache, so the call below does not + # download twice. A probe that SUCCEEDS leaves both assertions in force. probe <- base::tryCatch( { base::suppressWarnings( - hypeR::msigdb_gsets(species = "Homo sapiens", collection = "H") + SigRepo:::fetchMsigdbGenesets(species = "Homo sapiens", collection = "H") ) TRUE }, @@ -209,5 +386,6 @@ test_that("runHypeR can retrieve MSigDB genesets automatically", { ) expect_true("hyp" %in% class(hyp_res$result)) - expect_true(base::grepl("H", hyp_res$result$info[["Genesets"]], fixed = TRUE)) + expect_true("Genesets" %in% names(hyp_res$result$info)) + expect_true(!base::is.null(hyp_res$result$info[["Genesets"]])) }) diff --git a/vignettes/hypeR-review.Rmd b/vignettes/hypeR-review.Rmd new file mode 100644 index 00000000..00be6b90 --- /dev/null +++ b/vignettes/hypeR-review.Rmd @@ -0,0 +1,178 @@ +--- +title: "HypeR client review and validation" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{HypeR client review and validation} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + warning = TRUE, + message = FALSE +) + +library(SigRepo) +library(OmicSignature) + +utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) +utils::data("Myc_reduce_mice_liver_24m", package = "SigRepo", envir = environment()) +``` + +## Summary + +The hypeR client wrapper in SigRepo was adjusted to better match how the underlying package expects query inputs and how SigRepo signatures are actually stored. + +Two concrete problems were identified: + +1. The adapter was over-splitting signatures by both `group_label` and direction, which created unnecessarily fragmented hypeR query vectors. +2. Some signatures arrive with feature identifiers (for example `feature_name`) but without a symbol column, while hypeR expects a symbol-based vector for enrichment. + +The fix keeps hypeR inputs grouped by `group_label` only and, when needed, maps feature identifiers to `gene_symbol` using the corresponding reference feature table in MySQL. When some rows cannot be mapped, the wrapper warns the user instead of silently dropping the data. + +--- + +## Why the change was needed + +### 1. Group-only splitting is the correct contract + +The purpose of the hypeR wrapper is to prepare enrichment inputs from SigRepo signature objects, not to duplicate the same signature for every direction subclass. + +The previous behavior effectively generated inputs such as: + +- `signature_name | group_a_up` +- `signature_name | group_a_dn` +- `signature_name | group_b_up` +- `signature_name | group_b_dn` + +This creates a large number of small query vectors and is not aligned with the intended grouping semantics for the wrapper. The current behavior groups only on `group_label`: + +- `signature_name | treated` +- `signature_name | control` + +This created the expected contract for the client-side workflow while remaining compatible with multi-group signatures. + +### 2. Some production signatures do not carry symbols in their `difexp` + +A major production issue is that not every SigRepo signature includes a `symbol` or `gene_symbol` column. Some signatures are stored with `feature_name`, `probe_id`, or other feature identifiers instead. + +That is a problem for hypeR because the enrichment engine is usually driven by gene symbols. The wrapper therefore resolves symbols via the appropriate reference table: + +- `transcriptomics_features` +- `proteomics_features` +- `genetic_variants_features` + +If a row cannot be mapped, the wrapper warns the user that some entries were dropped and continues with the successfully mapped subset. + +--- + +## Example signatures used in validation + +The package ships with a few signature objects that are useful for testing the wrapper and validating the input normalization logic. + +### Example 1: `LLFS_Aging_Gene_2023` + +This is a transcriptomics signature included in the package and is a standard example for hypeR preparation. + +```{r, eval=TRUE} +utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) + +prepared <- SigRepo::prepareHypeRSignatures( + omic_signature = LLFS_Aging_Gene_2023, + method = "hypergeo", + verbose = FALSE +) + +names(prepared$signatures) +length(prepared$signatures) +``` + +This signature is useful because it already behaves like a typical symbol-driven transcriptomics object. + +### Example 2: `Myc_reduce_mice_liver_24m` + +This signature is useful for exercising the edge case where feature names are present but the data may not yet be symbolized. In the original review, this was one of the signatures used to confirm that the wrapper can tolerate non-symbolized feature identifiers. + +```{r, eval=TRUE} +utils::data("Myc_reduce_mice_liver_24m", package = "SigRepo", envir = environment()) + +prepared <- SigRepo::prepareHypeRSignatures( + omic_signature = Myc_reduce_mice_liver_24m, + method = "gsea", + verbose = FALSE +) + +prepared$metadata +``` + +The key point is that the wrapper should not fail just because `feature_name` is present instead of a ready-to-use symbol vector. + +### Example 3: synthetic validation signature with feature mapping fallback + +The wrapper itself was also exercised with a synthetic signature that mimics the real production issue: `feature_name` records are present, but the symbol column is missing and must be resolved from the reference table. + +```{r, eval=FALSE} +# A minimal example of the actual fallback contract +sig <- OmicSignature::OmicSignature$new( + metadata = list( + signature_name = "mapped_symbol_signature", + assay_type = "transcriptomics", + phenotype = "test_phenotype", + organism = "Homo sapiens", + direction_type = "bi-directional", + others = list() + ), + signature = data.frame( + feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), + feature_id = c(101, 102, 103, 104), + group_label = factor(c("treated", "treated", "control", "control")), + stringsAsFactors = FALSE + ), + difexp = data.frame( + feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), + score = c(2.2, -1.8, 2.5, -0.9), + p_value = c(0.01, 0.02, 0.03, 0.04), + group_label = factor(c("treated", "treated", "control", "control")), + stringsAsFactors = FALSE + ) +) + +prepared <- SigRepo::prepareHypeRSignatures( + omic_signature = sig, + method = "gsea", + split_by_group = TRUE, + verbose = FALSE +) + +prepared$signatures +``` + +This shape reflects the production pattern that triggered the fix: the difexp table has feature keys, but the wrapper has to resolve them to gene symbols before handing them to hypeR. + +--- + +## Implementation behavior + +The final client behavior is designed to be conservative and explicit: + +- If `symbol` or `gene_symbol` already exists, use it. +- If the data is feature-based, try to map the feature identifiers to gene symbols from the MySQL reference feature tables. +- If mapping succeeds, continue with the mapped values. +- If mapping fails for some rows, warn and drop only the unmapped entries. +- Do not split by positive/negative direction; split by `group_label` only. + +This keeps the wrapper aligned with both the SigRepo object model and the hypeR input contract while preserving user visibility into any data loss due to mapping. + +--- + +## Practical takeaway + +The HypeR wrapper is now more robust for real-world SigRepo signatures because it handles both of the common production edge cases: + +- multi-group signatures that should not be split by direction +- feature-driven signatures that require symbol resolution before enrichment + +This makes the wrapper more reliable, especially when processing live database signatures that do not perfectly match the symbols expected by the hypeR package. From 4da9638727f5e0ff28ee96a42fc6cac2aa8ca336 Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 14:19:07 -0400 Subject: [PATCH 02/61] feat: getHypeRGenesets with genesets = "msigdb" and a correct MSigDB species mapping Removes the old runHypeR/prepareHypeRSignatures implementation ahead of the hypeR-native rewrite. Co-Authored-By: Claude Sonnet 5 --- NAMESPACE | 4 +- R/hypeRClient.R | 748 --------------------------- R/hypeRGenesets.R | 164 ++++++ R/hyperGEMClient.R | 2 +- man/getHypeRGenesets.Rd | 60 +++ man/prepareHypeRSignatures.Rd | 65 --- man/resolveHypeRGenesets.Rd | 33 -- man/runHypeR.Rd | 124 ----- tests/testthat/test_hypeR_client.R | 391 -------------- tests/testthat/test_hypeR_genesets.R | 110 ++++ 10 files changed, 336 insertions(+), 1365 deletions(-) create mode 100644 R/hypeRGenesets.R create mode 100644 man/getHypeRGenesets.Rd delete mode 100644 man/prepareHypeRSignatures.Rd delete mode 100644 man/resolveHypeRGenesets.Rd delete mode 100644 man/runHypeR.Rd delete mode 100644 tests/testthat/test_hypeR_client.R create mode 100644 tests/testthat/test_hypeR_genesets.R diff --git a/NAMESPACE b/NAMESPACE index 54d0db57..4194ce76 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -51,6 +51,7 @@ export(direction_types) export(getAPIKey) export(getCollection) export(getDBColNames) +export(getHypeRGenesets) export(getNumOfObs) export(getSignature) export(getSignatureFeatureSet) @@ -62,13 +63,10 @@ export(init_handle) export(insert_table_sql) export(lookup_table_sql) export(newConnHandler) -export(prepareHypeRSignatures) export(print_messages) export(protTransform) export(removeDuplicates) export(removeSignatureFromCollection) -export(resolveHypeRGenesets) -export(runHypeR) export(runHyperGEM) export(searchAssayType) export(searchCollection) diff --git a/R/hypeRClient.R b/R/hypeRClient.R index 0b0e9587..bb2a2d33 100644 --- a/R/hypeRClient.R +++ b/R/hypeRClient.R @@ -212,751 +212,3 @@ resolveHypeRSignatureLabels <- function(omic_signatures) { base::make.unique(labels) } - -fetchMsigdbGenesets <- function( - species = "Homo sapiens", - collection = "H", - subcollection = NULL, - clean = FALSE -) { - if (!requireNamespace("msigdbr", quietly = TRUE)) { - base::stop( - "\nPackage 'msigdbr' is required to retrieve MSigDB genesets. Please install it first.\n" - ) - } - - species <- base::as.character(species[[1]]) - collection <- base::as.character(collection[[1]]) - subcollection <- if ( - base::is.null(subcollection) || - base::length(subcollection) == 0 || - base::all(subcollection %in% c("", NA)) - ) { - NULL - } else { - base::as.character(subcollection[[1]]) - } - - call_args <- base::list( - species = species, - collection = collection - ) - if (!base::is.null(subcollection)) { - call_args$subcollection <- subcollection - } - - # Some msigdbr builds support a direct "species = mouse" + "collection = ..." - # query, while others require the ortholog-mapped human database for non-human - # sets. Use the direct human mapping as the safest fallback instead of relying - # on the upstream hypeR wrapper, which has been inconsistent across recent - # releases. - response <- tryCatch( - do.call(msigdbr::msigdbr, call_args), - error = function(e) { - if (!base::identical(species, "Homo sapiens")) { - fallback_args <- call_args - fallback_args$species <- "Homo sapiens" - fallback_args$db_species <- if (base::identical(species, "Mus musculus")) "MM" else "HS" - return(do.call(msigdbr::msigdbr, fallback_args)) - } - stop(e) - } - ) - - if (base::nrow(response) == 0L) { - base::stop( - "\nNo MSigDB genesets were returned for the requested species/collection combination.\n" - ) - } - - mdf <- response[, c("gs_name", "gene_symbol")] - mdf <- stats::na.omit(mdf) - mdf <- unique(mdf) - - gsets <- split(mdf$gene_symbol, mdf$gs_name) - if (isTRUE(clean)) { - names(gsets) <- base::gsub("^HALLMARK_|^KEGG_|^GO_|^CP:|^C[0-9]+\\.", "", names(gsets)) - } - - gsets -} - -#' Resolve genesets for hypeR, including direct MSigDB fetches -#' -#' @description Resolves a named list of genesets directly or retrieves a -#' collection from MSigDB when requested. -#' -#' @param genesets A named list of genesets, a hypeR gsets object, or a hypeR -#' rgsets object. -#' @param msigdb_species Species name for MSigDB lookup. -#' @param msigdb_collection MSigDB collection id. -#' @param msigdb_subcollection Optional MSigDB subcollection id. -#' @param msigdb_clean Logical; whether to simplify geneset names. -#' -#' @return A named list of genesets or a hypeR gsets object. -#' -#' @export -resolveHypeRGenesets <- function( - genesets = NULL, - msigdb_species = NULL, - msigdb_collection = NULL, - msigdb_subcollection = NULL, - msigdb_clean = FALSE -) { - msigdb_requested <- !base::is.null(msigdb_collection) && - base::length(msigdb_collection) > 0 && - !base::all(msigdb_collection %in% c("", NA)) - - if (!base::is.null(genesets) && msigdb_requested) { - base::stop( - "\nSupply either 'genesets' or 'msigdb_collection', but not both.\n" - ) - } - - if (msigdb_requested) { - msigdb_species <- if ( - base::is.null(msigdb_species) || - base::length(msigdb_species) == 0 || - base::all(msigdb_species %in% c("", NA)) - ) { - "Homo sapiens" - } else { - base::as.character(msigdb_species[[1]]) - } - - msigdb_collection <- base::as.character(msigdb_collection[[1]]) - msigdb_subcollection <- if ( - base::is.null(msigdb_subcollection) || - base::length(msigdb_subcollection) == 0 || - base::all(msigdb_subcollection %in% c("", NA)) - ) { - NULL - } else { - base::as.character(msigdb_subcollection[[1]]) - } - - return( - fetchMsigdbGenesets( - species = msigdb_species, - collection = msigdb_collection, - subcollection = msigdb_subcollection, - clean = msigdb_clean - ) - ) - } - - if (base::is.null(genesets)) { - base::stop( - "\nProvide either 'genesets' or specify an MSigDB collection with 'msigdb_collection'.\n" - ) - } - - if ( - methods::is(genesets, "gsets") || - methods::is(genesets, "rgsets") - ) { - return(genesets) - } - - if (!methods::is(genesets, "list") || base::length(genesets) == 0) { - base::stop( - "\n'genesets' must be a non-empty named list, a hypeR gsets object, or a hypeR rgsets object.\n" - ) - } - - if (base::is.null(base::names(genesets)) || base::any(base::names(genesets) %in% c("", NA))) { - base::stop("\n'genesets' must be named.\n") - } - - genesets -} - -resolveHypeRFeatureSymbols <- function( - data_tbl = NULL, - feature_col = "feature_name", - assay_type = NULL, - sig_name = NULL, - conn_handler = NULL, - verbose = TRUE -) { - if (base::is.null(data_tbl) || !methods::is(data_tbl, "data.frame") || base::nrow(data_tbl) == 0) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - symbol_like <- c("symbol", "gene_symbol", "gene", "gene_name") - existing_symbol <- symbol_like[symbol_like %in% base::colnames(data_tbl)] - if (base::length(existing_symbol) > 0) { - return(list( - data = data_tbl, - feature_col = existing_symbol[[1]], - n_dropped = 0L, - mapped = FALSE - )) - } - - if (!feature_col %in% base::colnames(data_tbl)) { - fallback_cols <- c("feature_name", "feature_id", "probe_id", "probe", "feature") - fallback_cols <- fallback_cols[fallback_cols %in% base::colnames(data_tbl)] - if (base::length(fallback_cols) == 0L) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - feature_col <- fallback_cols[[1]] - } - - if (feature_col %in% c("symbol", "gene_symbol", "gene", "gene_name")) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - ref_lookup <- switch( - base::tolower(base::as.character(assay_type)), - transcriptomics = "transcriptomics_features", - proteomics = "proteomics_features", - genetic_variants = "genetic_variants_features", - NULL - ) - - if (base::is.null(ref_lookup) || base::is.null(conn_handler)) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - feature_values <- base::as.character(data_tbl[[feature_col]]) - valid_idx <- !base::is.na(feature_values) & nzchar(feature_values) - if (!base::any(valid_idx)) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - mapped_tbl <- tryCatch( - SigRepo::lookup_table_sql( - conn = SigRepo::conn_init(conn_handler), - db_table_name = ref_lookup, - return_var = c("feature_name", "gene_symbol"), - filter_coln_var = "feature_name", - filter_coln_val = base::list("feature_name" = base::unique(feature_values[valid_idx])), - check_db_table = TRUE - ), - error = function(e) NULL - ) - - if (base::is.null(mapped_tbl) || base::nrow(mapped_tbl) == 0) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - mapped_tbl <- mapped_tbl[ - !base::is.na(mapped_tbl$feature_name) & nzchar(mapped_tbl$feature_name) & - !base::is.na(mapped_tbl$gene_symbol) & nzchar(mapped_tbl$gene_symbol), - , - drop = FALSE - ] - - if (base::nrow(mapped_tbl) == 0) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - symbol_map <- stats::setNames( - base::as.character(mapped_tbl$gene_symbol), - base::as.character(mapped_tbl$feature_name) - ) - - matched_idx <- valid_idx & feature_values %in% base::names(symbol_map) - mapped_values <- symbol_map[feature_values[matched_idx]] - - if (base::sum(valid_idx) == 0 || base::sum(matched_idx) == 0) { - return(list(data = data_tbl, feature_col = feature_col, n_dropped = 0L, mapped = FALSE)) - } - - dropped_count <- base::sum(valid_idx) - base::sum(matched_idx) - if (dropped_count > 0L) { - base::warning( - base::sprintf( - "Signature '%s' used reference MySQL feature mapping to resolve %s to gene symbols; %s row(s) were dropped because they could not be mapped.", - if (is.null(sig_name) || !nzchar(sig_name)) "hypeR_input" else sig_name, - feature_col, - dropped_count - ), - call. = FALSE - ) - } - - out_tbl <- data_tbl[matched_idx, , drop = FALSE] - out_tbl$symbol <- unname(mapped_values) - - list( - data = out_tbl, - feature_col = "symbol", - n_dropped = dropped_count, - mapped = TRUE - ) -} - -#' Build hypeR-ready signature vectors from SigRepo signatures -#' -#' @description Converts one or more SigRepo signatures into the query-vector -#' format expected by \code{hypeR::hypeR()}. This helper can resolve signatures -#' directly from the SigRepo database, so users do not need to call -#' \code{getSignature()} manually first. -#' -#' @param conn_handler An R object obtained from \code{SigRepo::newConnHandler()}. -#' Required unless \code{omic_signature} is supplied. -#' @param signature_id One or more SigRepo signature IDs. -#' @param signature_name One or more SigRepo signature names. -#' @param omic_signature A single \code{OmicSignature} object or a list of -#' \code{OmicSignature} objects. -#' @param method One of \code{"hypergeo"}, \code{"kstest"}, or \code{"gsea"}. -#' Hypergeometric enrichment uses the \code{signature} table. KS/GSEA-style -#' enrichment use ranked scores from \code{difexp}. -#' @param feature_col Column containing feature identifiers. Defaults to -#' \code{"feature_name"}. -#' @param score_col Column containing ranked scores for KS/GSEA-style enrichment. -#' Defaults to \code{"score"}. -#' @param split_by_group Logical; whether to create separate query vectors for -#' each \code{group_label}. Defaults to \code{FALSE}. -#' @param split_by_direction Logical; retained for compatibility with other -#' SigRepo wrappers, but ignored by the hypeR wrapper because HypeR queries are -#' prepared as one feature vector per group label and should not be further -#' split by positive/negative direction. Defaults to \code{FALSE}. -#' @param verbose Logical; whether or not to print diagnostic messages while -#' retrieving signatures. Defaults to \code{TRUE}. -#' -#' @return A list with three elements: -#' \describe{ -#' \item{\code{signatures}}{A named list of query vectors for \code{hypeR}.} -#' \item{\code{metadata}}{A data frame describing each generated query vector.} -#' \item{\code{omic_signatures}}{The resolved \code{OmicSignature} objects.} -#' } -#' -#' @export -prepareHypeRSignatures <- function( - conn_handler = NULL, - signature_id = NULL, - signature_name = NULL, - omic_signature = NULL, - method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), - feature_col = "feature_name", - score_col = "score", - split_by_group = FALSE, - split_by_direction = FALSE, - verbose = TRUE -){ - - method <- base::match.arg(method, choices = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea")) - if (identical(method, "hypergeo") || identical(method, "hypergeometric")) { - method <- "hypergeometric" - } else if (identical(method, "ks") || identical(method, "kstest")) { - method <- "kstest" - } - - if (isTRUE(split_by_direction)) { - base::warning( - "split_by_direction is ignored by SigRepo::prepareHypeRSignatures(); hypeR queries are split by group_label only.", - call. = FALSE - ) - } - split_by_direction <- FALSE - - omic_signatures <- resolveHypeRSignatures( - conn_handler = conn_handler, - signature_id = signature_id, - signature_name = signature_name, - omic_signature = omic_signature, - verbose = verbose - ) - signature_labels <- resolveHypeRSignatureLabels(omic_signatures) - - build_group_component <- function(group_label, suffix = NULL) { - clean_group <- if (base::is.null(group_label) || base::is.na(group_label) || !base::nzchar(group_label)) { - "all_features" - } else { - base::gsub("[^A-Za-z0-9]+", "_", base::tolower(base::as.character(group_label))) - } - - if (base::is.null(suffix) || !base::nzchar(suffix)) { - return(clean_group) - } - - base::paste0(clean_group, "_", suffix) - } - - vectors <- base::list() - metadata <- base::list() - metadata_idx <- 0 - - for (sig_idx in base::seq_along(omic_signatures)) { - sig_obj <- omic_signatures[[sig_idx]] - sig_name <- signature_labels[[sig_idx]] - - if (identical(method, "hypergeometric")) { - signature_tbl <- sig_obj$signature - - if (!methods::is(signature_tbl, "data.frame") || base::nrow(signature_tbl) == 0) { - base::stop( - base::sprintf("\nSignature '%s' does not contain a non-empty 'signature' table.\n", sig_name) - ) - } - - if (!feature_col %in% base::colnames(signature_tbl) || - feature_col %in% c("feature_name", "feature_id", "probe_id", "probe", "feature")) { - resolved_features <- resolveHypeRFeatureSymbols( - data_tbl = signature_tbl, - feature_col = feature_col, - assay_type = sig_obj$metadata$assay_type[1], - sig_name = sig_name, - conn_handler = conn_handler, - verbose = verbose - ) - if (resolved_features$mapped) { - signature_tbl <- resolved_features$data - feature_col <- resolved_features$feature_col - } else if (!feature_col %in% base::colnames(signature_tbl)) { - base::stop( - base::sprintf("\nSignature '%s' is missing feature column '%s' in 'signature'.\n", sig_name, feature_col) - ) - } - } - - if (split_by_group && "group_label" %in% base::colnames(signature_tbl)) { - signature_tbl$group_label <- base::as.character(signature_tbl$group_label) - } else { - signature_tbl$group_label <- "all_features" - } - - for (group_label in base::unique(signature_tbl$group_label)) { - group_tbl <- signature_tbl[signature_tbl$group_label == group_label, , drop = FALSE] - - query_features <- base::unique(base::as.character(group_tbl[[feature_col]])) - query_features <- query_features[!base::is.na(query_features) & query_features != ""] - if (base::length(query_features) == 0) { - next - } - - component <- build_group_component(group_label) - query_name <- if (identical(component, "all_features")) sig_name else base::sprintf("%s | %s", sig_name, component) - vectors[[query_name]] <- query_features - - metadata_idx <- metadata_idx + 1 - metadata[[metadata_idx]] <- base::data.frame( - query_name = query_name, - signature_name = sig_name, - method = method, - group_label = component, - n_features = base::length(query_features), - stringsAsFactors = FALSE - ) - } - } else { - difexp_tbl <- sig_obj$difexp - - if (!methods::is(difexp_tbl, "data.frame") || base::nrow(difexp_tbl) == 0) { - base::stop( - base::sprintf( - "\nSignature '%s' does not contain a non-empty 'difexp' table, which is required for '%s'.\n", - sig_name, - method - ) - ) - } - - if (feature_col %in% c("feature_name", "feature_id", "probe_id", "probe", "feature") || - !feature_col %in% base::colnames(difexp_tbl)) { - resolved_features <- resolveHypeRFeatureSymbols( - data_tbl = difexp_tbl, - feature_col = feature_col, - assay_type = sig_obj$metadata$assay_type[1], - sig_name = sig_name, - conn_handler = conn_handler, - verbose = verbose - ) - if (resolved_features$mapped) { - difexp_tbl <- resolved_features$data - feature_col <- resolved_features$feature_col - } else if (!feature_col %in% base::colnames(difexp_tbl)) { - missing_cols <- base::setdiff(c(feature_col, score_col), base::colnames(difexp_tbl)) - if (base::length(missing_cols) > 0) { - base::stop( - base::sprintf( - "\nSignature '%s' is missing required difexp column(s): %s.\n", - sig_name, - base::paste0(missing_cols, collapse = ", ") - ) - ) - } - } - } - - missing_cols <- base::setdiff(c(feature_col, score_col), base::colnames(difexp_tbl)) - if (base::length(missing_cols) > 0) { - base::stop( - base::sprintf( - "\nSignature '%s' is missing required difexp column(s): %s.\n", - sig_name, - base::paste0(missing_cols, collapse = ", ") - ) - ) - } - - if (split_by_group && "group_label" %in% base::colnames(difexp_tbl)) { - difexp_tbl$group_label <- base::as.character(difexp_tbl$group_label) - } else { - difexp_tbl$group_label <- "all_features" - } - - difexp_tbl$feature_value <- base::as.character(difexp_tbl[[feature_col]]) - difexp_tbl$score_value <- base::suppressWarnings(base::as.numeric(difexp_tbl[[score_col]])) - difexp_tbl <- difexp_tbl[ - !base::is.na(difexp_tbl$feature_value) & difexp_tbl$feature_value != "" & - !base::is.na(difexp_tbl$score_value), - , - drop = FALSE - ] - - for (group_label in base::unique(difexp_tbl$group_label)) { - group_tbl <- difexp_tbl[difexp_tbl$group_label == group_label, , drop = FALSE] - if (base::nrow(group_tbl) == 0) { - next - } - - ranked_tbl <- group_tbl |> - dplyr::group_by(.data$feature_value) |> - dplyr::summarise( - score_value = .data$score_value[base::which.max(base::abs(.data$score_value))], - .groups = "drop" - ) |> - dplyr::arrange(dplyr::desc(.data$score_value)) - - ranked_vector <- stats::setNames(ranked_tbl$score_value, ranked_tbl$feature_value) - if (base::length(ranked_vector) == 0) { - next - } - - component <- build_group_component(group_label) - query_name <- if (identical(component, "all_features")) sig_name else base::sprintf("%s | %s", sig_name, component) - vectors[[query_name]] <- ranked_vector - - metadata_idx <- metadata_idx + 1 - metadata[[metadata_idx]] <- base::data.frame( - query_name = query_name, - signature_name = sig_name, - method = method, - group_label = component, - n_features = base::length(ranked_vector), - stringsAsFactors = FALSE - ) - } - } - } - - if (base::length(vectors) == 0) { - base::stop( - base::sprintf( - "\nNo valid signatures were available to prepare '%s' enrichment inputs.\n", - method - ) - ) - } - - metadata_df <- if (metadata_idx > 0) { - dplyr::bind_rows(metadata) - } else { - base::data.frame( - query_name = character(), - signature_name = character(), - method = character(), - group_label = character(), - n_features = numeric(), - stringsAsFactors = FALSE - ) - } - - base::list( - signatures = vectors, - metadata = metadata_df, - omic_signatures = omic_signatures - ) -} - -#' Run hypeR enrichment directly from SigRepo signatures -#' -#' @description Resolves one or more signatures from SigRepo and runs -#' \code{hypeR::hypeR()} on them without requiring the user to call -#' \code{getSignature()} manually first. -#' -#' @param conn_handler An R object obtained from \code{SigRepo::newConnHandler()}. -#' Required unless \code{omic_signature} is supplied. -#' @param signature_id One or more SigRepo signature IDs. -#' @param signature_name One or more SigRepo signature names. -#' @param omic_signature A single \code{OmicSignature} object or a list of -#' \code{OmicSignature} objects. -#' @param genesets A named list of genesets, a \code{hypeR} \code{gsets} -#' object, or a \code{hypeR} \code{rgsets} object supplied to \code{hypeR}. -#' Alternatively, leave this as \code{NULL} and specify -#' \code{msigdb_collection} to fetch genesets from MSigDB automatically. -#' @param msigdb_species Species passed to \code{hypeR::msigdb_gsets()} when -#' \code{msigdb_collection} is supplied. Defaults to \code{"Homo sapiens"}. -#' @param msigdb_collection MSigDB collection identifier, such as \code{"H"} -#' or \code{"C2"}. When supplied, \code{runHypeR()} retrieves genesets -#' automatically via \code{hypeR::msigdb_gsets()}. -#' @param msigdb_subcollection Optional MSigDB subcollection identifier, such as -#' \code{"CP:KEGG_LEGACY"}. -#' @param msigdb_clean Logical; whether to clean MSigDB geneset labels using -#' \code{hypeR::msigdb_gsets(clean = ...)}. Defaults to \code{FALSE}. -#' @param method One of \code{"hypergeo"}, \code{"kstest"}, or \code{"gsea"}. -#' @param feature_col Column containing feature identifiers. Defaults to -#' \code{"feature_name"}. -#' @param score_col Column containing ranked scores for KS/GSEA-style enrichment. -#' Defaults to \code{"score"}. -#' @param split_by_group Logical; whether to create separate query vectors for -#' each \code{group_label}. Defaults to \code{FALSE}. -#' @param split_by_direction Logical; retained for backward compatibility, but -#' ignored by the wrapper because HypeR signatures should be split only by -#' \code{group_label}, not by positive/negative direction. Defaults to -#' \code{FALSE}. -#' @param background Optional background size passed to \code{hypeR}. -#' @param fdr FDR threshold passed to \code{hypeR}. Defaults to \code{0.05}. -#' @param plotting Logical; whether to let \code{hypeR} generate plots. -#' Defaults to \code{FALSE}. -#' @param quiet Logical; whether to suppress \code{hypeR} messages. -#' Defaults to \code{TRUE}. -#' @param absolute Passed to \code{hypeR} for GSEA-style ranked enrichment. -#' Defaults to \code{FALSE}. -#' @param power Passed to \code{hypeR} for GSEA-style ranked enrichment. -#' Defaults to \code{1}. -#' @param ... Additional arguments passed directly to \code{hypeR::hypeR()}. -#' Use this for extra tuning parameters such as \code{background} or other -#' engine-specific options. -#' @param verbose Logical; whether or not to print diagnostic messages while -#' retrieving signatures. Defaults to \code{TRUE}. -#' -#' @return A list with: -#' \describe{ -#' \item{\code{result}}{A \code{hyp} or \code{multihyp} object returned by \code{hypeR}.} -#' \item{\code{signatures}}{The query vectors passed into \code{hypeR}.} -#' \item{\code{metadata}}{A data frame describing each query vector.} -#' } -#' -#' @examples -#' \dontrun{ -#' hyp_res <- SigRepo::runHypeR( -#' conn_handler = conn_handler, -#' signature_name = "example_signature", -#' msigdb_collection = "H", -#' method = "hypergeo", -#' background = 20000 -#' ) -#' } -#' -#' @export -runHypeR <- function( - conn_handler = NULL, - signature_id = NULL, - signature_name = NULL, - omic_signature = NULL, - genesets = NULL, - msigdb_species = "Homo sapiens", - msigdb_collection = NULL, - msigdb_subcollection = NULL, - msigdb_clean = FALSE, - method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), - feature_col = "feature_name", - score_col = "score", - split_by_group = FALSE, - split_by_direction = FALSE, - background = NULL, - fdr = 0.05, - plotting = FALSE, - quiet = TRUE, - absolute = FALSE, - power = 1, - ..., - verbose = TRUE -){ - - if (!requireNamespace("hypeR", quietly = TRUE)) { - base::stop( - "\nPackage 'hypeR' is required for runHypeR(). Please install it first.\n" - ) - } - - method <- base::match.arg(method, choices = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea")) - if (identical(method, "hypergeo") || identical(method, "hypergeometric")) { - method <- "hypergeometric" - } else if (identical(method, "ks") || identical(method, "kstest")) { - method <- "kstest" - } - if (isTRUE(split_by_direction)) { - base::warning( - "split_by_direction is ignored by SigRepo::runHypeR(); hypeR queries are split by group_label only.", - call. = FALSE - ) - } - split_by_direction <- FALSE - hype_test <- if (identical(method, "hypergeometric")) "hypergeometric" else "ks" - extra_args <- base::list(...) - resolved_genesets <- resolveHypeRGenesets( - genesets = genesets, - msigdb_species = msigdb_species, - msigdb_collection = msigdb_collection, - msigdb_subcollection = msigdb_subcollection, - msigdb_clean = msigdb_clean - ) - - reserved_args <- c("signature", "genesets", "test") - duplicate_reserved <- base::intersect(base::names(extra_args), reserved_args) - if (base::length(duplicate_reserved) > 0) { - base::stop( - base::sprintf( - "\nThe following hypeR arguments are handled internally by runHypeR() and cannot be supplied in '...': %s.\n", - base::paste0(duplicate_reserved, collapse = ", ") - ) - ) - } - - enrichment_inputs <- prepareHypeRSignatures( - conn_handler = conn_handler, - signature_id = signature_id, - signature_name = signature_name, - omic_signature = omic_signature, - method = method, - feature_col = feature_col, - score_col = score_col, - split_by_group = split_by_group, - split_by_direction = split_by_direction, - verbose = verbose - ) - - signature_vectors <- enrichment_inputs$signatures - - hype_signature <- if (base::length(signature_vectors) == 1) { - signature_vectors[[1]] - } else { - signature_vectors - } - - hype_args <- base::list( - signature = hype_signature, - genesets = resolved_genesets, - test = hype_test, - fdr = fdr, - plotting = plotting, - quiet = quiet - ) - - if (!base::is.null(background)) { - hype_args$background <- background - } - - if (identical(method, "gsea")) { - hype_args$absolute <- absolute - hype_args$power <- power - } - - if (base::length(extra_args) > 0) { - hype_args[base::names(extra_args)] <- extra_args - } - - hyp_result <- do.call(hypeR::hypeR, hype_args) - - base::list( - result = hyp_result, - signatures = signature_vectors, - metadata = enrichment_inputs$metadata - ) -} diff --git a/R/hypeRGenesets.R b/R/hypeRGenesets.R new file mode 100644 index 00000000..363d9314 --- /dev/null +++ b/R/hypeRGenesets.R @@ -0,0 +1,164 @@ +#' MSigDB database for a species/collection pair +#' +#' Mouse-native collections (MH, M1-M8) live in the mouse database. Every other +#' request -- human, mouse against a human collection such as C2 or C5, or any +#' other species -- uses the human database, which msigdbr maps to orthologs. +#' hypeR::msigdb_download() gets both cases wrong: it always uses "MM" for mouse +#' and has a `db_species == "HS"` typo for other species. +#' +#' @noRd +msigdbDbSpecies <- function(species, collection) { + species <- base::tolower(base::trimws(base::as.character(species[[1]]))) + collection <- base::toupper(base::trimws(base::as.character(collection[[1]]))) + + if (base::identical(species, "mus musculus") && base::grepl("^M(H|[0-9]+)$", collection)) { + return("MM") + } + + "HS" +} + +#' Thin wrapper so tests can replace the msigdbr call +#' @noRd +callMsigdbr <- function(args) { + base::do.call(msigdbr::msigdbr, args) +} + +#' Fetch an MSigDB collection as a hypeR gsets object +#' @noRd +fetchMsigdbGsets <- function(species, collection, subcollection = NULL, clean = FALSE) { + for (pkg in c("msigdbr", "hypeR")) { + if (!base::requireNamespace(pkg, quietly = TRUE)) { + base::stop(base::sprintf("\nPackage '%s' is required when genesets = \"msigdb\". Please install it first.\n", pkg)) + } + } + + args <- base::list( + species = species, + db_species = msigdbDbSpecies(species, collection), + collection = collection + ) + if (!base::is.null(subcollection)) { + args$subcollection <- subcollection + } + + response <- callMsigdbr(args) + + if (base::nrow(response) == 0L) { + base::stop(base::sprintf( + "\nMSigDB returned no genesets for species = '%s', collection = '%s'%s. See msigdbr::msigdbr_collections() for valid combinations.\n", + species, + collection, + if (base::is.null(subcollection)) "" else base::sprintf(", subcollection = '%s'", subcollection) + )) + } + + mdf <- base::unique(base::as.data.frame(response)[, c("gs_name", "gene_symbol")]) + mdf <- mdf[!base::is.na(mdf$gene_symbol) & base::nzchar(mdf$gene_symbol), , drop = FALSE] + genesets <- base::split(mdf$gene_symbol, mdf$gs_name) + + hypeR::gsets$new( + genesets, + name = if (base::is.null(subcollection)) collection else base::paste(collection, subcollection, sep = "."), + version = base::paste0("v", base::as.character(utils::packageVersion("msigdbr"))), + clean = clean, + quiet = TRUE + ) +} + +genesetsFormError <- function() { + "\n'genesets' must be \"msigdb\" (with msigdb_collection) or your own genesets: a named list, hypeR::gsets or hypeR::rgsets object.\n" +} + +#' Resolve genesets for hypeR +#' +#' @description Returns genesets in a form \code{hypeR::hypeR()} accepts. Pass +#' \code{genesets = "msigdb"} with \code{msigdb_collection} (and optionally +#' \code{msigdb_species}, \code{msigdb_subcollection}) to fetch an MSigDB +#' collection, or pass your own genesets object. +#' +#' @param genesets Either the string \code{"msigdb"}, or your own genesets: a +#' named list of character vectors, a \code{hypeR::gsets} object, or a +#' \code{hypeR::rgsets} object. +#' @param msigdb_species Species for MSigDB, e.g. \code{"Homo sapiens"} or +#' \code{"Mus musculus"}. Defaults to \code{"Homo sapiens"}. Only valid with +#' \code{genesets = "msigdb"}. +#' @param msigdb_collection MSigDB collection, e.g. \code{"H"}, \code{"C2"}, +#' \code{"MH"}. Required with \code{genesets = "msigdb"}. +#' @param msigdb_subcollection Optional MSigDB subcollection, e.g. +#' \code{"CP:REACTOME"}. Only valid with \code{genesets = "msigdb"}. +#' @param msigdb_clean Logical; clean geneset labels via +#' \code{hypeR::gsets$new(clean = TRUE)}. Defaults to \code{FALSE}. +#' +#' @return For \code{"msigdb"}, a \code{hypeR::gsets} object named after the +#' collection (e.g. \code{"C2.CP:REACTOME"}) and versioned by msigdbr. Otherwise +#' the supplied genesets, unchanged. +#' +#' @details Mouse-native collections (\code{MH}, \code{M1}-\code{M8}) use the +#' mouse MSigDB database; mouse requests for human collections and all other +#' species use the human database with ortholog mapping. +#' +#' @examples +#' \dontrun{ +#' hallmark <- SigRepo::getHypeRGenesets("msigdb", msigdb_collection = "H") +#' reactome_mouse <- SigRepo::getHypeRGenesets( +#' "msigdb", +#' msigdb_species = "Mus musculus", +#' msigdb_collection = "C2", +#' msigdb_subcollection = "CP:REACTOME" +#' ) +#' } +#' +#' @export +getHypeRGenesets <- function( + genesets, + msigdb_species = NULL, + msigdb_collection = NULL, + msigdb_subcollection = NULL, + msigdb_clean = FALSE +) { + if (base::missing(genesets) || base::is.null(genesets)) { + base::stop(genesetsFormError()) + } + + if (base::is.character(genesets)) { + if (!(base::length(genesets) == 1L && base::identical(genesets, "msigdb"))) { + base::stop(genesetsFormError()) + } + + if (base::is.null(msigdb_collection) || base::length(msigdb_collection) != 1L || + base::is.na(msigdb_collection) || !base::nzchar(msigdb_collection)) { + base::stop("\ngenesets = \"msigdb\" requires 'msigdb_collection' (e.g. \"H\", \"C2\", \"MH\").\n") + } + + return(fetchMsigdbGsets( + species = if (base::is.null(msigdb_species)) "Homo sapiens" else msigdb_species, + collection = msigdb_collection, + subcollection = msigdb_subcollection, + clean = msigdb_clean + )) + } + + msigdb_supplied <- c( + msigdb_species = !base::is.null(msigdb_species), + msigdb_collection = !base::is.null(msigdb_collection), + msigdb_subcollection = !base::is.null(msigdb_subcollection) + ) + if (base::any(msigdb_supplied)) { + base::stop(base::sprintf( + "\n%s only apply when genesets = \"msigdb\".\n", + base::paste(base::names(msigdb_supplied)[msigdb_supplied], collapse = ", ") + )) + } + + if (methods::is(genesets, "gsets") || methods::is(genesets, "rgsets")) { + return(genesets) + } + + if (methods::is(genesets, "list") && base::length(genesets) > 0 && + !base::is.null(base::names(genesets)) && !base::any(base::names(genesets) %in% c("", NA))) { + return(genesets) + } + + base::stop(genesetsFormError()) +} diff --git a/R/hyperGEMClient.R b/R/hyperGEMClient.R index 77e01ca4..2c40eb02 100644 --- a/R/hyperGEMClient.R +++ b/R/hyperGEMClient.R @@ -308,7 +308,7 @@ runHyperGEM <- function( ) } - resolved_genesets <- resolveHypeRGenesets(genesets = genesets) + resolved_genesets <- getHypeRGenesets(genesets = genesets) method <- base::match.arg(method) enrichment_inputs <- prepareHyperGEMSignatures( diff --git a/man/getHypeRGenesets.Rd b/man/getHypeRGenesets.Rd new file mode 100644 index 00000000..f538a2c5 --- /dev/null +++ b/man/getHypeRGenesets.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypeRGenesets.R +\name{getHypeRGenesets} +\alias{getHypeRGenesets} +\title{Resolve genesets for hypeR} +\usage{ +getHypeRGenesets( + genesets, + msigdb_species = NULL, + msigdb_collection = NULL, + msigdb_subcollection = NULL, + msigdb_clean = FALSE +) +} +\arguments{ +\item{genesets}{Either the string \code{"msigdb"}, or your own genesets: a +named list of character vectors, a \code{hypeR::gsets} object, or a +\code{hypeR::rgsets} object.} + +\item{msigdb_species}{Species for MSigDB, e.g. \code{"Homo sapiens"} or +\code{"Mus musculus"}. Defaults to \code{"Homo sapiens"}. Only valid with +\code{genesets = "msigdb"}.} + +\item{msigdb_collection}{MSigDB collection, e.g. \code{"H"}, \code{"C2"}, +\code{"MH"}. Required with \code{genesets = "msigdb"}.} + +\item{msigdb_subcollection}{Optional MSigDB subcollection, e.g. +\code{"CP:REACTOME"}. Only valid with \code{genesets = "msigdb"}.} + +\item{msigdb_clean}{Logical; clean geneset labels via +\code{hypeR::gsets$new(clean = TRUE)}. Defaults to \code{FALSE}.} +} +\value{ +For \code{"msigdb"}, a \code{hypeR::gsets} object named after the +collection (e.g. \code{"C2.CP:REACTOME"}) and versioned by msigdbr. Otherwise +the supplied genesets, unchanged. +} +\description{ +Returns genesets in a form \code{hypeR::hypeR()} accepts. Pass +\code{genesets = "msigdb"} with \code{msigdb_collection} (and optionally +\code{msigdb_species}, \code{msigdb_subcollection}) to fetch an MSigDB +collection, or pass your own genesets object. +} +\details{ +Mouse-native collections (\code{MH}, \code{M1}-\code{M8}) use the +mouse MSigDB database; mouse requests for human collections and all other +species use the human database with ortholog mapping. +} +\examples{ +\dontrun{ +hallmark <- SigRepo::getHypeRGenesets("msigdb", msigdb_collection = "H") +reactome_mouse <- SigRepo::getHypeRGenesets( + "msigdb", + msigdb_species = "Mus musculus", + msigdb_collection = "C2", + msigdb_subcollection = "CP:REACTOME" +) +} + +} diff --git a/man/prepareHypeRSignatures.Rd b/man/prepareHypeRSignatures.Rd deleted file mode 100644 index 02b8193f..00000000 --- a/man/prepareHypeRSignatures.Rd +++ /dev/null @@ -1,65 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypeRClient.R -\name{prepareHypeRSignatures} -\alias{prepareHypeRSignatures} -\title{Build hypeR-ready signature vectors from SigRepo signatures} -\usage{ -prepareHypeRSignatures( - conn_handler = NULL, - signature_id = NULL, - signature_name = NULL, - omic_signature = NULL, - method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), - feature_col = "feature_name", - score_col = "score", - split_by_group = FALSE, - split_by_direction = FALSE, - verbose = TRUE -) -} -\arguments{ -\item{conn_handler}{An R object obtained from \code{SigRepo::newConnHandler()}. -Required unless \code{omic_signature} is supplied.} - -\item{signature_id}{One or more SigRepo signature IDs.} - -\item{signature_name}{One or more SigRepo signature names.} - -\item{omic_signature}{A single \code{OmicSignature} object or a list of -\code{OmicSignature} objects.} - -\item{method}{One of \code{"hypergeo"}, \code{"kstest"}, or \code{"gsea"}. -Hypergeometric enrichment uses the \code{signature} table. KS/GSEA-style -enrichment use ranked scores from \code{difexp}.} - -\item{feature_col}{Column containing feature identifiers. Defaults to -\code{"feature_name"}.} - -\item{score_col}{Column containing ranked scores for KS/GSEA-style enrichment. -Defaults to \code{"score"}.} - -\item{split_by_group}{Logical; whether to create separate query vectors for -each \code{group_label}. Defaults to \code{FALSE}.} - -\item{split_by_direction}{Logical; retained for compatibility with other -SigRepo wrappers, but ignored by the hypeR wrapper because HypeR queries are -prepared as one feature vector per group label and should not be further -split by positive/negative direction. Defaults to \code{FALSE}.} - -\item{verbose}{Logical; whether or not to print diagnostic messages while -retrieving signatures. Defaults to \code{TRUE}.} -} -\value{ -A list with three elements: -\describe{ - \item{\code{signatures}}{A named list of query vectors for \code{hypeR}.} - \item{\code{metadata}}{A data frame describing each generated query vector.} - \item{\code{omic_signatures}}{The resolved \code{OmicSignature} objects.} -} -} -\description{ -Converts one or more SigRepo signatures into the query-vector -format expected by \code{hypeR::hypeR()}. This helper can resolve signatures -directly from the SigRepo database, so users do not need to call -\code{getSignature()} manually first. -} diff --git a/man/resolveHypeRGenesets.Rd b/man/resolveHypeRGenesets.Rd deleted file mode 100644 index 4b3aeb38..00000000 --- a/man/resolveHypeRGenesets.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypeRClient.R -\name{resolveHypeRGenesets} -\alias{resolveHypeRGenesets} -\title{Resolve genesets for hypeR, including direct MSigDB fetches} -\usage{ -resolveHypeRGenesets( - genesets = NULL, - msigdb_species = NULL, - msigdb_collection = NULL, - msigdb_subcollection = NULL, - msigdb_clean = FALSE -) -} -\arguments{ -\item{genesets}{A named list of genesets, a hypeR gsets object, or a hypeR -rgsets object.} - -\item{msigdb_species}{Species name for MSigDB lookup.} - -\item{msigdb_collection}{MSigDB collection id.} - -\item{msigdb_subcollection}{Optional MSigDB subcollection id.} - -\item{msigdb_clean}{Logical; whether to simplify geneset names.} -} -\value{ -A named list of genesets or a hypeR gsets object. -} -\description{ -Resolves a named list of genesets directly or retrieves a -collection from MSigDB when requested. -} diff --git a/man/runHypeR.Rd b/man/runHypeR.Rd deleted file mode 100644 index 6614f6d2..00000000 --- a/man/runHypeR.Rd +++ /dev/null @@ -1,124 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypeRClient.R -\name{runHypeR} -\alias{runHypeR} -\title{Run hypeR enrichment directly from SigRepo signatures} -\usage{ -runHypeR( - conn_handler = NULL, - signature_id = NULL, - signature_name = NULL, - omic_signature = NULL, - genesets = NULL, - msigdb_species = "Homo sapiens", - msigdb_collection = NULL, - msigdb_subcollection = NULL, - msigdb_clean = FALSE, - method = c("hypergeo", "hypergeometric", "kstest", "ks", "gsea"), - feature_col = "feature_name", - score_col = "score", - split_by_group = FALSE, - split_by_direction = FALSE, - background = NULL, - fdr = 0.05, - plotting = FALSE, - quiet = TRUE, - absolute = FALSE, - power = 1, - ..., - verbose = TRUE -) -} -\arguments{ -\item{conn_handler}{An R object obtained from \code{SigRepo::newConnHandler()}. -Required unless \code{omic_signature} is supplied.} - -\item{signature_id}{One or more SigRepo signature IDs.} - -\item{signature_name}{One or more SigRepo signature names.} - -\item{omic_signature}{A single \code{OmicSignature} object or a list of -\code{OmicSignature} objects.} - -\item{genesets}{A named list of genesets, a \code{hypeR} \code{gsets} -object, or a \code{hypeR} \code{rgsets} object supplied to \code{hypeR}. -Alternatively, leave this as \code{NULL} and specify -\code{msigdb_collection} to fetch genesets from MSigDB automatically.} - -\item{msigdb_species}{Species passed to \code{hypeR::msigdb_gsets()} when -\code{msigdb_collection} is supplied. Defaults to \code{"Homo sapiens"}.} - -\item{msigdb_collection}{MSigDB collection identifier, such as \code{"H"} -or \code{"C2"}. When supplied, \code{runHypeR()} retrieves genesets -automatically via \code{hypeR::msigdb_gsets()}.} - -\item{msigdb_subcollection}{Optional MSigDB subcollection identifier, such as -\code{"CP:KEGG_LEGACY"}.} - -\item{msigdb_clean}{Logical; whether to clean MSigDB geneset labels using -\code{hypeR::msigdb_gsets(clean = ...)}. Defaults to \code{FALSE}.} - -\item{method}{One of \code{"hypergeo"}, \code{"kstest"}, or \code{"gsea"}.} - -\item{feature_col}{Column containing feature identifiers. Defaults to -\code{"feature_name"}.} - -\item{score_col}{Column containing ranked scores for KS/GSEA-style enrichment. -Defaults to \code{"score"}.} - -\item{split_by_group}{Logical; whether to create separate query vectors for -each \code{group_label}. Defaults to \code{FALSE}.} - -\item{split_by_direction}{Logical; retained for backward compatibility, but -ignored by the wrapper because HypeR signatures should be split only by -\code{group_label}, not by positive/negative direction. Defaults to -\code{FALSE}.} - -\item{background}{Optional background size passed to \code{hypeR}.} - -\item{fdr}{FDR threshold passed to \code{hypeR}. Defaults to \code{0.05}.} - -\item{plotting}{Logical; whether to let \code{hypeR} generate plots. -Defaults to \code{FALSE}.} - -\item{quiet}{Logical; whether to suppress \code{hypeR} messages. -Defaults to \code{TRUE}.} - -\item{absolute}{Passed to \code{hypeR} for GSEA-style ranked enrichment. -Defaults to \code{FALSE}.} - -\item{power}{Passed to \code{hypeR} for GSEA-style ranked enrichment. -Defaults to \code{1}.} - -\item{...}{Additional arguments passed directly to \code{hypeR::hypeR()}. -Use this for extra tuning parameters such as \code{background} or other -engine-specific options.} - -\item{verbose}{Logical; whether or not to print diagnostic messages while -retrieving signatures. Defaults to \code{TRUE}.} -} -\value{ -A list with: -\describe{ - \item{\code{result}}{A \code{hyp} or \code{multihyp} object returned by \code{hypeR}.} - \item{\code{signatures}}{The query vectors passed into \code{hypeR}.} - \item{\code{metadata}}{A data frame describing each query vector.} -} -} -\description{ -Resolves one or more signatures from SigRepo and runs -\code{hypeR::hypeR()} on them without requiring the user to call -\code{getSignature()} manually first. -} -\examples{ -\dontrun{ -hyp_res <- SigRepo::runHypeR( - conn_handler = conn_handler, - signature_name = "example_signature", - msigdb_collection = "H", - method = "hypergeo", - background = 20000 -) -} - -} diff --git a/tests/testthat/test_hypeR_client.R b/tests/testthat/test_hypeR_client.R deleted file mode 100644 index c2a0a426..00000000 --- a/tests/testthat/test_hypeR_client.R +++ /dev/null @@ -1,391 +0,0 @@ -test_that("prepareHypeRSignatures keeps group labels but does not split by direction", { - testthat::skip_if_not_installed("hypeR") - - sig <- OmicSignature::OmicSignature$new( - metadata = list( - signature_name = "group_only_signature", - assay_type = "transcriptomics", - phenotype = "test_phenotype", - organism = "Homo sapiens", - direction_type = "bi-directional", - others = list() - ), - signature = data.frame( - feature_name = c("GENE_A", "GENE_B", "GENE_C", "GENE_D"), - score = c(2, -1.5, 3, -0.8), - group_label = factor(c("treated", "treated", "control", "control")), - stringsAsFactors = FALSE - ), - difexp = NULL - ) - - prepared <- SigRepo::prepareHypeRSignatures( - omic_signature = sig, - method = "hypergeo", - split_by_group = TRUE, - split_by_direction = TRUE, - verbose = FALSE - ) - - expect_equal( - sort(names(prepared$signatures)), - sort(c("group_only_signature | control", "group_only_signature | treated")) - ) - expect_false(any(grepl("_up|_dn", names(prepared$signatures), perl = TRUE))) -}) - -test_that("prepareHypeRSignatures falls back to reference gene symbols and warns when rows are dropped", { - testthat::skip_if_not_installed("hypeR") - - sig <- OmicSignature::OmicSignature$new( - metadata = list( - signature_name = "mapped_symbol_signature", - assay_type = "transcriptomics", - phenotype = "test_phenotype", - organism = "Homo sapiens", - direction_type = "bi-directional", - others = list() - ), - signature = data.frame( - feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), - feature_id = c(101, 102, 103, 104), - group_label = factor(c("treated", "treated", "control", "control")), - stringsAsFactors = FALSE - ), - difexp = data.frame( - feature_name = c("feat_1", "feat_2", "feat_3", "feat_4"), - score = c(2.2, -1.8, 2.5, -0.9), - p_value = c(0.01, 0.02, 0.03, 0.04), - group_label = factor(c("treated", "treated", "control", "control")), - stringsAsFactors = FALSE - ) - ) - - testthat::local_mocked_bindings( - conn_init = function(conn_handler) list(), - lookup_table_sql = function(conn, db_table_name, return_var, filter_coln_var, filter_coln_val, check_db_table = TRUE, ...) { - expect_equal(db_table_name, "transcriptomics_features") - expect_equal(return_var, c("feature_name", "gene_symbol")) - data.frame( - feature_name = c("feat_1", "feat_2", "feat_3"), - gene_symbol = c("GENE_A", "GENE_B", NA_character_), - stringsAsFactors = FALSE - ) - }, - .package = "SigRepo" - ) - - expect_warning( - prepared <- SigRepo::prepareHypeRSignatures( - conn_handler = list(), - omic_signature = sig, - method = "gsea", - split_by_group = TRUE, - verbose = FALSE - ), - "dropped" - ) - - expect_true("GENE_A" %in% names(prepared$signatures[[1]])) - expect_true("GENE_B" %in% names(prepared$signatures[[1]])) - expect_false("feat_3" %in% names(prepared$signatures[[1]])) -}) - -test_that("prepareHypeRSignatures resolves feature_name to symbol when feature_col is symbol", { - testthat::skip_if_not_installed("hypeR") - - sig <- OmicSignature::OmicSignature$new( - metadata = list( - signature_name = "symbol_targeted_signature", - assay_type = "transcriptomics", - phenotype = "test_phenotype", - organism = "Homo sapiens", - direction_type = "bi-directional", - others = list() - ), - signature = data.frame( - feature_name = c("feat_1", "feat_2", "feat_3"), - group_label = factor(c("treated", "treated", "control")), - stringsAsFactors = FALSE - ), - difexp = NULL - ) - - testthat::local_mocked_bindings( - conn_init = function(conn_handler) list(), - lookup_table_sql = function(conn, db_table_name, return_var, filter_coln_var, filter_coln_val, check_db_table = TRUE, ...) { - expect_equal(db_table_name, "transcriptomics_features") - expect_equal(return_var, c("feature_name", "gene_symbol")) - data.frame( - feature_name = c("feat_1", "feat_2", "feat_3"), - gene_symbol = c("GENE_A", "GENE_B", "GENE_C"), - stringsAsFactors = FALSE - ) - }, - .package = "SigRepo" - ) - - prepared <- SigRepo::prepareHypeRSignatures( - conn_handler = list(), - omic_signature = sig, - method = "hypergeo", - feature_col = "symbol", - split_by_group = TRUE, - verbose = FALSE - ) - - expect_true("GENE_A" %in% unlist(prepared$signatures)) - expect_true("GENE_B" %in% unlist(prepared$signatures)) -}) - -test_that("prepareHypeRSignatures accepts hypergeometric and ks aliases", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - hyper <- SigRepo::prepareHypeRSignatures( - omic_signature = LLFS_Aging_Gene_2023, - method = "hypergeometric", - verbose = FALSE - ) - - ks <- SigRepo::prepareHypeRSignatures( - omic_signature = LLFS_Aging_Gene_2023, - method = "ks", - verbose = FALSE - ) - - expect_true(methods::is(hyper, "list")) - expect_true(methods::is(ks, "list")) - expect_true(base::length(hyper$signatures) > 0) - expect_true(base::length(ks$signatures) > 0) -}) - -test_that("prepareHypeRSignatures builds hypergeometric query vectors", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - prepared <- SigRepo::prepareHypeRSignatures( - omic_signature = LLFS_Aging_Gene_2023, - method = "hypergeo", - verbose = FALSE - ) - - expect_true(methods::is(prepared, "list")) - expect_true("signatures" %in% base::names(prepared)) - expect_true("metadata" %in% base::names(prepared)) - expect_equal(base::length(prepared$signatures), 1) - expect_true(base::length(prepared$signatures[[1]]) > 0) - expect_true(methods::is(prepared$metadata, "data.frame")) -}) - -test_that("prepareHypeRSignatures builds ranked query vectors for GSEA-style enrichment", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - prepared <- SigRepo::prepareHypeRSignatures( - omic_signature = LLFS_Aging_Gene_2023, - method = "gsea", - verbose = FALSE - ) - - expect_equal(base::length(prepared$signatures), 1) - expect_true(is.numeric(prepared$signatures[[1]])) - expect_true(!is.null(base::names(prepared$signatures[[1]]))) - expect_true(base::length(prepared$signatures[[1]]) > 0) -}) - -test_that("runHypeR runs hypergeometric enrichment on an OmicSignature object", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - feature_hits <- base::unique(utils::head(LLFS_Aging_Gene_2023$signature$feature_name, 10)) - genesets <- base::list( - hit_set = feature_hits, - miss_set = base::paste0("missing_", base::seq_len(10)) - ) - - hyp_res <- SigRepo::runHypeR( - omic_signature = LLFS_Aging_Gene_2023, - genesets = genesets, - method = "hypergeo", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE - ) - - expect_true(methods::is(hyp_res, "list")) - expect_true("result" %in% base::names(hyp_res)) - expect_s3_class(hyp_res$result, "R6") - expect_true("hyp" %in% class(hyp_res$result)) -}) - -test_that("runHypeR passes additional hypeR arguments through dots", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - feature_hits <- base::unique(utils::head(LLFS_Aging_Gene_2023$signature$feature_name, 10)) - genesets <- base::list( - hit_set = feature_hits, - miss_set = base::paste0("missing_", base::seq_len(10)) - ) - - hyp_res <- SigRepo::runHypeR( - omic_signature = LLFS_Aging_Gene_2023, - genesets = genesets, - method = "hypergeo", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE, - background = 12345 - ) - - expect_equal(hyp_res$result$args$background, 12345) -}) - -test_that("runHypeR runs GSEA-style enrichment on an OmicSignature object", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - feature_hits <- base::unique(utils::head(LLFS_Aging_Gene_2023$difexp$feature_name, 10)) - genesets <- base::list( - hit_set = feature_hits, - miss_set = base::paste0("missing_", base::seq_len(10)) - ) - - hyp_res <- base::suppressWarnings( - SigRepo::runHypeR( - omic_signature = LLFS_Aging_Gene_2023, - genesets = genesets, - method = "gsea", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE - ) - ) - - expect_true("hyp" %in% class(hyp_res$result)) -}) - -test_that("runHypeR handles multiple signatures and returns multihyp", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - feature_hits <- base::unique(utils::head(LLFS_Aging_Gene_2023$signature$feature_name, 10)) - genesets <- base::list( - hit_set = feature_hits, - miss_set = base::paste0("missing_", base::seq_len(10)) - ) - - sig_list <- base::list( - first_sig = LLFS_Aging_Gene_2023, - second_sig = LLFS_Aging_Gene_2023 - ) - - hyp_res <- SigRepo::runHypeR( - omic_signature = sig_list, - genesets = genesets, - method = "hypergeo", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE - ) - - expect_true("multihyp" %in% class(hyp_res$result)) - expect_equal(base::sort(base::names(hyp_res$signatures)), c("first_sig", "second_sig")) - expect_equal(base::sort(base::unique(hyp_res$metadata$signature_name)), c("first_sig", "second_sig")) -}) - -test_that("runHypeR accepts hypeR gsets objects directly", { - testthat::skip_if_not_installed("hypeR") - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - feature_hits <- base::unique(utils::head(LLFS_Aging_Gene_2023$signature$feature_name, 10)) - genesets <- hypeR::gsets$new( - genesets = base::list( - hit_set = feature_hits, - miss_set = base::paste0("missing_", base::seq_len(10)) - ), - name = "test_sets", - version = "v1", - quiet = TRUE - ) - - hyp_res <- SigRepo::runHypeR( - omic_signature = LLFS_Aging_Gene_2023, - genesets = genesets, - method = "hypergeo", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE - ) - - expect_true("hyp" %in% class(hyp_res$result)) -}) - -test_that("resolveHypeRGenesets falls back to direct msigdbr for mouse C2 collections", { - testthat::skip_if_not_installed("msigdbr") - - gsets <- SigRepo::resolveHypeRGenesets( - msigdb_species = "Mus musculus", - msigdb_collection = "C2", - msigdb_subcollection = "CP:KEGG_LEGACY" - ) - - expect_true(methods::is(gsets, "list")) - expect_true(length(gsets) > 0) - expect_true(any(grepl("KEGG", names(gsets), fixed = TRUE))) -}) - -test_that("runHypeR can retrieve MSigDB genesets automatically", { - testthat::skip_if_not_installed("hypeR") - testthat::skip_if_not_installed("msigdbr") - - # This is the one test in the suite that needs MSigDB itself; every other - # hypeR test builds its gene sets inline. msigdbr 26.x stopped bundling the - # data and downloads it from zenodo.org on first use, so the test now depends - # on a third-party service being reachable. - # - # Probe that service through the direct msigdbr fetch used by SigRepo, and skip - # with the reason when it is down: an outage there is an environment failure, - # not a regression in runHypeR, and it should not turn the suite red for - # everyone. The probe also warms msigdbr's cache, so the call below does not - # download twice. A probe that SUCCEEDS leaves both assertions in force. - probe <- base::tryCatch( - { - base::suppressWarnings( - SigRepo:::fetchMsigdbGenesets(species = "Homo sapiens", collection = "H") - ) - TRUE - }, - error = function(err) base::conditionMessage(err) - ) - testthat::skip_if_not( - base::isTRUE(probe), - base::paste("MSigDB gene sets could not be downloaded:", probe) - ) - - utils::data("LLFS_Aging_Gene_2023", package = "SigRepo", envir = environment()) - - hyp_res <- base::suppressWarnings( - SigRepo::runHypeR( - omic_signature = LLFS_Aging_Gene_2023, - msigdb_collection = "H", - method = "hypergeo", - plotting = FALSE, - quiet = TRUE, - verbose = FALSE - ) - ) - - expect_true("hyp" %in% class(hyp_res$result)) - expect_true("Genesets" %in% names(hyp_res$result$info)) - expect_true(!base::is.null(hyp_res$result$info[["Genesets"]])) -}) diff --git a/tests/testthat/test_hypeR_genesets.R b/tests/testthat/test_hypeR_genesets.R new file mode 100644 index 00000000..686f76b4 --- /dev/null +++ b/tests/testthat/test_hypeR_genesets.R @@ -0,0 +1,110 @@ +test_that("msigdbDbSpecies maps species and collection to the MSigDB database", { + expect_equal(SigRepo:::msigdbDbSpecies("Homo sapiens", "C2"), "HS") + expect_equal(SigRepo:::msigdbDbSpecies("Homo Sapiens", "H"), "HS") + expect_equal(SigRepo:::msigdbDbSpecies("Mus musculus", "MH"), "MM") + expect_equal(SigRepo:::msigdbDbSpecies("Mus musculus", "M8"), "MM") + expect_equal(SigRepo:::msigdbDbSpecies("Mus musculus", "C2"), "HS") + expect_equal(SigRepo:::msigdbDbSpecies("Mus musculus", "H"), "HS") + expect_equal(SigRepo:::msigdbDbSpecies("Rattus norvegicus", "H"), "HS") +}) + +test_that("getHypeRGenesets passes a named list, gsets and rgsets through unchanged", { + testthat::skip_if_not_installed("hypeR") + + gs <- list(SET_1 = c("A", "B"), SET_2 = c("C")) + expect_identical(SigRepo::getHypeRGenesets(gs), gs) + + gsets_obj <- hypeR::gsets$new(gs, name = "custom", version = "v1", quiet = TRUE) + expect_identical(SigRepo::getHypeRGenesets(gsets_obj), gsets_obj) + + rgsets_like <- structure(list(), class = c("rgsets", "R6")) + expect_identical(SigRepo::getHypeRGenesets(rgsets_like), rgsets_like) +}) + +test_that("getHypeRGenesets rejects anything that is not msigdb or a genesets object", { + form_error <- "'genesets' must be \"msigdb\"" + expect_error(SigRepo::getHypeRGenesets("mygeneset"), form_error, fixed = TRUE) + expect_error(SigRepo::getHypeRGenesets(c("msigdb", "H")), form_error, fixed = TRUE) + expect_error(SigRepo::getHypeRGenesets(NULL), form_error, fixed = TRUE) + expect_error(SigRepo::getHypeRGenesets(list(c("A", "B"))), form_error, fixed = TRUE) + expect_error(SigRepo::getHypeRGenesets(list()), form_error, fixed = TRUE) +}) + +test_that("getHypeRGenesets requires msigdb_collection for msigdb and forbids msigdb_* otherwise", { + expect_error( + SigRepo::getHypeRGenesets("msigdb"), + "genesets = \"msigdb\" requires 'msigdb_collection'", fixed = TRUE + ) + expect_error( + SigRepo::getHypeRGenesets(list(S = "A"), msigdb_collection = "H", msigdb_species = "Mus musculus"), + "msigdb_species, msigdb_collection only apply when genesets = \"msigdb\"", fixed = TRUE + ) +}) + +test_that("getHypeRGenesets forwards msigdb arguments with a human default species", { + testthat::local_mocked_bindings( + fetchMsigdbGsets = function(species, collection, subcollection = NULL, clean = FALSE) { + list(species = species, collection = collection, subcollection = subcollection, clean = clean) + }, + .package = "SigRepo" + ) + + out <- SigRepo::getHypeRGenesets("msigdb", msigdb_collection = "C2", msigdb_subcollection = "CP:REACTOME") + expect_equal(out, list(species = "Homo sapiens", collection = "C2", subcollection = "CP:REACTOME", clean = FALSE)) +}) + +test_that("fetchMsigdbGsets builds a named, versioned gsets with the right db_species", { + testthat::skip_if_not_installed("hypeR") + testthat::skip_if_not_installed("msigdbr") + + seen <- NULL + testthat::local_mocked_bindings( + callMsigdbr = function(args) { + seen <<- args + data.frame( + gs_name = c("SET_1", "SET_1", "SET_1", "SET_2"), + gene_symbol = c("Abc1", "Abc1", "Def2", NA), + stringsAsFactors = FALSE + ) + }, + .package = "SigRepo" + ) + + gs <- SigRepo:::fetchMsigdbGsets("Mus musculus", "C2", "CP:REACTOME") + + expect_equal(seen, list(species = "Mus musculus", db_species = "HS", collection = "C2", subcollection = "CP:REACTOME")) + expect_true(methods::is(gs, "gsets")) + expect_equal(gs$name, "C2.CP:REACTOME") + expect_equal(gs$version, paste0("v", as.character(utils::packageVersion("msigdbr")))) + expect_equal(gs$genesets, list(SET_1 = c("Abc1", "Def2"))) +}) + +test_that("fetchMsigdbGsets errors clearly when MSigDB returns nothing", { + testthat::skip_if_not_installed("hypeR") + testthat::skip_if_not_installed("msigdbr") + + testthat::local_mocked_bindings( + callMsigdbr = function(args) data.frame(gs_name = character(), gene_symbol = character()), + .package = "SigRepo" + ) + + expect_error( + SigRepo:::fetchMsigdbGsets("Homo sapiens", "NOPE"), + "msigdbr::msigdbr_collections()", fixed = TRUE + ) +}) + +test_that("fetchMsigdbGsets retrieves Hallmark from MSigDB", { + testthat::skip_on_cran() + testthat::skip_if_not_installed("hypeR") + testthat::skip_if_not_installed("msigdbr") + + gs <- tryCatch( + SigRepo:::fetchMsigdbGsets("Homo sapiens", "H"), + error = function(e) testthat::skip(paste("MSigDB unavailable:", conditionMessage(e))) + ) + + expect_true(methods::is(gs, "gsets")) + expect_equal(gs$name, "H") + expect_true("HALLMARK_APOPTOSIS" %in% names(gs$genesets)) +}) From 120aee8c3e34bd85d22b7dea6cde10dd055ece0a Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 14:29:46 -0400 Subject: [PATCH 03/61] feat: hypeR-native query vectors with group_label split and ordered symbol sources Regenerated NAMESPACE/man via devtools::document() to export prepareHypeRSignatures(). Co-Authored-By: Claude Sonnet 5 --- NAMESPACE | 1 + R/hypeRSignatures.R | 389 +++++++++++++++++++++++++ man/prepareHypeRSignatures.Rd | 72 +++++ tests/testthat/helper-hypeR.R | 58 ++++ tests/testthat/test_hypeR_signatures.R | 145 +++++++++ 5 files changed, 665 insertions(+) create mode 100644 R/hypeRSignatures.R create mode 100644 man/prepareHypeRSignatures.Rd create mode 100644 tests/testthat/helper-hypeR.R create mode 100644 tests/testthat/test_hypeR_signatures.R diff --git a/NAMESPACE b/NAMESPACE index 4194ce76..e7ee319b 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -63,6 +63,7 @@ export(init_handle) export(insert_table_sql) export(lookup_table_sql) export(newConnHandler) +export(prepareHypeRSignatures) export(print_messages) export(protTransform) export(removeDuplicates) diff --git a/R/hypeRSignatures.R b/R/hypeRSignatures.R new file mode 100644 index 00000000..db44fcdf --- /dev/null +++ b/R/hypeRSignatures.R @@ -0,0 +1,389 @@ +HYPER_DEFAULT_BACKGROUND <- 23467 + +# Column names a signature or difexp table may carry gene symbols under. Kept +# identical to SigRepo_Server's DIFEXP_SYMBOL_COLUMNS (api/lib/annotate.R). +HYPER_SYMBOL_COLUMNS <- c("gene_symbol", "symbol", "geneSymbol", "gene", "hgnc_symbol", "mgi_symbol") + +cleanHypeRSymbols <- function(x) { + x <- base::trimws(base::as.character(x)) + x[base::is.na(x) | !base::nzchar(x)] <- NA_character_ + x +} + +#' First symbol column that is present and populated, or NULL +#' @noRd +hypeRSymbolColumn <- function(tbl) { + if (!methods::is(tbl, "data.frame") || base::nrow(tbl) == 0) { + return(NULL) + } + for (col in HYPER_SYMBOL_COLUMNS) { + if (col %in% base::colnames(tbl) && base::any(!base::is.na(cleanHypeRSymbols(tbl[[col]])))) { + return(col) + } + } + NULL +} + +#' feature_name -> gene_symbol from the reference table for one organism +#' +#' Reference tables are unique on (feature_name, organism_id), so the organism +#' filter is required. lookup_table_sql() matches on trim(lower()), so callers +#' must match the returned names case-insensitively. +#' +#' @return Named character vector (names = feature_name as stored). +#' @noRd +lookupReferenceSymbols <- function(conn_handler, assay_type, organism, feature_names) { + ref_table <- base::switch( + base::tolower(base::as.character(assay_type)[1]), + transcriptomics = "transcriptomics_features", + proteomics = "proteomics_features", + NULL + ) + feature_names <- base::unique(feature_names[!base::is.na(feature_names) & base::nzchar(feature_names)]) + + if (base::is.null(conn_handler) || base::is.null(ref_table) || base::length(feature_names) == 0 || + base::length(organism) == 0 || base::is.na(organism[1]) || !base::nzchar(organism[1])) { + return(base::character()) + } + + conn <- SigRepo::conn_init(conn_handler = conn_handler) + base::on.exit(base::try(DBI::dbDisconnect(conn), silent = TRUE), add = TRUE) + + organism_tbl <- SigRepo::lookup_table_sql( + conn = conn, + db_table_name = "organisms", + return_var = c("organism_id", "organism"), + filter_coln_var = "organism", + filter_coln_val = base::list("organism" = organism[1]), + check_db_table = TRUE + ) + if (base::nrow(organism_tbl) == 0) { + return(base::character()) + } + + ref_tbl <- SigRepo::lookup_table_sql( + conn = conn, + db_table_name = ref_table, + return_var = c("feature_name", "gene_symbol"), + filter_coln_var = c("feature_name", "organism_id"), + filter_coln_val = base::list("feature_name" = feature_names, "organism_id" = organism_tbl$organism_id[1]), + filter_var_by = "AND", + check_db_table = TRUE + ) + + symbols <- cleanHypeRSymbols(ref_tbl$gene_symbol) + keep <- !base::is.na(symbols) + stats::setNames(symbols[keep], base::as.character(ref_tbl$feature_name[keep])) +} + +#' Gene symbols for each row of a signature's signature or difexp table +#' +#' First source that yields any symbol wins: +#' 1. a symbol column in the table itself; +#' 2. (signature table only) the difexp's symbol column joined on probe_id -- +#' probe_id is an opaque key, used here only to join the two tables; +#' 3. the reference table by feature_name + organism (needs conn_handler). +#' +#' @return list(symbols = chr aligned with rows, NA where unmapped; source = chr) +#' @noRd +resolveSignatureSymbols <- function(omic_signature, table = c("signature", "difexp"), conn_handler = NULL) { + table <- base::match.arg(table) + tbl <- omic_signature[[table]] + n_rows <- base::nrow(tbl) + + own_col <- hypeRSymbolColumn(tbl) + if (!base::is.null(own_col)) { + return(base::list(symbols = cleanHypeRSymbols(tbl[[own_col]]), source = base::sprintf("%s$%s", table, own_col))) + } + + if (base::identical(table, "signature")) { + difexp_tbl <- omic_signature$difexp + difexp_col <- hypeRSymbolColumn(difexp_tbl) + if (!base::is.null(difexp_col) && "probe_id" %in% base::colnames(tbl) && "probe_id" %in% base::colnames(difexp_tbl)) { + by_probe <- stats::setNames(cleanHypeRSymbols(difexp_tbl[[difexp_col]]), base::as.character(difexp_tbl$probe_id)) + symbols <- base::unname(by_probe[base::as.character(tbl$probe_id)]) + if (base::any(!base::is.na(symbols))) { + return(base::list(symbols = symbols, source = base::sprintf("difexp$%s via probe_id", difexp_col))) + } + } + } + + if ("feature_name" %in% base::colnames(tbl)) { + feature_names <- base::trimws(base::as.character(tbl$feature_name)) + # OmicSignature$new() sorts signature/difexp rows by desc(abs(score)) when a + # score column is present, so tbl's row order is not the caller's input + # order. Sort before the lookup call so it (and its provenance) is + # deterministic; row alignment below still keys off names, not order. + reference <- lookupReferenceSymbols( + conn_handler = conn_handler, + assay_type = omic_signature$metadata$assay_type, + organism = omic_signature$metadata$organism, + feature_names = base::sort(feature_names) + ) + if (base::length(reference) > 0) { + base::names(reference) <- base::tolower(base::names(reference)) + symbols <- base::unname(reference[base::tolower(feature_names)]) + if (base::any(!base::is.na(symbols))) { + return(base::list(symbols = symbols, source = "reference feature_name")) + } + } + } + + base::list(symbols = base::rep(NA_character_, n_rows), source = NA_character_) +} + +disambiguateHypeRLabels <- function(labels) { + used <- base::character() + for (i in base::seq_along(labels)) { + candidate <- labels[i] + suffix <- 2L + while (candidate %in% used) { + candidate <- base::sprintf("%s (%d)", labels[i], suffix) + suffix <- suffix + 1L + } + labels[i] <- candidate + used <- c(used, candidate) + } + labels +} + +#' Resolve signatures plus their ids and display labels +#' @noRd +collectHypeRSignatures <- function(conn_handler, signature_id, signature_name, omic_signature, verbose) { + signatures <- resolveHypeRSignatures( + conn_handler = conn_handler, + signature_id = signature_id, + signature_name = signature_name, + omic_signature = omic_signature, + verbose = verbose + ) + + supplied_names <- if (!base::is.null(omic_signature) && !methods::is(omic_signature, "OmicSignature")) { + base::names(omic_signature) + } else { + NULL + } + + fetched_by_id <- base::is.null(omic_signature) && base::length(signature_id) > 0 && + base::any(!signature_id %in% c("", NA)) + ids <- if (fetched_by_id) base::names(signatures) else base::rep(NA_character_, base::length(signatures)) + + labels <- base::vapply(base::seq_along(signatures), function(i) { + supplied <- supplied_names[i] + if (!base::is.null(supplied) && !base::is.na(supplied) && base::nzchar(supplied)) { + return(base::as.character(supplied)) + } + resolveSignatureLabel(signatures[[i]], label = NULL, fallback = base::sprintf("sig_%s", i)) + }, base::character(1)) + + base::list(signatures = base::unname(signatures), ids = ids, labels = disambiguateHypeRLabels(labels)) +} + +emptyHypeRInfo <- function() { + base::data.frame( + query = base::character(), signature_id = base::character(), signature_name = base::character(), + group_label = base::character(), n_features = base::integer(), n_dropped = base::integer(), + symbol_source = base::character(), stringsAsFactors = FALSE + ) +} + +hypeRInfoRow <- function(query, signature_id, label, group_label, n_features, n_dropped, symbol_source) { + base::data.frame( + query = query, signature_id = signature_id, signature_name = label, group_label = group_label, + n_features = base::as.integer(n_features), n_dropped = base::as.integer(n_dropped), + symbol_source = symbol_source, stringsAsFactors = FALSE + ) +} + +hypeRSkip <- function(reason, message) { + base::list(queries = base::list(), info = NULL, skip = base::list(reason = reason, message = message)) +} + +#' Hypergeometric query vectors for one signature +#' @noRd +buildHypergeometricQueries <- function(omic_signature, label, signature_id, split, conn_handler) { + tbl <- omic_signature$signature + if (!methods::is(tbl, "data.frame") || base::nrow(tbl) == 0) { + return(hypeRSkip("empty_signature", "The signature table is empty.")) + } + + resolved <- resolveSignatureSymbols(omic_signature, "signature", conn_handler) + if (base::all(base::is.na(resolved$symbols))) { + return(hypeRSkip("no_gene_symbols", "No gene symbols in the signature, its difexp, or the reference tables.")) + } + + groups <- if (base::isTRUE(split) && "group_label" %in% base::colnames(tbl)) { + base::trimws(base::as.character(tbl$group_label)) + } else { + base::rep("", base::nrow(tbl)) + } + groups[base::is.na(groups)] <- "" + + queries <- base::list() + info <- base::list() + # OmicSignature$new() sorts signature rows by desc(abs(score)) when a score + # column is present, so tbl's row order is not the caller's input order. + # Sort query vectors so output is deterministic regardless of that ordering + # (the hypergeometric test treats a query as an unordered set anyway). + for (group in base::sort(base::unique(groups))) { + group_symbols <- resolved$symbols[groups == group] + query <- base::sort(base::unique(group_symbols[!base::is.na(group_symbols)])) + if (base::length(query) == 0) { + next + } + query_name <- if (base::nzchar(group)) base::sprintf("%s | %s", label, group) else label + queries[[query_name]] <- query + info[[base::length(info) + 1]] <- hypeRInfoRow( + query = query_name, signature_id = signature_id, label = label, + group_label = if (base::nzchar(group)) group else NA_character_, + n_features = base::length(query), n_dropped = base::sum(base::is.na(group_symbols)), + symbol_source = resolved$source + ) + } + + base::list(queries = queries, info = base::do.call(base::rbind, info), skip = NULL) +} + +#' Weighted (ranked) kstest query vector for one signature +#' @noRd +buildKstestQuery <- function(omic_signature, label, signature_id, score_col, conn_handler) { + tbl <- omic_signature$difexp + if (!methods::is(tbl, "data.frame") || base::nrow(tbl) == 0) { + return(hypeRSkip("no_difexp", "kstest needs a difexp table and this signature has none.")) + } + if (!score_col %in% base::colnames(tbl)) { + return(hypeRSkip( + "missing_score_col", + base::sprintf("difexp has no '%s' column (has: %s).", score_col, base::paste(base::colnames(tbl), collapse = ", ")) + )) + } + + resolved <- resolveSignatureSymbols(omic_signature, "difexp", conn_handler) + scores <- base::suppressWarnings(base::as.numeric(tbl[[score_col]])) + keep <- !base::is.na(resolved$symbols) & !base::is.na(scores) + if (!base::any(keep)) { + return(hypeRSkip("no_gene_symbols", "No difexp row has both a gene symbol and a numeric score.")) + } + + best <- base::vapply( + base::split(scores[keep], resolved$symbols[keep]), + function(x) x[base::which.max(base::abs(x))], + base::numeric(1) + ) + query <- base::sort(best, decreasing = TRUE) + + base::list( + queries = stats::setNames(base::list(query), label), + info = hypeRInfoRow( + query = label, signature_id = signature_id, label = label, group_label = NA_character_, + n_features = base::length(query), n_dropped = base::sum(!keep), symbol_source = resolved$source + ), + skip = NULL + ) +} + +#' Build query vectors for already-collected signatures +#' @noRd +buildHypeRQueries <- function(inputs, test, split, score_col, conn_handler) { + queries <- base::list() + info <- base::list() + skipped <- base::list() + + for (i in base::seq_along(inputs$signatures)) { + built <- if (base::identical(test, "hypergeometric")) { + buildHypergeometricQueries(inputs$signatures[[i]], inputs$labels[i], inputs$ids[i], split, conn_handler) + } else { + buildKstestQuery(inputs$signatures[[i]], inputs$labels[i], inputs$ids[i], score_col, conn_handler) + } + + if (!base::is.null(built$skip)) { + skipped[[base::length(skipped) + 1]] <- base::data.frame( + signature = inputs$labels[i], reason = built$skip$reason, message = built$skip$message, + stringsAsFactors = FALSE + ) + next + } + + queries <- c(queries, built$queries) + info[[base::length(info) + 1]] <- built$info + } + + base::list( + signatures = queries, + info = if (base::length(info) > 0) base::do.call(base::rbind, info) else emptyHypeRInfo(), + skipped = if (base::length(skipped) > 0) { + base::do.call(base::rbind, skipped) + } else { + base::data.frame(signature = base::character(), reason = base::character(), message = base::character(), stringsAsFactors = FALSE) + } + ) +} + +#' Build hypeR query vectors from SigRepo signatures +#' +#' @description Turns SigRepo signatures into the query vectors +#' \code{hypeR::hypeR()} takes, and reports how each was built. Use it to +#' inspect exactly what \code{runHypeR()} will test. +#' +#' @param conn_handler An R object obtained from \code{SigRepo::newConnHandler()}. +#' Needed to fetch signatures by id/name and for reference-table symbol lookup. +#' @param signature_id One or more SigRepo signature IDs. +#' @param signature_name One or more SigRepo signature names. +#' @param omic_signature An \code{OmicSignature} object or a list of them. List +#' names, when given, become the query labels. +#' @param test \code{"hypergeometric"} (a character vector of symbols from the +#' signature table) or \code{"kstest"} (a named numeric vector ranked by +#' \code{score_col} from the full difexp table). +#' @param split Logical; for \code{"hypergeometric"}, build one vector per +#' \code{group_label} (e.g. one per arm of a bi-directional signature). Ignored by +#' \code{"kstest"}, whose ranked list already carries direction in its sign. +#' Defaults to \code{TRUE}. +#' @param score_col difexp column used to rank genes for \code{"kstest"}. +#' Defaults to \code{"score"}. +#' @param verbose Logical; print messages while fetching signatures. +#' +#' @details Gene symbols come from the first source that works: a symbol column +#' (\code{gene_symbol}, \code{symbol}, \code{geneSymbol}, \code{gene}, +#' \code{hgnc_symbol}, \code{mgi_symbol}) in the table itself; for +#' \code{"hypergeometric"}, the difexp's symbol column joined on \code{probe_id}; +#' then the reference feature table by \code{feature_name} and organism (needs +#' \code{conn_handler}). \code{probe_id} is never read as a symbol. +#' +#' @return A list with +#' \describe{ +#' \item{\code{signatures}}{Named list of query vectors, ready for \code{hypeR::hypeR()}.} +#' \item{\code{info}}{Data frame, one row per query: \code{query}, \code{signature_id}, +#' \code{signature_name}, \code{group_label}, \code{n_features}, \code{n_dropped}, +#' \code{symbol_source}.} +#' \item{\code{skipped}}{Data frame of signatures that produced no query: +#' \code{signature}, \code{reason}, \code{message}.} +#' } +#' +#' @examples +#' utils::data("LLFS_Aging_Gene_2023", package = "SigRepo") +#' prepared <- SigRepo::prepareHypeRSignatures(omic_signature = LLFS_Aging_Gene_2023, verbose = FALSE) +#' prepared$info +#' +#' @export +prepareHypeRSignatures <- function( + conn_handler = NULL, + signature_id = NULL, + signature_name = NULL, + omic_signature = NULL, + test = c("hypergeometric", "kstest"), + split = TRUE, + score_col = "score", + verbose = TRUE +) { + test <- base::match.arg(test) + + inputs <- collectHypeRSignatures( + conn_handler = conn_handler, + signature_id = signature_id, + signature_name = signature_name, + omic_signature = omic_signature, + verbose = verbose + ) + + buildHypeRQueries(inputs, test = test, split = split, score_col = score_col, conn_handler = conn_handler) +} diff --git a/man/prepareHypeRSignatures.Rd b/man/prepareHypeRSignatures.Rd new file mode 100644 index 00000000..fb7f7d13 --- /dev/null +++ b/man/prepareHypeRSignatures.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypeRSignatures.R +\name{prepareHypeRSignatures} +\alias{prepareHypeRSignatures} +\title{Build hypeR query vectors from SigRepo signatures} +\usage{ +prepareHypeRSignatures( + conn_handler = NULL, + signature_id = NULL, + signature_name = NULL, + omic_signature = NULL, + test = c("hypergeometric", "kstest"), + split = TRUE, + score_col = "score", + verbose = TRUE +) +} +\arguments{ +\item{conn_handler}{An R object obtained from \code{SigRepo::newConnHandler()}. +Needed to fetch signatures by id/name and for reference-table symbol lookup.} + +\item{signature_id}{One or more SigRepo signature IDs.} + +\item{signature_name}{One or more SigRepo signature names.} + +\item{omic_signature}{An \code{OmicSignature} object or a list of them. List +names, when given, become the query labels.} + +\item{test}{\code{"hypergeometric"} (a character vector of symbols from the +signature table) or \code{"kstest"} (a named numeric vector ranked by +\code{score_col} from the full difexp table).} + +\item{split}{Logical; for \code{"hypergeometric"}, build one vector per +\code{group_label} (e.g. one per arm of a bi-directional signature). Ignored by +\code{"kstest"}, whose ranked list already carries direction in its sign. +Defaults to \code{TRUE}.} + +\item{score_col}{difexp column used to rank genes for \code{"kstest"}. +Defaults to \code{"score"}.} + +\item{verbose}{Logical; print messages while fetching signatures.} +} +\value{ +A list with +\describe{ + \item{\code{signatures}}{Named list of query vectors, ready for \code{hypeR::hypeR()}.} + \item{\code{info}}{Data frame, one row per query: \code{query}, \code{signature_id}, + \code{signature_name}, \code{group_label}, \code{n_features}, \code{n_dropped}, + \code{symbol_source}.} + \item{\code{skipped}}{Data frame of signatures that produced no query: + \code{signature}, \code{reason}, \code{message}.} +} +} +\description{ +Turns SigRepo signatures into the query vectors +\code{hypeR::hypeR()} takes, and reports how each was built. Use it to +inspect exactly what \code{runHypeR()} will test. +} +\details{ +Gene symbols come from the first source that works: a symbol column +(\code{gene_symbol}, \code{symbol}, \code{geneSymbol}, \code{gene}, +\code{hgnc_symbol}, \code{mgi_symbol}) in the table itself; for +\code{"hypergeometric"}, the difexp's symbol column joined on \code{probe_id}; +then the reference feature table by \code{feature_name} and organism (needs +\code{conn_handler}). \code{probe_id} is never read as a symbol. +} +\examples{ +utils::data("LLFS_Aging_Gene_2023", package = "SigRepo") +prepared <- SigRepo::prepareHypeRSignatures(omic_signature = LLFS_Aging_Gene_2023, verbose = FALSE) +prepared$info + +} diff --git a/tests/testthat/helper-hypeR.R b/tests/testthat/helper-hypeR.R new file mode 100644 index 00000000..dbe1afcb --- /dev/null +++ b/tests/testthat/helper-hypeR.R @@ -0,0 +1,58 @@ +# Fixtures for the hypeR client tests. testthat sources helper-*.R before the +# test files. OmicSignature requires group_label to be a factor. + +hyper_sig_table <- function(symbols = TRUE) { + tbl <- data.frame( + probe_id = c("p1", "p2", "p3", "p4"), + feature_name = c("f1", "f2", "f3", "f4"), + score = c(3, 2, -2, -3), + group_label = factor(c("Old", "Old", "Young", "Young")), + stringsAsFactors = FALSE + ) + if (symbols) { + tbl$symbol <- c("A", "B", "C", "D") + } + tbl +} + +# Full difexp: gene_symbol column, symbol E measured twice (scores 0.5 and -1). +hyper_difexp_table <- function() { + data.frame( + probe_id = paste0("p", 1:6), + feature_name = paste0("f", 1:6), + gene_symbol = c("A", "B", "C", "D", "E", "E"), + score = c(3, 2, -2, -3, 0.5, -1), + p_value = c(0.001, 0.01, 0.01, 0.001, 0.5, 0.2), + adj_p = c(0.01, 0.05, 0.05, 0.01, 0.6, 0.3), + group_label = factor(c("Old", "Old", "Young", "Young", "Old", "Young")), + stringsAsFactors = FALSE + ) +} + +make_hyper_sig <- function(name = "sig_a", + signature = hyper_sig_table(), + difexp = NULL, + direction_type = "bi-directional", + organism = "Homo sapiens") { + OmicSignature::OmicSignature$new( + metadata = list( + signature_name = name, + assay_type = "transcriptomics", + phenotype = "test_phenotype", + organism = organism, + direction_type = direction_type, + others = list() + ), + signature = signature, + difexp = difexp, + print_message = FALSE + ) +} + +hyper_genesets <- function() { + list( + SET_AB = c("A", "B", "X1", "X2"), + SET_CD = c("C", "D", "X3"), + SET_E = c("E", "X4", "X5") + ) +} diff --git a/tests/testthat/test_hypeR_signatures.R b/tests/testthat/test_hypeR_signatures.R new file mode 100644 index 00000000..7e2281fe --- /dev/null +++ b/tests/testthat/test_hypeR_signatures.R @@ -0,0 +1,145 @@ +test_that("hypeRSymbolColumn picks the first populated symbol column", { + tbl <- data.frame(gene_symbol = c(NA, ""), symbol = c("A", "B"), stringsAsFactors = FALSE) + expect_equal(SigRepo:::hypeRSymbolColumn(tbl), "symbol") + expect_null(SigRepo:::hypeRSymbolColumn(data.frame(feature_name = "f1"))) + expect_null(SigRepo:::hypeRSymbolColumn(NULL)) +}) + +test_that("lookupReferenceSymbols returns nothing without a connection", { + expect_identical( + SigRepo:::lookupReferenceSymbols(NULL, "transcriptomics", "Homo sapiens", c("f1", "f2")), + character() + ) +}) + +test_that("hypergeometric splits by group_label using the signature's own symbols", { + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = make_hyper_sig(), verbose = FALSE) + + expect_equal(names(prepared$signatures), c("sig_a | Old", "sig_a | Young")) + expect_equal(prepared$signatures[["sig_a | Old"]], c("A", "B")) + expect_equal(prepared$signatures[["sig_a | Young"]], c("C", "D")) + expect_equal(prepared$info$group_label, c("Old", "Young")) + expect_equal(prepared$info$symbol_source, c("signature$symbol", "signature$symbol")) + expect_equal(prepared$info$n_features, c(2L, 2L)) + expect_equal(nrow(prepared$skipped), 0L) +}) + +test_that("split = FALSE gives one hypergeometric vector per signature", { + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = make_hyper_sig(), split = FALSE, verbose = FALSE) + + expect_equal(names(prepared$signatures), "sig_a") + expect_equal(prepared$signatures[["sig_a"]], c("A", "B", "C", "D")) + expect_true(is.na(prepared$info$group_label)) +}) + +test_that("a signature without group_label gives one vector named after the signature", { + tbl <- hyper_sig_table() + tbl$group_label <- NULL + sig <- make_hyper_sig(signature = tbl, direction_type = "uni-directional") + + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = sig, verbose = FALSE) + + expect_equal(names(prepared$signatures), "sig_a") +}) + +test_that("hypergeometric falls back to difexp symbols joined on probe_id", { + sig <- make_hyper_sig(signature = hyper_sig_table(symbols = FALSE), difexp = hyper_difexp_table()) + + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = sig, verbose = FALSE) + + expect_equal(prepared$signatures[["sig_a | Old"]], c("A", "B")) + expect_equal(prepared$info$symbol_source[1], "difexp$gene_symbol via probe_id") +}) + +test_that("hypergeometric falls back to the reference table by feature_name and organism", { + seen <- NULL + testthat::local_mocked_bindings( + lookupReferenceSymbols = function(conn_handler, assay_type, organism, feature_names) { + seen <<- list(assay_type = assay_type, organism = organism, feature_names = feature_names) + c(F1 = "A", F2 = "B", F3 = "C") + }, + .package = "SigRepo" + ) + sig <- make_hyper_sig(signature = hyper_sig_table(symbols = FALSE)) + + prepared <- SigRepo::prepareHypeRSignatures(conn_handler = list(), omic_signature = sig, verbose = FALSE) + + expect_equal(seen$assay_type, "transcriptomics") + expect_equal(seen$organism, "Homo sapiens") + expect_equal(seen$feature_names, c("f1", "f2", "f3", "f4")) + expect_equal(prepared$signatures[["sig_a | Old"]], c("A", "B")) + expect_equal(prepared$signatures[["sig_a | Young"]], "C") + expect_equal(prepared$info$n_dropped, c(0L, 1L)) + expect_equal(prepared$info$symbol_source[1], "reference feature_name") +}) + +test_that("probe_id is never used as a symbol: no symbols and no connection means skipped", { + sig <- make_hyper_sig(signature = hyper_sig_table(symbols = FALSE)) + + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = sig, verbose = FALSE) + + expect_length(prepared$signatures, 0L) + expect_equal(prepared$skipped$signature, "sig_a") + expect_equal(prepared$skipped$reason, "no_gene_symbols") +}) + +test_that("kstest ranks the full difexp, collapsing duplicate symbols by max |score|", { + sig <- make_hyper_sig(difexp = hyper_difexp_table()) + + prepared <- SigRepo::prepareHypeRSignatures(omic_signature = sig, test = "kstest", verbose = FALSE) + + expect_equal(names(prepared$signatures), "sig_a") + expect_equal(prepared$signatures[["sig_a"]], c(A = 3, B = 2, E = -1, C = -2, D = -3)) + expect_equal(prepared$info$symbol_source, "difexp$gene_symbol") + expect_true(is.na(prepared$info$group_label)) +}) + +test_that("kstest skips signatures without difexp or without the score column", { + no_difexp <- SigRepo::prepareHypeRSignatures(omic_signature = make_hyper_sig(), test = "kstest", verbose = FALSE) + expect_equal(no_difexp$skipped$reason, "no_difexp") + + no_score <- SigRepo::prepareHypeRSignatures( + omic_signature = make_hyper_sig(difexp = hyper_difexp_table()), + test = "kstest", score_col = "logFC", verbose = FALSE + ) + expect_equal(no_score$skipped$reason, "missing_score_col") + expect_match(no_score$skipped$message, "logFC", fixed = TRUE) +}) + +test_that("labels come from supplied list names, then signature_name, with (2) for duplicates", { + named <- SigRepo::prepareHypeRSignatures( + omic_signature = list(first = make_hyper_sig("x"), second = make_hyper_sig("y")), + split = FALSE, verbose = FALSE + ) + expect_equal(names(named$signatures), c("first", "second")) + + dupes <- SigRepo::prepareHypeRSignatures( + omic_signature = list(make_hyper_sig("dup"), make_hyper_sig("dup"), make_hyper_sig("dup")), + split = FALSE, verbose = FALSE + ) + expect_equal(names(dupes$signatures), c("dup", "dup (2)", "dup (3)")) +}) + +test_that("signature ids are recorded when signatures are fetched by id", { + testthat::local_mocked_bindings( + getSignature = function(conn_handler, signature_id = NULL, signature_name = NULL, verbose = TRUE) { + list(make_hyper_sig("db_sig")) + }, + .package = "SigRepo" + ) + + inputs <- SigRepo:::collectHypeRSignatures( + conn_handler = list(), signature_id = 101, signature_name = NULL, + omic_signature = NULL, verbose = FALSE + ) + + expect_equal(inputs$ids, "101") + expect_equal(inputs$labels, "db_sig") +}) + +test_that("prepareHypeRSignatures rejects the removed test aliases", { + expect_error( + SigRepo::prepareHypeRSignatures(omic_signature = make_hyper_sig(), test = "gsea", verbose = FALSE), + "should be one of" + ) +}) From 0b86e4f186af6ac063ebd842838a97486a97aba1 Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 14:38:00 -0400 Subject: [PATCH 04/61] feat: hypeR-native runHypeR returning hyp/multihyp with SigRepo provenance hypeR's argument names and defaults, per-query "difexp" background, and unusable signatures skipped with a warning instead of aborting the run. Co-Authored-By: Claude Sonnet 5 --- NAMESPACE | 1 + R/hypeRClient.R | 213 +++++++++++++++++++++++++++++ man/runHypeR.Rd | 127 +++++++++++++++++ tests/testthat/test_hypeR_client.R | 100 ++++++++++++++ 4 files changed, 441 insertions(+) create mode 100644 man/runHypeR.Rd create mode 100644 tests/testthat/test_hypeR_client.R diff --git a/NAMESPACE b/NAMESPACE index e7ee319b..e42bdb1e 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -68,6 +68,7 @@ export(print_messages) export(protTransform) export(removeDuplicates) export(removeSignatureFromCollection) +export(runHypeR) export(runHyperGEM) export(searchAssayType) export(searchCollection) diff --git a/R/hypeRClient.R b/R/hypeRClient.R index bb2a2d33..6824b2d4 100644 --- a/R/hypeRClient.R +++ b/R/hypeRClient.R @@ -212,3 +212,216 @@ resolveHypeRSignatureLabels <- function(omic_signatures) { base::make.unique(labels) } + + +#' Background for each query vector +#' +#' A number or gene vector is passed through for every query. "difexp" gives +#' each query its own signature's measured genes; signatures without difexp +#' symbols fall back to hypeR's default with one warning. +#' +#' @return Unnamed list, one background per row of `info`. +#' @noRd +resolveQueryBackgrounds <- function(background, info, inputs, conn_handler) { + if (!(base::is.character(background) && base::length(background) == 1L && base::identical(background, "difexp"))) { + return(base::rep(base::list(background), base::nrow(info))) + } + + signatures_by_label <- stats::setNames(inputs$signatures, inputs$labels) + universes <- base::list() + fell_back <- base::character() + + for (label in base::unique(info$signature_name)) { + sig <- signatures_by_label[[label]] + symbols <- if (methods::is(sig$difexp, "data.frame") && base::nrow(sig$difexp) > 0) { + resolveSignatureSymbols(sig, "difexp", conn_handler)$symbols + } else { + NA_character_ + } + symbols <- base::unique(symbols[!base::is.na(symbols)]) + + if (base::length(symbols) == 0) { + fell_back <- c(fell_back, label) + universes[[label]] <- HYPER_DEFAULT_BACKGROUND + } else { + universes[[label]] <- symbols + } + } + + if (base::length(fell_back) > 0) { + base::warning( + base::sprintf( + "background = \"difexp\": no difexp gene symbols for %s; used background = %s instead.", + base::paste(base::sprintf("'%s'", fell_back), collapse = ", "), + HYPER_DEFAULT_BACKGROUND + ), + call. = FALSE + ) + } + + base::unname(universes[info$signature_name]) +} + +#' Append SigRepo provenance to a hyp object's info, in a fixed order +#' +#' hypeR::hyp_to_excel() stacks info across a multihyp with mapply(), so every +#' hyp must carry the same keys in the same order. +#' @noRd +appendHypeRProvenance <- function(hyp_obj, info_row) { + hyp_obj$info <- c(hyp_obj$info, base::list( + "SigRepo Signature ID" = if (base::is.na(info_row$signature_id)) "" else base::as.character(info_row$signature_id), + "SigRepo Signature Name" = base::as.character(info_row$signature_name), + "Group Label" = if (base::is.na(info_row$group_label)) "" else base::as.character(info_row$group_label), + "Symbol Source" = if (base::is.na(info_row$symbol_source)) "" else base::as.character(info_row$symbol_source) + )) + hyp_obj +} + +warnSkippedHypeRSignatures <- function(skipped) { + if (base::nrow(skipped) == 0) { + return(base::invisible(NULL)) + } + base::warning( + base::sprintf( + "Skipped %d signature(s): %s", + base::nrow(skipped), + base::paste(base::sprintf("'%s' (%s: %s)", skipped$signature, skipped$reason, skipped$message), collapse = "; ") + ), + call. = FALSE + ) +} + +#' Run hypeR enrichment on SigRepo signatures +#' +#' @description Builds hypeR query vectors from SigRepo signatures (see +#' \code{prepareHypeRSignatures()}) and runs \code{hypeR::hypeR()} on them. The +#' arguments after \code{score_col} are hypeR's own, with hypeR's defaults, and +#' the result is hypeR's own object, so \code{hypeR::hyp_dots()}, +#' \code{hyp_show()}, \code{hyp_emap()}, \code{hyp_to_excel()} and +#' \code{hyp_to_rmd()} work on it directly. +#' +#' @inheritParams prepareHypeRSignatures +#' @inheritParams getHypeRGenesets +#' @param background hypeR's background: a single number (population size), a +#' character vector of background genes, or \code{"difexp"} to use each +#' signature's measured genes from its difexp table. Signatures without difexp +#' symbols fall back to \code{23467} with a warning. Defaults to \code{23467}. +#' @param power Exponent for score weights (kstest only). \code{1} (default) +#' weights hits by score, GSEA-style; \code{0} is the classic unweighted KS +#' statistic. +#' @param absolute Passed to \code{hypeR::hypeR()} (kstest only). Defaults to \code{FALSE}. +#' @param pval Keep results with p-value at or below this. Defaults to \code{1}. +#' @param fdr Keep results with FDR at or below this. Defaults to \code{1}. +#' @param plotting Logical; generate hypeR's per-geneset plots. Defaults to \code{FALSE}. +#' @param quiet Logical; suppress hypeR's logs. Defaults to \code{TRUE}. +#' +#' @return A \code{hypeR} \code{hyp} object when one query vector is produced, +#' otherwise a \code{multihyp} named by query. Each \code{hyp$info} ends with +#' \code{SigRepo Signature ID}, \code{SigRepo Signature Name}, +#' \code{Group Label} and \code{Symbol Source}. Signatures that cannot produce a +#' query are skipped with a warning; if none can, an error is raised. +#' +#' @examples +#' \dontrun{ +#' utils::data("LLFS_Aging_Gene_2023", package = "SigRepo") +#' +#' hyp <- SigRepo::runHypeR( +#' omic_signature = LLFS_Aging_Gene_2023, +#' genesets = "msigdb", +#' msigdb_collection = "H", +#' fdr = 0.05 +#' ) +#' hypeR::hyp_dots(hyp) +#' +#' ranked <- SigRepo::runHypeR( +#' omic_signature = LLFS_Aging_Gene_2023, +#' genesets = "msigdb", +#' msigdb_collection = "H", +#' test = "kstest", +#' power = 0 +#' ) +#' } +#' +#' @export +runHypeR <- function( + conn_handler = NULL, + signature_id = NULL, + signature_name = NULL, + omic_signature = NULL, + genesets, + msigdb_species = NULL, + msigdb_collection = NULL, + msigdb_subcollection = NULL, + msigdb_clean = FALSE, + test = c("hypergeometric", "kstest"), + split = TRUE, + score_col = "score", + background = 23467, + power = 1, + absolute = FALSE, + pval = 1, + fdr = 1, + plotting = FALSE, + quiet = TRUE, + verbose = TRUE +) { + if (!base::requireNamespace("hypeR", quietly = TRUE)) { + base::stop("\nPackage 'hypeR' is required for runHypeR(). Please install it first.\n") + } + + test <- base::match.arg(test) + + if (base::missing(genesets)) { + genesets <- NULL + } + resolved_genesets <- getHypeRGenesets( + genesets = genesets, + msigdb_species = msigdb_species, + msigdb_collection = msigdb_collection, + msigdb_subcollection = msigdb_subcollection, + msigdb_clean = msigdb_clean + ) + + inputs <- collectHypeRSignatures( + conn_handler = conn_handler, + signature_id = signature_id, + signature_name = signature_name, + omic_signature = omic_signature, + verbose = verbose + ) + prepared <- buildHypeRQueries(inputs, test = test, split = split, score_col = score_col, conn_handler = conn_handler) + + warnSkippedHypeRSignatures(prepared$skipped) + if (base::length(prepared$signatures) == 0) { + base::stop("\nNo signature produced a hypeR query vector; see the warning for each signature's reason.\n") + } + + backgrounds <- resolveQueryBackgrounds(background, prepared$info, inputs, conn_handler) + query_names <- base::names(prepared$signatures) + + results <- base::lapply(base::seq_along(prepared$signatures), function(i) { + if (!quiet && base::length(query_names) > 1) { + base::cat(base::sprintf("\n%s\n", query_names[i])) + } + hyp_obj <- hypeR::hypeR( + signature = prepared$signatures[[i]], + genesets = resolved_genesets, + test = test, + background = backgrounds[[i]], + power = power, + absolute = absolute, + pval = pval, + fdr = fdr, + plotting = plotting, + quiet = quiet + ) + appendHypeRProvenance(hyp_obj, prepared$info[i, , drop = FALSE]) + }) + base::names(results) <- query_names + + if (base::length(results) == 1L) { + return(results[[1]]) + } + + hypeR::multihyp$new(data = results) +} diff --git a/man/runHypeR.Rd b/man/runHypeR.Rd new file mode 100644 index 00000000..b5fd12d8 --- /dev/null +++ b/man/runHypeR.Rd @@ -0,0 +1,127 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypeRClient.R +\name{runHypeR} +\alias{runHypeR} +\title{Run hypeR enrichment on SigRepo signatures} +\usage{ +runHypeR( + conn_handler = NULL, + signature_id = NULL, + signature_name = NULL, + omic_signature = NULL, + genesets, + msigdb_species = NULL, + msigdb_collection = NULL, + msigdb_subcollection = NULL, + msigdb_clean = FALSE, + test = c("hypergeometric", "kstest"), + split = TRUE, + score_col = "score", + background = 23467, + power = 1, + absolute = FALSE, + pval = 1, + fdr = 1, + plotting = FALSE, + quiet = TRUE, + verbose = TRUE +) +} +\arguments{ +\item{conn_handler}{An R object obtained from \code{SigRepo::newConnHandler()}. +Needed to fetch signatures by id/name and for reference-table symbol lookup.} + +\item{signature_id}{One or more SigRepo signature IDs.} + +\item{signature_name}{One or more SigRepo signature names.} + +\item{omic_signature}{An \code{OmicSignature} object or a list of them. List +names, when given, become the query labels.} + +\item{genesets}{Either the string \code{"msigdb"}, or your own genesets: a +named list of character vectors, a \code{hypeR::gsets} object, or a +\code{hypeR::rgsets} object.} + +\item{msigdb_species}{Species for MSigDB, e.g. \code{"Homo sapiens"} or +\code{"Mus musculus"}. Defaults to \code{"Homo sapiens"}. Only valid with +\code{genesets = "msigdb"}.} + +\item{msigdb_collection}{MSigDB collection, e.g. \code{"H"}, \code{"C2"}, +\code{"MH"}. Required with \code{genesets = "msigdb"}.} + +\item{msigdb_subcollection}{Optional MSigDB subcollection, e.g. +\code{"CP:REACTOME"}. Only valid with \code{genesets = "msigdb"}.} + +\item{msigdb_clean}{Logical; clean geneset labels via +\code{hypeR::gsets$new(clean = TRUE)}. Defaults to \code{FALSE}.} + +\item{test}{\code{"hypergeometric"} (a character vector of symbols from the +signature table) or \code{"kstest"} (a named numeric vector ranked by +\code{score_col} from the full difexp table).} + +\item{split}{Logical; for \code{"hypergeometric"}, build one vector per +\code{group_label} (e.g. one per arm of a bi-directional signature). Ignored by +\code{"kstest"}, whose ranked list already carries direction in its sign. +Defaults to \code{TRUE}.} + +\item{score_col}{difexp column used to rank genes for \code{"kstest"}. +Defaults to \code{"score"}.} + +\item{background}{hypeR's background: a single number (population size), a +character vector of background genes, or \code{"difexp"} to use each +signature's measured genes from its difexp table. Signatures without difexp +symbols fall back to \code{23467} with a warning. Defaults to \code{23467}.} + +\item{power}{Exponent for score weights (kstest only). \code{1} (default) +weights hits by score, GSEA-style; \code{0} is the classic unweighted KS +statistic.} + +\item{absolute}{Passed to \code{hypeR::hypeR()} (kstest only). Defaults to \code{FALSE}.} + +\item{pval}{Keep results with p-value at or below this. Defaults to \code{1}.} + +\item{fdr}{Keep results with FDR at or below this. Defaults to \code{1}.} + +\item{plotting}{Logical; generate hypeR's per-geneset plots. Defaults to \code{FALSE}.} + +\item{quiet}{Logical; suppress hypeR's logs. Defaults to \code{TRUE}.} + +\item{verbose}{Logical; print messages while fetching signatures.} +} +\value{ +A \code{hypeR} \code{hyp} object when one query vector is produced, +otherwise a \code{multihyp} named by query. Each \code{hyp$info} ends with +\code{SigRepo Signature ID}, \code{SigRepo Signature Name}, +\code{Group Label} and \code{Symbol Source}. Signatures that cannot produce a +query are skipped with a warning; if none can, an error is raised. +} +\description{ +Builds hypeR query vectors from SigRepo signatures (see +\code{prepareHypeRSignatures()}) and runs \code{hypeR::hypeR()} on them. The +arguments after \code{score_col} are hypeR's own, with hypeR's defaults, and +the result is hypeR's own object, so \code{hypeR::hyp_dots()}, +\code{hyp_show()}, \code{hyp_emap()}, \code{hyp_to_excel()} and +\code{hyp_to_rmd()} work on it directly. +} +\examples{ +\dontrun{ +utils::data("LLFS_Aging_Gene_2023", package = "SigRepo") + +hyp <- SigRepo::runHypeR( + omic_signature = LLFS_Aging_Gene_2023, + genesets = "msigdb", + msigdb_collection = "H", + fdr = 0.05 +) +hypeR::hyp_dots(hyp) + +ranked <- SigRepo::runHypeR( + omic_signature = LLFS_Aging_Gene_2023, + genesets = "msigdb", + msigdb_collection = "H", + test = "kstest", + power = 0 +) +} + +} diff --git a/tests/testthat/test_hypeR_client.R b/tests/testthat/test_hypeR_client.R new file mode 100644 index 00000000..9c0954c3 --- /dev/null +++ b/tests/testthat/test_hypeR_client.R @@ -0,0 +1,100 @@ +test_that("hypergeometric results match a direct hypeR::hypeR() call", { + testthat::skip_if_not_installed("hypeR") + sig <- make_hyper_sig() + vec <- SigRepo::prepareHypeRSignatures(omic_signature = sig, split = FALSE, verbose = FALSE)$signatures[[1]] + + direct <- hypeR::hypeR(vec, hyper_genesets(), test = "hypergeometric") + res <- SigRepo::runHypeR(omic_signature = sig, genesets = hyper_genesets(), split = FALSE, verbose = FALSE) + + expect_true(inherits(res, "hyp")) + expect_equal(res$data, direct$data) +}) + +test_that("kstest results match a direct hypeR::hypeR() call at default power and power = 0", { + testthat::skip_if_not_installed("hypeR") + sig <- make_hyper_sig(difexp = hyper_difexp_table()) + vec <- SigRepo::prepareHypeRSignatures(omic_signature = sig, test = "kstest", verbose = FALSE)$signatures[[1]] + + for (pwr in c(1, 0)) { + direct <- hypeR::hypeR(vec, hyper_genesets(), test = "kstest", power = pwr) + res <- SigRepo::runHypeR(omic_signature = sig, genesets = hyper_genesets(), test = "kstest", power = pwr, verbose = FALSE) + expect_equal(res$data, direct$data) + } +}) + +test_that("split queries return a multihyp with aligned SigRepo provenance", { + testthat::skip_if_not_installed("hypeR") + + res <- SigRepo::runHypeR(omic_signature = make_hyper_sig(), genesets = hyper_genesets(), verbose = FALSE) + + expect_true(inherits(res, "multihyp")) + expect_equal(names(res$data), c("sig_a | Old", "sig_a | Young")) + + provenance_keys <- c("SigRepo Signature ID", "SigRepo Signature Name", "Group Label", "Symbol Source") + for (hyp_obj in res$data) { + expect_equal(utils::tail(names(hyp_obj$info), 4), provenance_keys) + } + expect_equal(res$data[["sig_a | Old"]]$info[["Group Label"]], "Old") + expect_equal(res$data[["sig_a | Old"]]$info[["SigRepo Signature Name"]], "sig_a") + expect_equal(res$data[["sig_a | Old"]]$info[["SigRepo Signature ID"]], "") + expect_equal(res$data[["sig_a | Old"]]$info[["Symbol Source"]], "signature$symbol") +}) + +test_that("hypeR's own plotting and export functions work on the result", { + testthat::skip_if_not_installed("hypeR") + res <- SigRepo::runHypeR(omic_signature = make_hyper_sig(), genesets = hyper_genesets(), verbose = FALSE) + + expect_no_error(hypeR::hyp_dots(res)) + + xlsx <- tempfile(fileext = ".xlsx") + on.exit(unlink(xlsx), add = TRUE) + expect_no_error(hypeR::hyp_to_excel(res, file_path = xlsx)) + expect_true(file.exists(xlsx)) +}) + +test_that("background = \"difexp\" uses each signature's measured genes", { + testthat::skip_if_not_installed("hypeR") + sig <- make_hyper_sig(difexp = hyper_difexp_table()) + + res <- SigRepo::runHypeR(omic_signature = sig, genesets = hyper_genesets(), background = "difexp", verbose = FALSE) + + expect_equal(res$data[["sig_a | Old"]]$info$Background, "5") + expect_equal(res$data[["sig_a | Young"]]$info$Background, "5") +}) + +test_that("background = \"difexp\" falls back to 23467 with a warning when there is no difexp", { + testthat::skip_if_not_installed("hypeR") + + expect_warning( + res <- SigRepo::runHypeR(omic_signature = make_hyper_sig(), genesets = hyper_genesets(), + background = "difexp", split = FALSE, verbose = FALSE), + "no difexp gene symbols for 'sig_a'; used background = 23467", fixed = TRUE + ) + expect_equal(res$info$Background, "23467") +}) + +test_that("unusable signatures are skipped with a warning; all unusable is an error", { + testthat::skip_if_not_installed("hypeR") + bad <- make_hyper_sig("bad", signature = hyper_sig_table(symbols = FALSE)) + + expect_warning( + res <- SigRepo::runHypeR(omic_signature = list(good = make_hyper_sig("good"), bad = bad), + genesets = hyper_genesets(), split = FALSE, verbose = FALSE), + "Skipped 1 signature(s): 'bad' (no_gene_symbols", fixed = TRUE + ) + expect_true(inherits(res, "hyp")) + + expect_error( + suppressWarnings(SigRepo::runHypeR(omic_signature = bad, genesets = hyper_genesets(), verbose = FALSE)), + "No signature produced a hypeR query vector", fixed = TRUE + ) +}) + +test_that("runHypeR requires genesets and rejects the removed arguments", { + testthat::skip_if_not_installed("hypeR") + sig <- make_hyper_sig() + + expect_error(SigRepo::runHypeR(omic_signature = sig, verbose = FALSE), "'genesets' must be \"msigdb\"", fixed = TRUE) + expect_error(SigRepo::runHypeR(omic_signature = sig, genesets = hyper_genesets(), method = "gsea"), "unused argument") + expect_error(SigRepo::runHypeR(omic_signature = sig, genesets = hyper_genesets(), test = "gsea"), "should be one of") +}) From 0d547be6200fa1b374393168f6fc2bae7f48e1bc Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 14:44:09 -0400 Subject: [PATCH 05/61] docs: document the hypeR-native client and its breaking changes Co-Authored-By: Claude Opus 5 (1M context) --- DESCRIPTION | 1 + NEWS.md | 36 ++++++++++++++++++++++++++++++++++++ _pkgdown.yml | 1 + 3 files changed, 38 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index bd332215..3889d9cd 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,6 +40,7 @@ Suggests: fgsea, hypeR, hypeR.GEM, + msigdbr, knitr, pkgdown, rmarkdown, diff --git a/NEWS.md b/NEWS.md index c3bc261d..1a3de0d6 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,39 @@ +# SigRepo (development version) + +## Breaking changes + +`runHypeR()` and `prepareHypeRSignatures()` now follow hypeR's own interface. + +- `runHypeR()` returns hypeR's `hyp` (one query vector) or `multihyp` (several) + instead of `list(result, signatures, metadata)`. Use `hypeR::hyp_dots()`, + `hyp_to_excel()` etc. on it directly. Each `hyp$info` now ends with + `SigRepo Signature ID`, `SigRepo Signature Name`, `Group Label`, `Symbol Source`. +- `method` is now `test = c("hypergeometric", "kstest")`. The `"hypergeo"`, + `"ks"` and `"gsea"` aliases are gone: GSEA-style weighting is + `test = "kstest"` with `power = 1` (the default); `power = 0` is the classic KS test. +- Defaults match `hypeR::hypeR()`: `fdr = 1` (was 0.05), `pval = 1` (new), + `background = 23467`. `background = "difexp"` uses each signature's measured genes. +- `genesets` is required: `genesets = "msigdb"` with `msigdb_collection` + (and optional `msigdb_species`, `msigdb_subcollection`), or your own named + list / `hypeR::gsets` / `hypeR::rgsets`. `msigdb_*` without `"msigdb"` is an error. +- `split_by_group` is now `split` and defaults to `TRUE` (one hypergeometric + vector per `group_label`). `split_by_direction`, `feature_col` and `...` are removed. +- `prepareHypeRSignatures()` returns `list(signatures, info, skipped)`. +- Signatures that cannot produce a query are skipped with a warning instead of + aborting the run. + +## New + +- `getHypeRGenesets()` returns a named, versioned `hypeR::gsets` for MSigDB. + Mouse requests for human collections (e.g. C2, C5) now use ortholog mapping. + +## Fixes + +- Gene symbols resolve from the table's symbol column, then (hypergeometric) + difexp symbols joined on `probe_id`, then the reference table by + `feature_name` and organism. `probe_id` is no longer read as an identifier, + and one signature's symbol column no longer leaks into the next. + # SigRepo 1.0.0 - Documentation: diff --git a/_pkgdown.yml b/_pkgdown.yml index 8fe128fd..f328897d 100755 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -115,6 +115,7 @@ reference: contents: - '`prepareHypeRSignatures`' - '`runHypeR`' + - '`getHypeRGenesets`' - '`runHyperGEM`' - '`hypergemAvailable`' - '`hypergemExport`' From 4963fe146223a60ef17b684e2baf61176a472de7 Mon Sep 17 00:00:00 2001 From: Cvicnaire Date: Mon, 14 Sep 2026 16:13:38 -0400 Subject: [PATCH 06/61] fix: unique query names, safe probe_id join, input validation and zero-weight kstest guard Co-Authored-By: Claude Opus 5 (1M context) --- NEWS.md | 18 +++ R/hypeRClient.R | 96 +++++++++++++++- R/hypeRSignatures.R | 48 +++++++- man/runHypeR.Rd | 17 ++- tests/testthat/helper-hypeR.R | 21 ++++ tests/testthat/test_hypeR_client.R | 150 +++++++++++++++++++++++++ tests/testthat/test_hypeR_signatures.R | 104 +++++++++++++++++ 7 files changed, 443 insertions(+), 11 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1a3de0d6..3c051942 100755 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,12 @@ instead of `list(result, signatures, metadata)`. Use `hypeR::hyp_dots()`, `hyp_to_excel()` etc. on it directly. Each `hyp$info` now ends with `SigRepo Signature ID`, `SigRepo Signature Name`, `Group Label`, `Symbol Source`. + `hyp_to_excel()` uses query names as sheet names (at most 31 characters, no + `: \ / ? * [ ]`), so long signature names need sheet-safe names first: + ```r + names(hyp$data) <- make.unique(substr(gsub("[][\\\\/?*:]", "_", names(hyp$data)), 1, 28)) + hypeR::hyp_to_excel(hyp, file_path = "results.xlsx") + ``` - `method` is now `test = c("hypergeometric", "kstest")`. The `"hypergeo"`, `"ks"` and `"gsea"` aliases are gone: GSEA-style weighting is `test = "kstest"` with `power = 1` (the default); `power = 0` is the classic KS test. @@ -33,6 +39,18 @@ difexp symbols joined on `probe_id`, then the reference table by `feature_name` and organism. `probe_id` is no longer read as an identifier, and one signature's symbol column no longer leaks into the next. +- The `probe_id` join to difexp symbols matches on (`probe_id`, `feature_name`), + so a `probe_id` repeated in difexp no longer hands a row another feature's + symbol. Without `feature_name` it joins on `probe_id` only when that is unique. +- Query names are always unique (`"X | Up"`, `"X | Up (2)"`). +- The kstest ranked list keeps the positive score when a gene's scores tie on + `|score|` with opposite signs, so it no longer depends on difexp row order. +- `runHypeR()` errors on an invalid `background` (e.g. `"Difexp"`); both + functions error on a `split` that is not `TRUE`/`FALSE` and on + `omic_signature` supplied together with `signature_id`/`signature_name`. +- Weighted kstest (`power != 0`) drops, with a warning, genesets whose hits all + have score 0. hypeR cannot score them and would otherwise error or put scores + on the wrong genesets. # SigRepo 1.0.0 diff --git a/R/hypeRClient.R b/R/hypeRClient.R index 6824b2d4..e2039d1a 100644 --- a/R/hypeRClient.R +++ b/R/hypeRClient.R @@ -277,6 +277,60 @@ appendHypeRProvenance <- function(hyp_obj, info_row) { hyp_obj } +#' Error unless background is a single positive number, a gene vector, or "difexp" +#' @noRd +checkHypeRBackground <- function(background) { + is_number <- base::is.numeric(background) && base::length(background) == 1L && + base::is.finite(background) && background > 0 + is_genes <- base::is.character(background) && base::length(background) >= 2L + is_difexp <- base::identical(background, "difexp") + if (!(is_number || is_genes || is_difexp)) { + base::stop("\nbackground must be a number, a gene vector, or \"difexp\".\n") + } + base::invisible(background) +} + +#' Drop genesets a weighted kstest cannot score +#' +#' hypeR's weighted kstest (power != 0) gives an empty score when every hit of +#' a geneset has weight 0, which either errors or silently shifts scores onto +#' other genesets. Drops each geneset whose members present in `query` all have +#' score exactly 0; genesets with no members in `query` are kept. +#' +#' @param genesets Named list, `hypeR::gsets` or `hypeR::rgsets`. +#' @param query Named numeric vector (gene -> score). +#' @return list(genesets = same kind as the input, unchanged when nothing is +#' dropped; dropped = chr labels) +#' @noRd +dropZeroWeightGenesets <- function(genesets, query) { + unchanged <- base::list(genesets = genesets, dropped = base::character()) + zero_genes <- base::names(query)[query == 0] + if (base::length(zero_genes) == 0) { + return(unchanged) + } + nonzero_genes <- base::names(query)[query != 0] + + is_hyper_gsets <- methods::is(genesets, "gsets") || methods::is(genesets, "rgsets") + members <- if (is_hyper_gsets) genesets$genesets else genesets + drop <- base::vapply(members, function(genes) { + base::any(genes %in% zero_genes) && !base::any(genes %in% nonzero_genes) + }, base::logical(1)) + if (!base::any(drop)) { + return(unchanged) + } + + kept_labels <- base::names(members)[!drop] + reduced <- if (methods::is(genesets, "rgsets")) { + genesets$subset(kept_labels) + } else if (methods::is(genesets, "gsets")) { + hypeR::gsets$new(members[!drop], name = genesets$name, version = genesets$version, quiet = TRUE) + } else { + genesets[!drop] + } + + base::list(genesets = reduced, dropped = base::names(members)[drop]) +} + warnSkippedHypeRSignatures <- function(skipped) { if (base::nrow(skipped) == 0) { return(base::invisible(NULL)) @@ -300,15 +354,26 @@ warnSkippedHypeRSignatures <- function(skipped) { #' \code{hyp_show()}, \code{hyp_emap()}, \code{hyp_to_excel()} and #' \code{hyp_to_rmd()} work on it directly. #' +#' \code{hyp_to_excel()} uses each query name as an Excel sheet name, which +#' must be at most 31 characters and cannot contain \code{: \\ / ? * [ ]}. +#' Query names built from long signature names break that, so make the names +#' sheet-safe first: +#' \preformatted{ +#' names(hyp$data) <- make.unique(substr(gsub("[][\\\\\\\\/?*:]", "_", names(hyp$data)), 1, 28)) +#' hypeR::hyp_to_excel(hyp, file_path = "results.xlsx") +#' } +#' #' @inheritParams prepareHypeRSignatures #' @inheritParams getHypeRGenesets #' @param background hypeR's background: a single number (population size), a #' character vector of background genes, or \code{"difexp"} to use each #' signature's measured genes from its difexp table. Signatures without difexp -#' symbols fall back to \code{23467} with a warning. Defaults to \code{23467}. +#' symbols fall back to \code{23467} with a warning. Anything else (e.g. +#' \code{"Difexp"}) is an error. Defaults to \code{23467}. #' @param power Exponent for score weights (kstest only). \code{1} (default) #' weights hits by score, GSEA-style; \code{0} is the classic unweighted KS -#' statistic. +#' statistic. With \code{power != 0}, genesets whose hits in a query all have +#' score 0 cannot be scored and are dropped for that query with a warning. #' @param absolute Passed to \code{hypeR::hypeR()} (kstest only). Defaults to \code{FALSE}. #' @param pval Keep results with p-value at or below this. Defaults to \code{1}. #' @param fdr Keep results with FDR at or below this. Defaults to \code{1}. @@ -320,6 +385,8 @@ warnSkippedHypeRSignatures <- function(skipped) { #' \code{SigRepo Signature ID}, \code{SigRepo Signature Name}, #' \code{Group Label} and \code{Symbol Source}. Signatures that cannot produce a #' query are skipped with a warning; if none can, an error is raised. +#' Query names are unique but can be long; rename them as shown in the +#' description before \code{hypeR::hyp_to_excel()}. #' #' @examples #' \dontrun{ @@ -370,6 +437,8 @@ runHypeR <- function( } test <- base::match.arg(test) + checkHypeRBackground(background) + checkHypeRSplit(split) if (base::missing(genesets)) { genesets <- NULL @@ -399,13 +468,34 @@ runHypeR <- function( backgrounds <- resolveQueryBackgrounds(background, prepared$info, inputs, conn_handler) query_names <- base::names(prepared$signatures) + # Weighted kstest cannot score a geneset whose hits all have score 0 (hypeR + # errors or misaligns scores), so drop those per query before calling hypeR. + query_genesets <- base::lapply(prepared$signatures, function(query) { + if (base::identical(test, "kstest") && power != 0) { + dropZeroWeightGenesets(resolved_genesets, query) + } else { + base::list(genesets = resolved_genesets, dropped = base::character()) + } + }) + dropped <- base::unique(base::unlist(base::lapply(query_genesets, `[[`, "dropped"), use.names = FALSE)) + if (base::length(dropped) > 0) { + base::warning( + base::sprintf( + "Dropped %d geneset(s) whose hits all have score 0 (undefined for weighted kstest, power != 0): %s", + base::length(dropped), + base::paste(c(dropped[base::seq_len(base::min(10L, base::length(dropped)))], if (base::length(dropped) > 10) "..."), collapse = ", ") + ), + call. = FALSE + ) + } + results <- base::lapply(base::seq_along(prepared$signatures), function(i) { if (!quiet && base::length(query_names) > 1) { base::cat(base::sprintf("\n%s\n", query_names[i])) } hyp_obj <- hypeR::hypeR( signature = prepared$signatures[[i]], - genesets = resolved_genesets, + genesets = query_genesets[[i]]$genesets, test = test, background = backgrounds[[i]], power = power, diff --git a/R/hypeRSignatures.R b/R/hypeRSignatures.R index db44fcdf..3041421d 100644 --- a/R/hypeRSignatures.R +++ b/R/hypeRSignatures.R @@ -100,10 +100,23 @@ resolveSignatureSymbols <- function(omic_signature, table = c("signature", "dife difexp_tbl <- omic_signature$difexp difexp_col <- hypeRSymbolColumn(difexp_tbl) if (!base::is.null(difexp_col) && "probe_id" %in% base::colnames(tbl) && "probe_id" %in% base::colnames(difexp_tbl)) { - by_probe <- stats::setNames(cleanHypeRSymbols(difexp_tbl[[difexp_col]]), base::as.character(difexp_tbl$probe_id)) - symbols <- base::unname(by_probe[base::as.character(tbl$probe_id)]) - if (base::any(!base::is.na(symbols))) { - return(base::list(symbols = symbols, source = base::sprintf("difexp$%s via probe_id", difexp_col))) + # A probe_id can repeat in difexp (multi-mapped probes, aptamers), so join + # on (probe_id, feature_name) when both tables have feature_name. Without + # it, join on probe_id only when that key is unique; otherwise a row could + # borrow another feature's symbol, so skip to the reference lookup. + join_key <- if ("feature_name" %in% base::colnames(tbl) && "feature_name" %in% base::colnames(difexp_tbl)) { + function(t) base::paste(base::as.character(t$probe_id), base::as.character(t$feature_name), sep = "\r") + } else if (!base::anyDuplicated(base::as.character(difexp_tbl$probe_id))) { + function(t) base::as.character(t$probe_id) + } else { + NULL + } + if (!base::is.null(join_key)) { + by_key <- stats::setNames(cleanHypeRSymbols(difexp_tbl[[difexp_col]]), join_key(difexp_tbl)) + symbols <- base::unname(by_key[join_key(tbl)]) + if (base::any(!base::is.na(symbols))) { + return(base::list(symbols = symbols, source = base::sprintf("difexp$%s via probe_id", difexp_col))) + } } } } @@ -132,6 +145,13 @@ resolveSignatureSymbols <- function(omic_signature, table = c("signature", "dife base::list(symbols = base::rep(NA_character_, n_rows), source = NA_character_) } +checkHypeRSplit <- function(split) { + if (!(base::is.logical(split) && base::length(split) == 1L && !base::is.na(split))) { + base::stop("\n'split' must be TRUE or FALSE.\n") + } + base::invisible(split) +} + disambiguateHypeRLabels <- function(labels) { used <- base::character() for (i in base::seq_along(labels)) { @@ -150,6 +170,11 @@ disambiguateHypeRLabels <- function(labels) { #' Resolve signatures plus their ids and display labels #' @noRd collectHypeRSignatures <- function(conn_handler, signature_id, signature_name, omic_signature, verbose) { + supplied <- function(x) base::length(x) > 0 && base::any(!x %in% c("", NA)) + if (!base::is.null(omic_signature) && (supplied(signature_id) || supplied(signature_name))) { + base::stop("\nSupply either 'omic_signature' or 'signature_id'/'signature_name', not both.\n") + } + signatures <- resolveHypeRSignatures( conn_handler = conn_handler, signature_id = signature_id, @@ -267,7 +292,9 @@ buildKstestQuery <- function(omic_signature, label, signature_id, score_col, con best <- base::vapply( base::split(scores[keep], resolved$symbols[keep]), - function(x) x[base::which.max(base::abs(x))], + # On an opposite-sign |score| tie keep the positive value, so the result + # does not depend on difexp row order. + function(x) base::max(x[base::abs(x) == base::max(base::abs(x))]), base::numeric(1) ) query <- base::sort(best, decreasing = TRUE) @@ -308,9 +335,17 @@ buildHypeRQueries <- function(inputs, test, split, score_col, conn_handler) { info[[base::length(info) + 1]] <- built$info } + info <- if (base::length(info) > 0) base::do.call(base::rbind, info) else emptyHypeRInfo() + # Labels are unique per signature, but a label can still collide with another + # signature's "