diff --git a/NAMESPACE b/NAMESPACE index 7830efa9..974c0c7a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -70,7 +70,10 @@ export( BStringSetList, DNAStringSetList, RNAStringSetList, AAStringSetList, ## xscat.R: - xscat + xscat, + + ## coloring.R: + update_DNA_palette, update_RNA_palette, update_AA_palette, update_B_palette ) exportMethods( diff --git a/R/coloring.R b/R/coloring.R index 05406fed..f3a5db3c 100644 --- a/R/coloring.R +++ b/R/coloring.R @@ -1,13 +1,6 @@ ### ========================================================================= -### add_colors() +### XString Display Colors ### ------------------------------------------------------------------------- -### -### Nothing in this file is exported. -### - -### Placeholder, initialized in .onLoad() -DNA_AND_RNA_COLORED_LETTERS <- NULL -AA_COLORED_LETTERS <- NULL ### Return a named character vector where all the names are single letters. ### Colors for A, C, G, and T were inspired by @@ -36,28 +29,6 @@ make_DNA_AND_RNA_COLORED_LETTERS <- function() ) } -### 'x' must be a character vector. -.add_dna_and_rna_colors <- function(x) -{ - if (!isTRUE(getOption("Biostrings.coloring", default=FALSE))) - return(x) - ans <- vapply(x, - function(xi) { - xi <- safeExplode(xi) - m <- match(xi, names(DNA_AND_RNA_COLORED_LETTERS)) - match_idx <- which(!is.na(m)) - xi[match_idx] <- DNA_AND_RNA_COLORED_LETTERS[m[match_idx]] - paste0(xi, collapse="") - }, - character(1), - USE.NAMES=FALSE - ) - x_names <- names(x) - if (!is.null(x_names)) - names(ans) <- x_names - ans -} - ### Return a named character vector where all the names are single letters. ### Colors amino acids by similarity ### Colors groupins by @@ -118,16 +89,18 @@ make_AA_COLORED_LETTERS <- function(){ } ### 'x' must be a character vector. -.add_aa_colors <- function(x) +## env_var_name is the name of the corresponding palette in .pkgenv +.add_xstring_colors <- function(x, env_var_name) { if (!isTRUE(getOption("Biostrings.coloring", default=FALSE))) return(x) + color_palette <- get(env_var_name, envir=.pkgenv) ans <- vapply(x, function(xi) { xi <- safeExplode(xi) - m <- match(xi, names(AA_COLORED_LETTERS)) + m <- match(xi, names(color_palette)) match_idx <- which(!is.na(m)) - xi[match_idx] <- AA_COLORED_LETTERS[m[match_idx]] + xi[match_idx] <- color_palette[m[match_idx]] paste0(xi, collapse="") }, character(1), @@ -139,7 +112,71 @@ make_AA_COLORED_LETTERS <- function(){ ans } +.update_X_palette <- function(colors=NULL, env_var_name, + alphabet, default_palette_function){ + ## passing default_palette_function as a function pointer so we don't + ## have to evaluate it unless necessary + palette <- get(env_var_name, envir=.pkgenv) + if(is.null(colors)) + palette <- default_palette_function() + if(!is.null(colors)){ + if(!is.list(colors)){ + stop("'colors' should be NULL or a named list of entries with 'bg' ", + "and optionally 'fg' values.") + } + + n <- names(colors) + if(!is.null(alphabet) && length(setdiff(n, alphabet)) != 0){ + ## non-BStrings: checking if the characters are valid + stop("Invalid codes specified.") + } else if(is.null(alphabet)){ + ## BStrings: checking for single characters (0:255 in raw) + name_nchars <- vapply(n, \(x) length(charToRaw(x)), integer(1L)) + if(!all(name_nchars == 1L)) + stop("Invalid codes specified.") + } + + for(i in seq_along(colors)){ + fg <- colors[[i]]$fg + bg <- colors[[i]]$bg + if(is.null(fg) && is.null(bg)){ + palette[n[i]] <- n[i] + } else if(is.null(bg)) { + palette[n[i]] <- make_style(fg)(n[i]) + } else { + if(is.null(fg)) fg <- rgb(1,1,1) + palette[n[i]] <- make_style(bg, bg=TRUE)(make_style(fg)(n[i])) + } + } + } + + assign(env_var_name, palette, envir=.pkgenv) +} + +update_DNA_palette <- function(colors=NULL){ + .update_X_palette(colors, "DNA_AND_RNA_COLORED_LETTERS", + union(DNA_ALPHABET, RNA_ALPHABET), + make_DNA_AND_RNA_COLORED_LETTERS) +} + +update_RNA_palette <- update_DNA_palette + +update_AA_palette <- function(colors=NULL){ + .update_X_palette(colors, "AA_COLORED_LETTERS", + AA_ALPHABET, + make_AA_COLORED_LETTERS) +} + +update_B_palette <- function(colors=NULL){ + ## BStrings don't have a default palette + ## thus their default palette function is just \() return(character(0L)) + .update_X_palette(colors, "B_COLORED_LETTERS", + NULL, + \(){ character(0L) }) +} + add_colors <- function(x) UseMethod("add_colors") add_colors.default <- identity -add_colors.DNA <- add_colors.RNA <- .add_dna_and_rna_colors -add_colors.AA <- .add_aa_colors +add_colors.DNA <- add_colors.RNA <- function(x){ .add_xstring_colors(x, "DNA_AND_RNA_COLORED_LETTERS") } +add_colors.AA <- function(x){ .add_xstring_colors(x, "AA_COLORED_LETTERS") } +add_colors.B <- function(x) { .add_xstring_colors(x, "B_COLORED_LETTERS") } diff --git a/R/zzz.R b/R/zzz.R index 65e22402..28cabcb0 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,7 @@ ### +.pkgenv <- new.env(parent=emptyenv()) + .onLoad <- function(libname, pkgname) { .Call2("init_DNAlkups", @@ -11,8 +13,11 @@ .Call2("init_AAlkups", AA_STRING_CODEC@enc_lkup, AA_STRING_CODEC@dec_lkup, PACKAGE=pkgname) - DNA_AND_RNA_COLORED_LETTERS <<- make_DNA_AND_RNA_COLORED_LETTERS() - AA_COLORED_LETTERS <<- make_AA_COLORED_LETTERS() + + assign("DNA_AND_RNA_COLORED_LETTERS", make_DNA_AND_RNA_COLORED_LETTERS(), envir=.pkgenv) + assign("AA_COLORED_LETTERS", make_AA_COLORED_LETTERS(), envir=.pkgenv) + assign("B_COLORED_LETTERS", character(0L), envir=.pkgenv) + option_name <- "Biostrings.coloring" if (!(option_name %in% names(.Options))) options(setNames(list(TRUE), option_name)) diff --git a/man/coloring.Rd b/man/coloring.Rd new file mode 100644 index 00000000..de5c94b4 --- /dev/null +++ b/man/coloring.Rd @@ -0,0 +1,119 @@ +\name{coloring} + +\alias{coloring} +\alias{update_X_palette} +\alias{update_DNA_palette} +\alias{update_RNA_palette} +\alias{update_AA_palette} +\alias{update_B_palette} + +\title{XString Display Colors} + +\description{ + \link{XString} objects support custom coloring for display. Users can also set custom color palettes for XString objects using the \code{update_X_palette} functions. +} + +\usage{ +update_DNA_palette(colors=NULL) +update_RNA_palette(colors=NULL) +update_AA_palette(colors=NULL) +update_B_palette(colors=NULL) +} + +\arguments{ + \item{colors}{ + A named list of colors to update, with entries \code{fg} and \code{bg} specifying the foreground and background colors, respectively. Colors can be specified in any way compatible with \code{\link[crayon]{make_style}} from the \code{crayon} package. Defaults to \code{NULL}, which resets the color palette to the default color scheme. See Details and Examples for more information. + } +} + +\details{ + \link{XString} objects support the following default coloring for display. +\itemize{ + \item DNAString: A, C, G, and T are colored red, green, blue, and orange (respectively), N is colored light grey, other ambiguity codes are colored dark grey, and \code{"-+."} have no coloring. + \item RNAString: All bases are colored identically to DNAString. U is colored yellow. + \item AAString: Amino acids are colored according to JalView's Zappo color scheme, representing physicochemical properties. X is colored light grey, other ambiguity codes are colored dark grey, and \code{"*-+."} are not colored. + \item BStrings are not colored. +} + + Users can change the default color scheme of Biostrings with the \code{update_X_palette} family functions. Each function expects a \code{list} with named entries corresponding to the values to update. Each entry can specify \code{'fg'} and \code{'bg'} values, corresponding to the foreground and background colors (respectively). If \code{'fg'} is not specified, it defaults to \code{rgb(1,1,1)} (white). If \code{'bg'} is not specified, it defaults to transparent. + + These functions will only update the values passed, leaving the rest of the colors as-is. For example, calling \code{update_AA_palette(list(A=list(fg="green")))} would update the coloring for \code{A} while leaving all other colors as the default schema. + + To reset all colors to the default palette, call the function with no arguments (\code{NULL}). + + To remove a coloring for a specific value, provide a named entry with value \code{NULL}. For example, \code{update_AA_palette(list(A=NULL))} will remove the coloring for \code{A}. + + \code{update_DNA_palette} and \code{update_RNA_palette} are identical internally, so either function can be used to update colorings for \code{T,U}. + + See the Examples section for more examples of custom colorings. +} + +\value{ + For \code{update_X_palette}, Invisibly returns the new color mapping, consisting of a named character vector. Calling \code{cat} on the return value will print out all letters with their respective coloring. +} + +\author{Aidan Lakshman } + +\seealso{ + \link{XString-class} +} + +\examples{ +## display default colors +DNAString(paste(DNA_ALPHABET, collapse='')) +RNAString(paste(RNA_ALPHABET, collapse='')) +AAString(paste(AA_ALPHABET, collapse='')) +BString(paste(LETTERS, collapse='')) + +## create new palettes +DNA_palette <- list( + A=list(fg="blue",bg="black"), + T=list(fg="red",bg='black'), + G=list(fg='green',bg='black'), + C=list(fg='yellow',bg='black') +) +update_DNA_palette(DNA_palette) +DNAString(paste(DNA_ALPHABET, collapse='')) + +## reset to default palette +update_DNA_palette() +DNAString(paste(DNA_ALPHABET, collapse='')) + +## colors can also be specified with `rgb()` +AA_palette <- list( + A=list(fg="white", bg="purple"), + B=list(fg=rgb(1,1,1), bg='orange') +) +update_AA_palette(AA_palette) +AAString(paste(AA_ALPHABET, collapse='')) + +## remove all coloring for QEG +update_AA_palette(list(Q=NULL, E=NULL, G=NULL)) +AAString(paste(AA_ALPHABET, collapse='')) + +## reset to default +update_AA_palette() +AAString(paste(AA_ALPHABET, collapse='')) + +## We can also add colors to BStrings, +## which are normally not colored + +## if 'fg' is not specified, defaults to rgb(1,1,1) +## if 'bg' is not specified, background is transparent +B_palette <- list( + A=list(bg='green'), + B=list(bg="red"), + C=list(bg='blue'), + D=list(fg="orange"), + E=list(fg="yellow") +) +update_B_palette(B_palette) +BString(paste(LETTERS, collapse='')) + +## can also directly view the changes with cat +cat(update_B_palette(B_palette), '\n') + +## reset to default +update_B_palette() +BString(paste(LETTERS, collapse='')) +} diff --git a/tests/testthat/test-coloring.R b/tests/testthat/test-coloring.R new file mode 100644 index 00000000..1788f10d --- /dev/null +++ b/tests/testthat/test-coloring.R @@ -0,0 +1,107 @@ +## Tests for coloring.R +## - make_DNA_AND_RNA_COLORED_LETTERS +## - make_AA_COLORED_LETTERS +## - update_X_palette (X is one of DNA, RNA, AA, B) + +test_that("coloring works for DNA, RNA, and AA", { + ## not a super important test + make_DNA_AND_RNA_COLORED_LETTERS <- + Biostrings:::make_DNA_AND_RNA_COLORED_LETTERS + make_AA_COLORED_LETTERS <- Biostrings:::make_AA_COLORED_LETTERS + + dna_rna_expected <- c(DNA_BASES, "U", DNA_ALPHABET[-c(1:4,16:18)]) + expect_true(!any(duplicated(make_DNA_AND_RNA_COLORED_LETTERS()))) + expect_equal(sort(names(make_DNA_AND_RNA_COLORED_LETTERS())), + sort(dna_rna_expected)) + + aa_expected <- AA_ALPHABET[-c(27:30)] + expect_true(!any(duplicated(make_AA_COLORED_LETTERS()))) + expect_equal(sort(names(make_AA_COLORED_LETTERS())), sort(aa_expected)) +}) + +test_that("users can update color palettes", { + colored_letter <- \(letter, fg, bg){ + crayon::make_style(bg, bg=TRUE)(crayon::make_style(fg)(letter)) + } + + dnapalette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + aapalette <- get("AA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + bpalette <- get("B_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + + origdna_palette <- Biostrings:::make_DNA_AND_RNA_COLORED_LETTERS() + origaa_palette <- Biostrings:::make_AA_COLORED_LETTERS() + origb_palette <- character(0L) + + ## check initialization + expect_identical(dnapalette, origdna_palette) + expect_identical(aapalette, origaa_palette) + expect_identical(bpalette, origb_palette) + + ## check DNA update + DNA_palette <- list( + A=list(fg="blue",bg="black"), + T=list(fg="red",bg='black'), + G=list(fg='green',bg='black'), + C=list(fg='yellow',bg='black') + ) + update_DNA_palette(DNA_palette) + + dnapalette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(dnapalette[c("A","T","G","C")], + c(A=colored_letter("A", "blue", "black"), + T=colored_letter("T", "red", "black"), + G=colored_letter("G", "green", "black"), + C=colored_letter("C", "yellow", "black"))) + update_DNA_palette() + dnapalette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(dnapalette, origdna_palette) + + ## Check AA update + AA_palette <- list( + A=list(fg="white", bg="purple"), + B=list(fg=rgb(1,1,1), bg='orange') + ) + update_AA_palette(AA_palette) + aapalette <- get("AA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(aapalette[c("A","B")], + c(A=colored_letter("A","white","purple"), + B=colored_letter("B", rgb(1,1,1), "orange"))) + update_AA_palette() + aapalette <- get("AA_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(aapalette, origaa_palette) + + B_palette <- list( + A=list(bg='green'), + B=list(bg="red"), + C=list(bg='blue'), + D=list(fg="orange"), + E=list(fg="yellow") + ) + update_B_palette(B_palette) + bpalette <- get("B_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(bpalette[c("A","B","C","D","E")], + c(A=colored_letter("A", rgb(1,1,1), "green"), + B=colored_letter("B", rgb(1,1,1), "red"), + C=colored_letter("C", rgb(1,1,1), "blue"), + D=crayon::make_style("orange")("D"), + E=crayon::make_style("yellow")("E"))) + + multibyte_char_palette <- list() + multibyte_char_palette[[rawToChar(as.raw(239L))]] <- list(fg="red") + expect_no_condition(update_B_palette(multibyte_char_palette)) + + update_B_palette() + bpalette <- get("B_COLORED_LETTERS", envir=Biostrings:::.pkgenv) + expect_identical(bpalette, origb_palette) + + ## sad path testing + expect_error(update_DNA_palette(list(E=list(fg="yellow"))), + "Invalid codes specified.") + expect_error(update_AA_palette(list(test=list(fg="yellow"))), + "Invalid codes specified.") + expect_error(update_B_palette(list(test=list(fg="yellow"))), + "Invalid codes specified.") + expect_error(update_DNA_palette(10), "should be NULL or a named list") + expect_error(update_AA_palette(10), "should be NULL or a named list") + expect_error(update_B_palette(10), "should be NULL or a named list") +}) diff --git a/tests/testthat/test-miscellaneous.R b/tests/testthat/test-miscellaneous.R index c7c571eb..12127b98 100644 --- a/tests/testthat/test-miscellaneous.R +++ b/tests/testthat/test-miscellaneous.R @@ -2,22 +2,6 @@ ## these are all relatively low priority and/or for files with only a few things ## some tests are just for internal functions -test_that("coloring works for DNA, RNA, and AA", { - ## not a super important test - make_DNA_AND_RNA_COLORED_LETTERS <- - Biostrings:::make_DNA_AND_RNA_COLORED_LETTERS - make_AA_COLORED_LETTERS <- Biostrings:::make_AA_COLORED_LETTERS - - dna_rna_expected <- c(DNA_BASES, "U", DNA_ALPHABET[-c(1:4,16:18)]) - expect_true(!any(duplicated(make_DNA_AND_RNA_COLORED_LETTERS()))) - expect_equal(sort(names(make_DNA_AND_RNA_COLORED_LETTERS())), - sort(dna_rna_expected)) - - aa_expected <- AA_ALPHABET[-c(27:30)] - expect_true(!any(duplicated(make_AA_COLORED_LETTERS()))) - expect_equal(sort(names(make_AA_COLORED_LETTERS())), sort(aa_expected)) -}) - test_that("utils functions work as they should", { expect_true(Biostrings:::isNumericOrNAs(NA_character_)) expect_true(Biostrings:::isNumericOrNAs(NA_real_))