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

@@ -2,13 +2,9 @@
 ### add_colors()
 ### -------------------------------------------------------------------------
 ###
-### Nothing in this file is exported.
+### Only update_X_palette() methods are 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
 ###   https://en.wikipedia.org/wiki/Nucleotide#Structure
@@ -41,12 +37,13 @@ make_DNA_AND_RNA_COLORED_LETTERS <- function()
 {
     if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
         return(x)
+    color_palette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=.pkgenv)
     ans <- vapply(x,
         function(xi) {
             xi <- safeExplode(xi)
-            m <- match(xi, names(DNA_AND_RNA_COLORED_LETTERS))
+            m <- match(xi, names(color_palette))
             match_idx <- which(!is.na(m))
-            xi[match_idx] <- DNA_AND_RNA_COLORED_LETTERS[m[match_idx]]
+            xi[match_idx] <- color_palette[m[match_idx]]
             paste0(xi, collapse="")
         },
         character(1),
@@ -122,12 +119,37 @@ make_AA_COLORED_LETTERS <- function(){
 {
     if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
         return(x)
+    color_palette <- get("AA_COLORED_LETTERS", envir=.pkgenv)
+    ans <- vapply(x,
+        function(xi) {
+            xi <- safeExplode(xi)
+            m <- match(xi, names(color_palette))
+            match_idx <- which(!is.na(m))
+            xi[match_idx] <- color_palette[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
+}
+
+### BString Colors
+### by default, no coloring, but will allow users to set their own palettes
+.add_bstring_colors <- function(x)
+{
+    if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
+        return(x)
+    color_palette <- get("BSTRING_COLORED_LETTERS", 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 +161,103 @@ make_AA_COLORED_LETTERS <- function(){
     ans
 }
 
+update_DNA_palette <- function(colors=NULL){
+    palette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=.pkgenv)
+    if(is.null(colors))
+        palette <- make_DNA_AND_RNA_COLORED_LETTERS()
+    if(!is.null(colors)){
+        if(!is.list(colors)){
+            error("'colors' should be NULL or a list of entries with 'bg' ",
+                    "and optionally 'fg' values.")
+        }
+        all_bases <- union(DNA_ALPHABET, RNA_ALPHABET)
+        if(length(setdiff(names(colors), all_bases)) != 0){
+            error("Invalid DNA/RNA codes specified.")
+        }
+
+        n <- names(colors)
+        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("DNA_AND_RNA_COLORED_LETTERS", palette, envir=.pkgenv)
+}
+
+update_RNA_palette <- update_DNA_palette
+
+update_AA_palette <- function(colors=NULL){
+    palette <- get("AA_COLORED_LETTERS", envir=.pkgenv)
+    if(is.null(colors))
+        palette <- make_AA_COLORED_LETTERS()
+
+    if(!is.null(colors)){
+        if(!is.list(colors)){
+            error("'colors' should be NULL or a list of entries with 'bg' ",
+                    "and optionally 'fg' values.")
+        }
+
+        if(length(setdiff(names(colors), AA_ALPHABET)) != 0){
+            error("Invalid AA codes specified.")
+        }
+
+        n <- names(colors)
+        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("AA_COLORED_LETTERS", palette, envir=.pkgenv)
+}
+
+update_B_palette <- function(colors=NULL){
+    palette <- get("BSTRING_COLORED_LETTERS", envir=.pkgenv)
+    if(is.null(colors))
+        palette <- character(0L)
+    if(!is.null(colors)){
+        if(!is.list(colors)){
+            error("'colors' should be NULL or a list of entries with 'bg' ",
+                    "and optionally 'fg' values.")
+        }
+
+        n <- names(colors)
+        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("BSTRING_COLORED_LETTERS", palette, envir=.pkgenv)
+}
+
 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.B <- .add_bstring_colors

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("BSTRING_COLORED_LETTERS", character(0L), envir=.pkgenv)
+
     option_name <- "Biostrings.coloring"
     if (!(option_name %in% names(.Options)))
         options(setNames(list(TRUE), option_name))

man/update_X_palette.Rd

@@ -0,0 +1,108 @@
+\name{update_X_palette}
+
+\alias{update_DNA_palette}
+\alias{update_RNA_palette}
+\alias{update_AA_palette}
+\alias{update_B_palette}
+
+\title{Update XString Display Colors}
+
+\description{
+  Functions to set custom user color palettes for displaying \code{XString} objects.
+}
+
+\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{
+  These functions allow users to change the default color scheme of Biostrings. 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 no elements. 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{
+  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=''))
+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=''))
+}

tests/testthat/test-miscellaneous.R

@@ -18,6 +18,77 @@ test_that("coloring works for DNA, RNA, and AA", {
     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("BSTRING_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("BSTRING_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")))
+    update_B_palette()
+    bpalette <- get("BSTRING_COLORED_LETTERS", envir=Biostrings:::.pkgenv)
+    expect_identical(bpalette, origb_palette)
+})
+
 test_that("utils functions work as they should", {
     expect_true(Biostrings:::isNumericOrNAs(NA_character_))
     expect_true(Biostrings:::isNumericOrNAs(NA_real_))