Use placeholder variable names in GRN model formulas

R/grn.R

@@ -337,42 +337,31 @@ fit_grn_models.GRNData <- function(
             ) %>%
             rename('tf'=1, 'corr'=2)
 
-        # Filter TFs and make formula string
-        frml_string <- map(names(gene_peak_tfs), function(p){
-            peak_tfs <- gene_peak_tfs[[p]]
-            peak_tfs <- peak_tfs[peak_tfs%in%tfs_use]
-            if (length(peak_tfs)==0){
-                return()
-            }
-            peak_name <- str_replace_all(p, '-', '_')
-            tf_name <- str_replace_all(peak_tfs, '-', '_')
-            formula_str <- paste(
-                paste(peak_name, interaction_term, tf_name, sep=' '), collapse = ' + ')
-            return(list(tfs=peak_tfs, frml=formula_str))
-        })
-        frml_string <- frml_string[!map_lgl(frml_string, is.null)]
-        if (length(frml_string)==0){
+        # Filter TFs for each peak
+        peak_tfs_use <- map(gene_peak_tfs, function(tfs) tfs[tfs%in%tfs_use])
+        peak_tfs_use <- peak_tfs_use[lengths(peak_tfs_use) > 0]
+        if (length(peak_tfs_use)==0){
             log_message('Warning: No valid peak:TF pairs found for ', g, verbose=verbose==2)
             return()
         }
 
-        target <- str_replace_all(g, '-', '_')
-        model_frml <- as.formula(
-            paste0(target, ' ~ ', paste0(map(frml_string, function(x) x$frml),  collapse=' + '))
+        # Make formula and model matrix
+        model_input <- build_model_input(
+            target = g,
+            peak_tfs = peak_tfs_use,
+            gene_data = gene_data,
+            peak_x = peak_x,
+            gene_groups = gene_groups,
+            term = interaction_term,
+            scale = scale
         )
-
-        # Get expression data
-        nfeats <- sum(map_dbl(frml_string, function(x) length(x$tfs)))
-        gene_tfs <- purrr::reduce(map(frml_string, function(x) x$tfs), union)
-        gene_x <- gene_data[gene_groups, union(g, gene_tfs), drop=FALSE]
-        model_mat <- as.data.frame(cbind(gene_x, peak_x))
-        if (scale) model_mat <- as.data.frame(scale(as.matrix(model_mat)))
-        colnames(model_mat) <- str_replace_all(colnames(model_mat), '-', '_')
+        var_names <- model_input$var_names
+        nfeats <- model_input$nfeats
 
         log_message('Fitting model with ', nfeats, ' variables for ', g, verbose=verbose==2)
         result <- try(fit_model(
-            model_frml,
-            data = model_mat,
+            model_input$formula,
+            data = model_input$data,
             method = method,
             ...
         ), silent=TRUE)
@@ -381,6 +370,7 @@ fit_grn_models.GRNData <- function(
             log_message(result, verbose=verbose==2)
             return()
         } else {
+            result$coefs <- decode_model_terms(result$coefs, var_names)
             result$gof$nvariables <- nfeats
             result$corr <- tf_g_corr_df
             return(result)
@@ -423,11 +413,110 @@ fit_grn_models.GRNData <- function(
 
 
 
+#' Placeholder variable names for model formulas
+#'
+#' @param target Name of the target gene.
+#' @param regions Character vector with region names.
+#' @param tfs Character vector with TF names.
+#'
+#' @return A named character vector mapping original names to syntactic
+#' placeholders (\code{target}, \code{region1}, ..., \code{tf1}, ...).
+#' @noRd
+model_var_names <- function(target, regions, tfs){
+    var_names <- c(
+        setNames('target', target),
+        setNames(paste0('region', seq_along(regions)), regions),
+        setNames(paste0('tf', seq_along(tfs)), tfs)
+    )
+    dup <- unique(names(var_names)[duplicated(names(var_names))])
+    if (length(dup) > 0){
+        stop('Gene and region names must be distinct, found duplicates: ', paste(dup, collapse=', '))
+    }
+    return(var_names)
+}
+
+
+#' Make model formula and data with placeholder variable names
+#'
+#' Gene and region names are not always valid R symbols (e.g. 'if', 'Su(H)',
+#' '18w' or dm6 regions like '3R-100-200'), so the formula and model matrix
+#' use placeholder names which are mapped back by \code{decode_model_terms()}.
+#'
+#' @param target Name of the target gene.
+#' @param peak_tfs Named list with TFs (values) for each region (names).
+#' @param gene_data Matrix with gene expression (observations x genes).
+#' @param peak_x Matrix with region accessibility (observations x regions).
+#' All columns are added to the model matrix.
+#' @param gene_groups Rows of \code{gene_data} matching the rows of \code{peak_x}.
+#' @param term Interaction term between regions and TFs.
+#' @param scale Logical, whether to scale the model matrix.
+#'
+#' @return A list with \code{formula}, \code{data}, \code{var_names} and
+#' \code{nfeats} (number of region-TF pairs).
+#' @noRd
+build_model_input <- function(
+    target,
+    peak_tfs,
+    gene_data,
+    peak_x,
+    gene_groups = seq_len(nrow(gene_data)),
+    term = ':',
+    scale = FALSE
+){
+    gene_tfs <- purrr::reduce(peak_tfs, union)
+    var_names <- model_var_names(target, colnames(peak_x), gene_tfs)
+    frml_terms <- purrr::map2_chr(names(peak_tfs), peak_tfs, function(p, tfs){
+        paste(var_names[p], term, var_names[tfs], sep=' ', collapse=' + ')
+    })
+    model_frml <- as.formula(
+        paste0(var_names[target], ' ~ ', paste0(frml_terms, collapse=' + '))
+    )
+
+    gene_x <- gene_data[gene_groups, union(target, gene_tfs), drop=FALSE]
+    model_mat <- as.data.frame(cbind(gene_x, peak_x))
+    if (scale) model_mat <- as.data.frame(scale(as.matrix(model_mat)))
+    colnames(model_mat) <- var_names[colnames(model_mat)]
+
+    return(list(
+        formula = model_frml,
+        data = model_mat,
+        var_names = var_names,
+        nfeats = sum(lengths(peak_tfs))
+    ))
+}
+
+
+#' Map placeholder names in model terms back to original names
+#'
+#' @param coefs A data frame with a \code{term} column.
+#' @param var_names Named character vector from \code{model_var_names()}.
+#'
+#' @return The data frame with \code{tf} and \code{region} columns added and
+#' placeholders in \code{term} replaced by the original names.
+#' @noRd
+decode_model_terms <- function(coefs, var_names){
+    lookup <- setNames(names(var_names), var_names)
+    coefs$tf <- unname(lookup[str_extract(coefs$term, '\\btf\\d+\\b')])
+    coefs$region <- unname(lookup[str_extract(coefs$term, '\\bregion\\d+\\b')])
+    # Keep unknown placeholders as they are instead of turning the term into NA
+    coefs$term <- str_replace_all(
+        coefs$term, '\\b(tf|region)\\d+\\b', function(x) ifelse(is.na(lookup[x]), x, lookup[x])
+    )
+    return(coefs)
+}
+
+
 #' Format network coefficients
 #'
 #' @import stringr
 #'
-#' @param coefs A data frame with coefficients
+#' @param coefs A data frame with coefficients. If it already contains
+#' \code{tf} and \code{region} columns (as produced by \code{infer_grn()}),
+#' these are used as they are and \code{term} is not parsed. Otherwise TF and
+#' region are parsed from \code{term}, assuming regions named like
+#' \code{chr1_100_200} and '-' replaced by '_' in all names.
+#' @param term Interaction term between regions and TFs.
+#' @param adjust_method Method for p-value adjustment, see \code{p.adjust()}.
 #'
 #' @return A data frame.
 #'
@@ -442,6 +531,14 @@ format_coefs <- function(coefs, term=':', adjust_method='fdr'){
         coefs$padj <- p.adjust(coefs$pval, method=adjust_method)
     }
 
+    # TFs and regions were already decoded from placeholder names
+    if (all(c('tf', 'region') %in% colnames(coefs))){
+        coefs_use <- coefs %>%
+            filter(!term%in%c('(Intercept)', 'Intercept')) %>%
+            select(tf, target, region, term, everything())
+        return(coefs_use)
+    }
+
     region_pattern <- '[\\d\\w]+_\\d+_\\d+'
 
     # Escape the interaction term for use in a regex (e.g. '+' is a quantifier)

tests/testthat/test_model_names.R

@@ -0,0 +1,138 @@
+context('Tests for placeholder variable names in model formulas')
+
+library(testthat)
+library(Pando)
+
+
+# Names which are not valid R symbols: reserved words, parentheses, colons,
+# leading digits (e.g. dm6 chromosomes '3R') and underscores
+target <- 'if'
+regions <- c('3R-100-200', '2L-5-50', 'chr1-1-9')
+tfs <- c('Su(H)', 'lncRNA:CR1', '18w', 'Abd-B', 'ey_1')
+
+set.seed(1)
+n <- 60
+gene_data <- matrix(rnorm(n*7), n, dimnames=list(NULL, c(target, tfs, 'other')))
+peak_x <- matrix(runif(n*3), n, dimnames=list(NULL, regions))
+gene_data[, target] <- 2*peak_x[, 1]*gene_data[, 'Su(H)'] + rnorm(n, sd=0.1)
+
+# 'Su(H)' is shared by two regions, so glm orders some terms as 'tf:region'
+peak_tfs <- list(
+    `3R-100-200` = c('Su(H)', 'lncRNA:CR1'),
+    `2L-5-50` = c('18w', 'Abd-B', 'ey_1', 'Su(H)')
+)
+pairs <- c(
+    '3R-100-200 Su(H)', '3R-100-200 lncRNA:CR1', '2L-5-50 18w',
+    '2L-5-50 Abd-B', '2L-5-50 ey_1', '2L-5-50 Su(H)'
+)
+
+fit_and_decode <- function(method, term, peak_tfs_use=peak_tfs){
+    input <- Pando:::build_model_input(target, peak_tfs_use, gene_data, peak_x, term=term)
+    fit <- Pando:::fit_model(input$formula, data=input$data, method=method)
+    coefs <- Pando:::decode_model_terms(fit$coefs, input$var_names)
+    format_coefs(cbind(target=target, coefs), term=term)
+}
+
+methods <- c('glm', 'glmnet', 'cv.glmnet', 'xgb')
+method_pkgs <- c(glm='stats', glmnet='glmnet', cv.glmnet='glmnet', xgb='xgboost')
+
+
+test_that('model_var_names gives unique syntactic names.', {
+    var_names <- Pando:::model_var_names(target, regions, tfs)
+    expect_equal(names(var_names), c(target, regions, tfs))
+    expect_equal(unname(make.names(var_names)), unname(var_names))
+    expect_false(any(duplicated(var_names)))
+})
+
+test_that('model_var_names fails on a gene named like a region.', {
+    expect_error(Pando:::model_var_names('chr1-5-9', 'chr1-5-9', 'A'), 'chr1-5-9')
+})
+
+test_that('build_model_input makes a valid formula and model matrix.', {
+    input <- Pando:::build_model_input(target, peak_tfs, gene_data, peak_x, term=':')
+    expect_equal(input$nfeats, 6)
+    expect_equal(all.vars(input$formula)[1], 'target')
+    expect_true(all(all.vars(input$formula) %in% colnames(input$data)))
+    expect_false(anyNA(colnames(input$data)))
+    # All regions are in the model matrix, genes without TF role are not
+    expect_equal(ncol(input$data), 1 + 5 + 3)
+    expect_false('other' %in% names(input$var_names))
+    # Data columns keep their values under the new names
+    expect_equal(input$data$target, unname(gene_data[, target]))
+    expect_equal(input$data[[input$var_names['3R-100-200']]], unname(peak_x[, '3R-100-200']))
+})
+
+test_that('decode_model_terms maps placeholders back to original names.', {
+    var_names <- Pando:::model_var_names(target, regions, c(tfs, paste0('X', 1:5)))
+    coefs <- data.frame(
+        term = c('(Intercept)', 'region1:tf1', 'tf2:region1', 'region2', 'tf5', 'region2:tf10'),
+        estimate = 1:6
+    )
+    dec <- Pando:::decode_model_terms(coefs, var_names)
+    expect_equal(dec$tf, c(NA, 'Su(H)', 'lncRNA:CR1', NA, 'ey_1', 'X5'))
+    expect_equal(dec$region, c(NA, '3R-100-200', '3R-100-200', '2L-5-50', NA, '2L-5-50'))
+    expect_equal(dec$term[2:3], c('3R-100-200:Su(H)', 'lncRNA:CR1:3R-100-200'))
+})
+
+test_that('decode_model_terms keeps unknown placeholders in term.', {
+    var_names <- Pando:::model_var_names(target, regions[1], tfs[1])
+    dec <- Pando:::decode_model_terms(data.frame(term='region1:tf9'), var_names)
+    expect_equal(dec$term, '3R-100-200:tf9')
+    expect_true(is.na(dec$tf))
+})
+
+test_that('interaction models decode to the expected region-TF pairs.', {
+    for (method in methods){
+        skip_if_not_installed(method_pkgs[[method]])
+        coefs <- fit_and_decode(method, ':')
+        # xgb reports feature gain instead of an estimate
+        coefs$value <- if ('estimate' %in% colnames(coefs)) coefs$estimate else coefs$gain
+        coefs <- coefs[coefs$value != 0, ]
+        expect_false(any(c('(Intercept)', 'Intercept') %in% coefs$term), info=method)
+        expect_true(all(coefs$target == target), info=method)
+        expect_false(anyNA(coefs$tf) || anyNA(coefs$region), info=method)
+        expect_true(all(paste(coefs$region, coefs$tf) %in% pairs), info=method)
+        if (method == 'glm'){
+            expect_setequal(paste(coefs$region, coefs$tf), pairs)
+        }
+        # The true effect is recovered under its original names
+        top <- coefs[which.max(abs(coefs$value)), ]
+        expect_equal(c(top$region, top$tf), c('3R-100-200', 'Su(H)'), info=method)
+    }
+})
+
+test_that('main effects and interactions are split correctly for "*".', {
+    for (method in c('glm', 'xgb')){
+        skip_if_not_installed(method_pkgs[[method]])
+        coefs <- fit_and_decode(method, '*')
+        inter <- grepl(':', gsub('lncRNA:CR1', '', coefs$term, fixed=TRUE))
+        expect_false(anyNA(coefs$tf[inter]) || anyNA(coefs$region[inter]), info=method)
+        expect_true(all(xor(is.na(coefs$tf[!inter]), is.na(coefs$region[!inter]))), info=method)
+        expect_true(all(coefs$tf %in% c(tfs, NA)), info=method)
+        expect_true(all(coefs$region %in% c(regions, NA)), info=method)
+    }
+})
+
+test_that('additive models give rows with either TF or region.', {
+    coefs <- fit_and_decode('glm', '+')
+    expect_true(all(xor(is.na(coefs$tf), is.na(coefs$region))))
+    expect_setequal(na.omit(coefs$tf), c('Su(H)', 'lncRNA:CR1', '18w', 'Abd-B', 'ey_1'))
+    expect_setequal(na.omit(coefs$region), c('3R-100-200', '2L-5-50'))
+})
+
+test_that('a single region with a single TF works.', {
+    coefs <- fit_and_decode('glm', ':', peak_tfs_use=list(`3R-100-200`='Su(H)'))
+    expect_equal(nrow(coefs), 1)
+    expect_equal(c(coefs$tf, coefs$region, coefs$term), c('Su(H)', '3R-100-200', '3R-100-200:Su(H)'))
+})
+
+test_that('format_coefs still parses terms without tf/region columns.', {
+    coefs <- data.frame(
+        target = 'Gata',
+        term = c('(Intercept)', 'chr1_1_9:Abd_B'),
+        estimate = c(0, 1)
+    )
+    res <- format_coefs(coefs)
+    expect_equal(res$tf, 'Abd-B')
+    expect_equal(res$region, 'chr1-1-9')
+})