cleans up some methods, removes <<- assignment, disable braille

Author: ahl27

R/XString-class.R

@@ -142,13 +142,19 @@ setMethod("extract_character_from_XString_by_ranges", "XString",
 ### BString methods to support 0:255 input
 
 ## BSTRING_RAW_LOOKUP is initialized in `zzz.R`
-## this value is just a backup on the offchance `zzz.R:.onLoad` fails
-BSTRING_RAW_LOOKUP <- rawToChar(as.raw(0:255), multiple=TRUE)
 setMethod("extract_character_from_XString_by_ranges", "BString",
     function(x, start, width, collapse=FALSE)
     {
         SHOW_RAW <- getOption("Biostrings.showRaw")
+        if(!is.logical(SHOW_RAW)){
+            warning("Invalid value for option 'Biostrings.showRaw', ",
+                        "resetting to FALSE")
+            SHOW_RAW <- FALSE
+            options(Biostrings.showRaw=FALSE)
+        }
         if(!SHOW_RAW) callNextMethod()
+
+        bstring_lookup <- get("BSTRING_RAW_LOOKUP", envir=.pkgenv)
         lkup <- xs_dec_lkup(x)
 
         ## need to remap null bytes, they have to be in 0:255
@@ -159,7 +165,7 @@ setMethod("extract_character_from_XString_by_ranges", "BString",
                                                         lkup=lkup)
         ## replace all undisplayable characters
         for(i in seq_along(xs))
-            xs[i] <- paste(BSTRING_RAW_LOOKUP[as.integer(charToRaw(xs[i]))+1L],
+            xs[i] <- paste(bstring_lookup[as.integer(charToRaw(xs[i]))+1L],
                             collapse='')
         xs
     }
@@ -169,8 +175,15 @@ setMethod("extract_character_from_XString_by_positions", "BString",
     function(x, pos, collapse=FALSE)
     {
         SHOW_RAW <- getOption("Biostrings.showRaw")
+        if(!is.logical(SHOW_RAW)){
+            warning("Invalid value for option 'Biostrings.showRaw', ",
+                        "resetting to FALSE")
+            SHOW_RAW <- FALSE
+            options(Biostrings.showRaw=FALSE)
+        }
         if(!SHOW_RAW) callNextMethod()
         lkup <- xs_dec_lkup(x)
+        bstring_lookup <- get("BSTRING_RAW_LOOKUP", envir=.pkgenv)
 
         ## need to remap null bytes, they have to be in 0:255
         ## so we have to overload some value
@@ -180,7 +193,7 @@ setMethod("extract_character_from_XString_by_positions", "BString",
                                                         lkup=lkup)
         ## replace all undisplayable characters
         for(i in seq_along(xs))
-            xs[i] <- paste(BSTRING_RAW_LOOKUP[as.integer(charToRaw(xs[i]))+1L],
+            xs[i] <- paste(bstring_lookup[as.integer(charToRaw(xs[i]))+1L],
                             collapse='')
         xs
     }

R/zzz.R

@@ -1,5 +1,7 @@
 ###
 
+.pkgenv <- new.env(parent=emptyenv())
+
 .onLoad <- function(libname, pkgname)
 {
     .Call2("init_DNAlkups",
@@ -28,17 +30,22 @@
     encoding_details <- l10n_info()
     bstring_lookup <- rawToChar(as.raw(0:255), multiple=TRUE)
     invalid_chars <- c(1:32,128:256)
-    if(encoding_details$`UTF-8`){
-      # braille is nice if supported
-      # allows for char comparisons after as.character() comparisons
-      bstring_lookup[invalid_chars] <-
-        as.character(parse(text=paste0("'\\U28", as.raw(95:255), "'")))
-    } else if (encoding_details$MBCS){
+    # if(encoding_details$`UTF-8`){
+    #   # braille is nice if supported
+    #   # allows for char comparisons after as.character() comparisons
+    #   # I think it's overkill, though...uncomment this section if we need it
+    #   bstring_lookup[invalid_chars] <-
+    #     as.character(parse(text=paste0("'\\U28", as.raw(95:255), "'")))
+    # } else
+    if (encoding_details$MBCS){
       # use multibyte question mark if supported
       compact_unknown <- rawToChar(as.raw(c(0xef, 0xbf, 0xbd)))
       bstring_lookup[invalid_chars] <- compact_unknown
+    } else {
+      # otherwise just use the regular '?'
+      bstring_lookup[invalid_chars] <- "?"
     }
-    BSTRING_RAW_LOOKUP <<- bstring_lookup
+    assign("BSTRING_RAW_LOOKUP", bstring_lookup, envir=.pkgenv)
 }
 
 .onUnload <- function(libpath)

tests/testthat/test-XString-class.R

@@ -250,6 +250,29 @@ test_that("reverse, complement, reverseComplement work correctly", {
     expect_equal(as.character(reverseComplement(mrna)), .revString(mr_comp))
 })
 
+test_that("BStrings display correctly with full 0-255 value range", {
+    orig_setting <- getOption("Biostrings.showRaw")
+    full_bstring <- as(as(as.raw(0:255),"XRaw"),"BString")
+    options(Biostrings.showRaw=FALSE)
+    expect_error(extract_character_from_XString_by_ranges(full_bstring, 1L, 256L),
+        "embedded nul in string")
+
+    ## can't really test MBCS vs. non-MBCS because we can't guarantee
+    ## the test suites will run on a platform with(out) MBCS
+    options(Biostrings.showRaw=TRUE)
+    expect_is(extract_character_from_XString_by_ranges(full_bstring, 1L, 256L),
+                "character")
+
+    options(Biostrings.showRaw=10)
+    expect_warning(extract_character_from_XString_by_ranges(BString("ABCD"), 1L, 4L),
+        "Invalid value for option 'Biostrings.showRaw'")
+    expect_false(getOption("Biostrings.showRaw"))
+
+    ## make sure we leave the system as we found it
+    options(Biostrings.showRaw=orig_setting)
+
+})
+
 ## Porting RUnit tests
 test_that("alphabet finds the correct values", {
     expect_equal(alphabet(DNAString(dnastr)), strsplit(dnastr, "")[[1]])