Skip to content

Commit 5c366ec

Browse files
ahl27ahl27
committed
Refactor to remove lots of duplicated code
1 parent 2e66337 commit 5c366ec

File tree

3 files changed

+42
-126
lines changed

3 files changed

+42
-126
lines changed

‎R/coloring.R‎

Lines changed: 38 additions & 123 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
### =========================================================================
2-
### add_colors()
2+
### XString Display Colors
33
### -------------------------------------------------------------------------
44
###
55
### Only update_X_palette() methods are exported
@@ -32,29 +32,6 @@ make_DNA_AND_RNA_COLORED_LETTERS <- function()
3232
)
3333
}
3434

35-
### 'x' must be a character vector.
36-
.add_dna_and_rna_colors <- function(x)
37-
{
38-
if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
39-
return(x)
40-
color_palette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=.pkgenv)
41-
ans <- vapply(x,
42-
function(xi) {
43-
xi <- safeExplode(xi)
44-
m <- match(xi, names(color_palette))
45-
match_idx <- which(!is.na(m))
46-
xi[match_idx] <- color_palette[m[match_idx]]
47-
paste0(xi, collapse="")
48-
},
49-
character(1),
50-
USE.NAMES=FALSE
51-
)
52-
x_names <- names(x)
53-
if (!is.null(x_names))
54-
names(ans) <- x_names
55-
ans
56-
}
57-
5835
### Return a named character vector where all the names are single letters.
5936
### Colors amino acids by similarity
6037
### Colors groupins by
@@ -115,35 +92,12 @@ make_AA_COLORED_LETTERS <- function(){
11592
}
11693

