From 6fd64b83ffd430fbbcb1e9cd880c60bd9acfe860 Mon Sep 17 00:00:00 2001 From: dtm2451 Date: Wed, 17 Apr 2024 11:47:46 -0400 Subject: [PATCH] allow custom functions for discrete color.var-data --- R/dittoHex.R | 86 +++++++++++++++++++++++++++++++++++-------------- man/dittoHex.Rd | 2 ++ 2 files changed, 63 insertions(+), 25 deletions(-) diff --git a/R/dittoHex.R b/R/dittoHex.R index 8189103..97d1f2e 100644 --- a/R/dittoHex.R +++ b/R/dittoHex.R @@ -171,6 +171,7 @@ dittoDimHex <- function( color.var = NULL, bins = 30, color.method = NULL, + color.method.out.is.numeric = NA, reduction.use = .default_reduction(object), dim.1 = 1, dim.2 = 2, @@ -252,7 +253,7 @@ dittoDimHex <- function( # Make dataframes and plot p.df <- dittoScatterHex( object, xdat$embeddings, ydat$embeddings, color.var, bins, - color.method, split.by, + color.method, color.method.out.is.numeric, split.by, extra.vars, cells.use, color.panel, colors, multivar.split.dir, split.nrow, split.ncol, split.adjust, NA, NA, NA, NA, NA, NA, assay, slot, adjustment, assay.extra, slot.extra, adjustment.extra, @@ -297,6 +298,7 @@ dittoScatterHex <- function( color.var = NULL, bins = 30, color.method = NULL, + color.method.out.is.numeric = NA, split.by = NULL, extra.vars = NULL, cells.use = NULL, @@ -372,25 +374,56 @@ dittoScatterHex <- function( # Parse coloring methods color_by_var <- FALSE - discrete_disp <- FALSE discrete_data <- FALSE + color_method_valid <- FALSE if (!is.null(color.var)) { color_by_var <- TRUE + # Check for discrete data of unfilled color.method first, to capture known options if (!is.numeric(data$color)) { discrete_data <- TRUE - - if (!any(c("max.prop", paste0("prop.", unique(data$color))) %in% color.method)) { - discrete_disp <- TRUE + if (identical(NA, color.method) || identical(NULL, color.method) || color.method=="max") { + color.method <- "max" + color_method_valid <- TRUE + color.method.out.is.numeric <- FALSE + } else if (color.method %in% c("max.prop", paste0("prop.", unique(data$color)))) { + color_method_valid <- TRUE + color.method.out.is.numeric <- TRUE } + } else if (identical(NA, color.method) || identical(NULL, color.method)) { + color.method <- "median" + color_method_valid <- TRUE + color.method.out.is.numeric <- TRUE } - - if (is.null(color.method)) { - color.method <- ifelse(discrete_data, "max", "median") + # + if (!color_method_valid && exists(color.method, mode='function')) { + color_method_valid <- TRUE + if (identical(NA, color.method.out.is.numeric)) { + color.method.out.is.numeric <- tryCatch( + { + out <- get(color.method)(head(data$color, 50)) + if (is.na(out)) stop("'get(color.method)(head(data$color, 50))' yielded NA.") + is.numeric(out) + }, + error = function(e) { + warning("Automatic determination of 'color.method'-function's output type has failed. ", + "\nThe problem could lay in the function itself, or in the determination methodology.", + "\nATTEMPTING plotting by assumming output is numeric.", + "\nTo avoid this warning, or if this assumption is incorrect, set 'color.method.out.is.numeric' to TRUE or FALSE, respectively.", + "\nDetermination failed with error:", e) + TRUE + } + ) + } } - .check_color.method(color.method, discrete_disp) + if (!color_method_valid) { + stop("'color.method' not valid. It must be the name of a function or, for discrete data only, \"max\", \"max.prop\", or \"prop.\".") + } + } else { + # Density displayed via color + color.method.out.is.numeric <- TRUE } # Set titles if "make" @@ -414,7 +447,7 @@ dittoScatterHex <- function( # Make the plot p <- .ditto_scatter_hex( - data, bins, color_by_var, discrete_disp, color.method, color.panel, colors, + data, bins, color_by_var, !color.method.out.is.numeric, color.method, color.panel, colors, min.density, max.density, min.color, max.color, min.opacity, max.opacity, min, max, xlab, ylab, main, sub, theme, legend.show, @@ -532,7 +565,10 @@ dittoScatterHex <- function( geom.args$funs <- c( fxn_c = if (color.method == "max") { function(x) names(which.max(table(x))) - }, fxn_d = length) + } else { + color.method + }, + fxn_d = length) p <- p + scale_fill_manual( name = legend.color.title, @@ -542,7 +578,7 @@ dittoScatterHex <- function( geom.args$funs <- c( fxn_c = if (color.method == "max.prop") { - function(x) max(table(x)/length(x)) + function(x) max(table(x))/length(x) } else if (grepl("^prop.", color.method)) { function(x) { lev <- substr(color.method, 6, nchar(color.method)) @@ -578,17 +614,17 @@ dittoScatterHex <- function( p } -.check_color.method <- function(color.method, discrete) { - - valid <- FALSE - if (discrete) { - valid <- color.method == "max" - } else { - valid <- color.method == "max.prop" || grepl("^prop.", color.method) || exists(color.method, mode='function') - } - - if (!valid) { - stop("'color.method' not valid. Must be \"max\", \"max.prop\", or \"prop.\" (discrete data) or the name of a function (continuous data)") - } -} +# .check_color.method <- function(color.method, discrete) { +# +# valid <- FALSE +# if (discrete) { +# valid <- color.method == "max" +# } else { +# valid <- color.method == "max.prop" || grepl("^prop.", color.method) || exists(color.method, mode='function') +# } +# +# if (!valid) { +# stop("'color.method' not valid. Must be \"max\", \"max.prop\", or \"prop.\" (discrete data) or the name of a function (continuous data)") +# } +# } diff --git a/man/dittoHex.Rd b/man/dittoHex.Rd index a694de4..a7aa001 100644 --- a/man/dittoHex.Rd +++ b/man/dittoHex.Rd @@ -11,6 +11,7 @@ dittoDimHex( color.var = NULL, bins = 30, color.method = NULL, + color.method.out.is.numeric = NA, reduction.use = .default_reduction(object), dim.1 = 1, dim.2 = 2, @@ -77,6 +78,7 @@ dittoScatterHex( color.var = NULL, bins = 30, color.method = NULL, + color.method.out.is.numeric = NA, split.by = NULL, extra.vars = NULL, cells.use = NULL,