feat: Allow custom color palettes for XString objects

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(

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") }

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))

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 <[email protected]>}
+
+\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=''))
+}