11794
### 'x' must be a character vector.
118-
.add_aa_colors <- function(x)
119-
{
120-
if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
121-
return(x)
122-
color_palette <- get("AA_COLORED_LETTERS", envir=.pkgenv)
123-
ans <- vapply(x,
124-
function(xi) {
125-
xi <- safeExplode(xi)
126-
m <- match(xi, names(color_palette))
127-
match_idx <- which(!is.na(m))
128-
xi[match_idx] <- color_palette[m[match_idx]]
129-
paste0(xi, collapse="")
130-
},
131-
character(1),
132-
USE.NAMES=FALSE
133-
)
134-
x_names <- names(x)
135-
if (!is.null(x_names))
136-
names(ans) <- x_names
137-
ans
138-
}
139-
140-
### BString Colors
141-
### by default, no coloring, but will allow users to set their own palettes
142-
.add_bstring_colors <- function(x)
95+
## env_var_name is the name of the corresponding palette in .pkgenv
96+
.add_xstring_colors <- function(x, env_var_name)
14397
{
14498
if (!isTRUE(getOption("Biostrings.coloring", default=FALSE)))
14599
return(x)
146-
color_palette <- get("BSTRING_COLORED_LETTERS", envir=.pkgenv)
100+
color_palette <- get(env_var_name, envir=.pkgenv)
147101
ans <- vapply(x,
148102
function(xi) {
149103
xi <- safeExplode(xi)
@@ -161,21 +115,30 @@ make_AA_COLORED_LETTERS <- function(){
161115
ans
162116
}
163117

164-
update_DNA_palette <- function(colors=NULL){
165-
palette <- get("DNA_AND_RNA_COLORED_LETTERS", envir=.pkgenv)
118+
.update_X_palette <- function(colors=NULL, env_var_name,
119+
alphabet, default_palette_function){
120+
## passing default_palette_function as a function pointer so we don't
121+
## have to evaluate it unless necessary
122+
palette <- get(env_var_name, envir=.pkgenv)
166123
if(is.null(colors))
167-
palette <- make_DNA_AND_RNA_COLORED_LETTERS()
124+
palette <- default_palette_function()
168125
if(!is.null(colors)){
169126
if(!is.list(colors)){
170127
stop("'colors' should be NULL or a named list of entries with 'bg' ",
171128
"and optionally 'fg' values.")
172129
}
173-
all_bases <- union(DNA_ALPHABET, RNA_ALPHABET)
174-
if(length(setdiff(names(colors), all_bases)) != 0){
175-
stop("Invalid DNA/RNA codes specified.")
176-
}
177130

178131
n <- names(colors)
132+
if(!is.null(alphabet) && length(setdiff(n, alphabet)) != 0){
133+
## non-BStrings: checking if the characters are valid
134+
stop("Invalid codes specified.")
135+
} else if(is.null(alphabet)){
136+
## BStrings: checking for single characters (0:255 in raw)
137+
name_nchars <- vapply(n, \(x) length(charToRaw(x)), integer(1L))
138+
if(!all(name_nchars == 1L))
139+
stop("Invalid codes specified.")
140+
}
141+
179142
for(i in seq_along(colors)){
180143
fg <- colors[[i]]$fg
181144
bg <- colors[[i]]$bg
@@ -190,81 +153,33 @@ update_DNA_palette <- function(colors=NULL){
190153
}
191154
}
192155

193-
assign("DNA_AND_RNA_COLORED_LETTERS", palette, envir=.pkgenv)
156+
assign(env_var_name, palette, envir=.pkgenv)
157+
}
158+
159+
update_DNA_palette <- function(colors=NULL){
160+
.update_X_palette(colors, "DNA_AND_RNA_COLORED_LETTERS",
161+
union(DNA_ALPHABET, RNA_ALPHABET),
162+
make_DNA_AND_RNA_COLORED_LETTERS)
194163
}
195164

196165
update_RNA_palette <- update_DNA_palette
197166

198167
update_AA_palette <- function(colors=NULL){
199-
palette <- get("AA_COLORED_LETTERS", envir=.pkgenv)
200-
if(is.null(colors))
201-
palette <- make_AA_COLORED_LETTERS()
202-
203-
if(!is.null(colors)){
204-
if(!is.list(colors)){
205-
stop("'colors' should be NULL or a named list of entries with 'bg' ",
206-
"and optionally 'fg' values.")
207-
}
208-
209-
if(length(setdiff(names(colors), AA_ALPHABET)) != 0){
210-
stop("Invalid AA codes specified.")
211-
}
212-
213-
n <- names(colors)
214-
for(i in seq_along(colors)){
215-
fg <- colors[[i]]$fg
216-
bg <- colors[[i]]$bg
217-
if(is.null(fg) && is.null(bg)){
218-
palette[n[i]] <- n[i]
219-
} else if(is.null(bg)) {
220-
palette[n[i]] <- make_style(fg)(n[i])
221-
} else {
222-
if(is.null(fg)) fg <- rgb(1,1,1)
223-
palette[n[i]] <- make_style(bg, bg=TRUE)(make_style(fg)(n[i]))
224-
}
225-
}
226-
}
227-
228-
assign("AA_COLORED_LETTERS", palette, envir=.pkgenv)
168+
.update_X_palette(colors, "AA_COLORED_LETTERS",
169+
AA_ALPHABET,
170+
make_AA_COLORED_LETTERS)
229171
}
230172

231173
update_B_palette <- function(colors=NULL){
232-
palette <- get("BSTRING_COLORED_LETTERS", envir=.pkgenv)
233-
if(is.null(colors))
234-
palette <- character(0L)
235-
if(!is.null(colors)){
236-
if(!is.list(colors)){
237-
stop("'colors' should be NULL or a named list of entries with 'bg' ",
238-
"and optionally 'fg' values.")
239-
}
240-
241-
n <- names(colors)
242-
## have to use this approach over nchar() because of multibyte chars
243-
## e.g., 240 -> f0 -> "\xf0" -> 'Error: invalid multibyte string'
244-
## however, BString supports these values (sort of)
245-
name_nchars <- vapply(n, \(x) length(charToRaw(x)), integer(1L))
246-
if(!all(name_nchars == 1L)){
247-
stop("Invalid B codes specified.")
248-
}
249-
for(i in seq_along(colors)){
250-
fg <- colors[[i]]$fg
251-
bg <- colors[[i]]$bg
252-
if(is.null(fg) && is.null(bg)){
253-
palette[n[i]] <- n[i]
254-
} else if(is.null(bg)) {
255-
palette[n[i]] <- make_style(fg)(n[i])
256-
} else {
257-
if(is.null(fg)) fg <- rgb(1,1,1)
258-
palette[n[i]] <- make_style(bg, bg=TRUE)(make_style(fg)(n[i]))
259-
}
260-
}
261-
}
262-
263-
assign("BSTRING_COLORED_LETTERS", palette, envir=.pkgenv)
174+
## BStrings don't have a default palette
175+
## thus their default palette function is just \() return(character(0L))
176+
.update_X_palette(colors, "BSTRING_COLORED_LETTERS",
177+
NULL,
178+
\(){ character(0L) })
264179
}
265180

266181
add_colors <- function(x) UseMethod("add_colors")
267182
add_colors.default <- identity
268-
add_colors.DNA <- add_colors.RNA <- .add_dna_and_rna_colors
269-
add_colors.AA <- .add_aa_colors
270-
add_colors.B <- .add_bstring_colors
183+
add_colors.DNA <- add_colors.RNA <- function(x){ .add_xstring_colors(x, "DNA_AND_RNA_COLORED_LETTERS") }
184+
add_colors.AA <- function(x){ .add_xstring_colors(x, "AA_COLORED_LETTERS") }
185+
add_colors.B <- function(x) { .add_xstring_colors(x, "BSTRING_COLORED_LETTERS") }

‎man/coloring.Rd‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
\name{coloring}
22

3+
\alias{coloring}
34
\alias{update_X_palette}
45
\alias{update_DNA_palette}
56
\alias{update_RNA_palette}

‎tests/testthat/test-coloring.R‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -96,11 +96,11 @@ test_that("users can update color palettes", {
9696

9797
## sad path testing
9898
expect_error(update_DNA_palette(list(E=list(fg="yellow"))),
99-
"Invalid DNA/RNA codes specified.")
99+
"Invalid codes specified.")
100100
expect_error(update_AA_palette(list(test=list(fg="yellow"))),
101-
"Invalid AA codes specified.")
101+
"Invalid codes specified.")
102102
expect_error(update_B_palette(list(test=list(fg="yellow"))),
103-
"Invalid B codes specified.")
103+
"Invalid codes specified.")
104104
expect_error(update_DNA_palette(10), "should be NULL or a named list")
105105
expect_error(update_AA_palette(10), "should be NULL or a named list")
106106
expect_error(update_B_palette(10), "should be NULL or a named list")

0 commit comments

Comments
 (0)