feat: fixes for next Bioc release

.github/workflows/test-coverage.yaml

@@ -0,0 +1,227 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  pull_request:
+    branches: [main, master, devel, devel-staging]
+
+name: test-coverage-nocodecov
+
+permissions: read-all
+
+jobs:
+  test-coverage:
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - name: Checkout current ref
+        uses: actions/checkout@v4
+        with:
+          path: ./new-state
+
+      - name: Checkout Biostrings devel ref
+        id: devel-checkout
+        uses: actions/checkout@v4
+        with:
+          repository: Bioconductor/Biostrings
+          path: ./original-state
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - name: setup dependencies for old state
+        uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          working-directory: ./original-state
+          extra-packages: any::covr
+          needs: coverage
+
+      - name: setup dependencies for new state
+        uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          working-directory: ./new-state
+          extra-packages: any::covr
+          needs: coverage
+
+      - name: Test coverage on base branch
+        run: |
+          dirpath <- file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
+          dir.create(dirpath)
+
+          ## first check unit tests
+          cat("Checking test results...\n")
+          res <- testthat::test_local("./new-state", stop_on_failure=FALSE, reporter="check")
+          res <- as.data.frame(res)
+          test_report <- c(sum(res$failed), sum(res$warning), sum(res$skipped), sum(res$passed))
+          shouldStop <- test_report[1] > 0
+          shouldPrint <- sum(test_report[1:2]) > 0
+          test_report <- paste(c("FAIL", "WARN", "SKIP", "PASS"), test_report, collapse=' | ')
+          test_report <- paste('Unit Tests: [', test_report, ']')
+
+          ## build the output message
+          out_msg <- '# Testing Report\n\n'
+          out_msg <- paste0(out_msg, "## Test Results:\n\n")
+          out_msg <- paste0(out_msg, "Please note that test coverage is **not** an ",
+                            "end-all-be-all measure of robustness. Having tests that ",
+                            "correctly cover intended use cases and potential errors ",
+                            "is significantly more important than maximizing coverage.\n\n")
+          out_msg <- paste0(out_msg, "```\n", test_report, '\n```\n\n')
+
+          ## if any tests failed or threw warnings, report them
+          if(shouldPrint){
+            p_toprint <- which(res$failed + res$warning > 0)
+            ptp <- res[p_toprint,]
+            failed_tests <- ptp[,c("file", "test", "warning", "failed")]
+            failed_tests <- apply(failed_tests, 1L, paste, collapse=" | ")
+            failed_tests <- paste("|", failed_tests, "| ")
+            failed_tests <- paste(failed_tests, collapse='\n')
+            md_tab <- paste0("| Test File :page_facing_up: | Test Name :id: | Warnings :warning: | Failures :x: | \n",
+                            "| :----- | :----- | :-----: | :-----: | \n",
+                            failed_tests, "\n\n")
+            out_msg <- paste0(out_msg, "### Warning/Failing Tests:\n\n", md_tab)
+          }
+          if(shouldStop){
+            cat(out_msg, file='./test_status.md')
+            stop("Some tests failed! Skipping coverage report.")
+          }
+
+          ## if no tests failed, check coverage of old vs. new
+          library(covr)
+          # exclude lines with no content
+          options(covr.exclude_pattern=c("^[ \t{}()]+$"))
+          # get results on old state
+          files_to_ignore <- list("R/AMINO_ACID_CODE.R", "R/GENETIC_CODE.R",
+                                  "R/zzz.R", "R/IUPAC_CODE_MAP.R",
+                                  "R/getSeq.R")
+          cov <- covr::package_coverage(
+            path = "./original-state",
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(dirpath, "old-state"),
+            function_exclusions = "^\\.",
+            line_exclusions=files_to_ignore
+          )
+          head_res <- covr::coverage_to_list(cov)
+          # get results on new state
+          cov <- covr::package_coverage(
+            path = "./new-state",
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(dirpath, "new-state"),
+            function_exclusions = "^\\.", # excludes functions starting with .
+            line_exclusions=files_to_ignore
+          )
+          new_res <- covr::coverage_to_list(cov)
+
+          ## compare difference in coverage
+          f_old <- head_res$filecoverage
+          f_new <- new_res$filecoverage
+          cat("Old Coverage:\n")
+          print(f_old)
+          cat("***************\n")
+          cat("New Coverage:\n")
+          print(f_new)
+          cat("***************\n")
+          all_files <- union(names(f_old), names(f_new))
+          file_changes <- rep(0, length(all_files))
+          names(file_changes) <- all_files
+          file_changes[names(f_new)] <- file_changes[names(f_new)] + f_new
+          final_cov <- file_changes
+          file_changes[names(f_old)] <- file_changes[names(f_old)] - f_old
+          total_change <- new_res$totalcoverage - head_res$totalcoverage
+
+          out_msg <- paste0(out_msg, "## Negatively Impacted Files\n\n")
+          ## build warning message
+          n <- names(file_changes)
+          pos_neg <- which(file_changes < 0)
+          if(length(pos_neg) > 0){
+            pos_neg <- pos_neg[order(file_changes[pos_neg], decreasing=FALSE)]
+            warn_changes <- sprintf("%+.01f%%", file_changes)
+            header <- "| File name | Coverage | Change |\n | :----- | :-----: | :-----: |\n"
+            warn_tab <- paste0('| ', n[pos_neg], ' | ', sprintf("%0.02f%%", final_cov[pos_neg]), ' | ',
+                                unname(warn_changes[pos_neg]), ' |', collapse='\n')
+            warn_tab <- paste0(header, warn_tab)
+            out_msg <- paste0(out_msg, "The following files have lost coverage:\n", warn_tab, '\n')
+          } else {
+            out_msg <- paste0(out_msg, "No negatively impacted files. Nice job!\n\n")
+          }
+
+          ## build extended diff table
+          p_Rfiles <- grepl("^R/", n)
+          n <- vapply(strsplit(n, '/'), .subset, character(1L), 2L)
+          all_diffs <- data.frame(filename=n,
+            coverage=sprintf("%.02f%%", final_cov),
+            change=sprintf("%+.01f%%", file_changes))
+          max_nchar <- max(nchar(all_diffs$filename))
+          all_diffs$filename <- sprintf(paste0("%", max_nchar, "s"), all_diffs$filename)
+          all_diffs$coverage <- sprintf("%7s", all_diffs$coverage)
+          all_diffs$change <- sprintf("%7s", all_diffs$change)
+          all_diffs$mark_char <- 1L
+          all_diffs$mark_char[file_changes > 0] <- 2L
+          all_diffs$mark_char[file_changes < 0] <- 3L
+          all_diffs$mark_char <- c(" ", "+", "-")[all_diffs$mark_char]
+
+          all_rows <- apply(all_diffs[c(4,1:3)], 1L, paste, collapse=' ')
+          w <- nchar(all_rows[1L])
+
+          title0 <- "Total Coverage"
+          n_padding <- (w - nchar(title0) - 4) / 2
+          title0 <- paste0("@@", paste(rep(' ', floor(n_padding)), collapse=''),
+            title0, paste(rep(' ', ceiling(n_padding)), collapse=''), "@@")
+          row0 <- paste(ifelse(total_change < 0, "-", ifelse(total_change>0, "+", " ")),
+                          sprintf(paste0("%", max_nchar, "s"), "Total Coverage"),
+                          sprintf("%6.02f%%", new_res$totalcoverage),
+                          sprintf("%+6.01f%%", total_change), collapse=' ')
+
+          title1 <- "R/... Files"
+          n_padding <- (w - nchar(title1) - 4) / 2
+          title1 <- paste0("@@", paste(rep(' ', floor(n_padding)), collapse=''),
+            title1, paste(rep(' ', ceiling(n_padding)), collapse=''), "@@")
+
+          title2 <- "src/... Files"
+          n_padding <- (w - nchar(title2) - 4) / 2
+          title2 <- paste0("@@", paste(rep(' ', floor(n_padding)), collapse=''),
+            title2, paste(rep(' ', ceiling(n_padding)), collapse=''), "@@")
+
+          spacer <- paste(rep('=', w), collapse='')
+          entries1 <- paste(all_rows[p_Rfiles], collapse='\n')
+          entries2 <- paste(all_rows[!p_Rfiles], collapse='\n')
+          diff_table <- paste(title0, spacer, '\n', row0, '\n', spacer,
+                              title1, spacer, entries1, spacer,
+                              title2, spacer, entries2, spacer,
+                              collapse='\n', sep='\n')
+          diff_table <- paste0("<details>\n<summary>Additional Details and Impacted Files:</summary>\n\n",
+                                "```diff\n", diff_table, '\n\n```\n\n</details>')
+          out_msg <- paste0(out_msg, diff_table, '\n')
+          cat(out_msg, file='./test_status.md')
+        shell: Rscript {0}
+
+      ## This is a better option than step summary, but requires
+      ## the "pull-request: write" permission, which I'd rather
+      ## not allow on a public repository
+      # - name: Print comment to PR
+      #   uses: thollander/actions-comment-pull-request@v2
+      #   with:
+      #     GITHUB_TOKEN: ${{ env.GITHUB_PAT }}
+      #     filePath: ./test_status.md
+      #     comment_tag: unit-test-results
+
+      - name: Print results to summary
+        if: always()
+        run: cat ./test_status.md >> $GITHUB_STEP_SUMMARY
+
+      - name: Upload package on failure
+        if: failure()
+        uses: actions/upload-artifact@v4
+        with:
+          name: coverage-test-failures
+          path: ${{ runner.temp }}/package
+
+      - name: Upload status on success
+        if: always()
+        uses: actions/upload-artifact@v4
+        with:
+          name: coverage-test-results
+          path: ./test_status.md

.gitignore

@@ -0,0 +1,13 @@
+*.o
+src/*.o
+src/*.so
+*.icloud
+.Rproj*
+.DS_Store
+*/.DS_Store
+.RData
+.Rbuildignore
+.Rhistory
+*/*.gcov
+*/*.gcda
+*/*.gcno

DESCRIPTION

@@ -44,7 +44,7 @@ Suggests: graphics, pwalign, BSgenome (>= 1.13.14),
 	drosophila2probe, hgu95av2probe, hgu133aprobe,
 	GenomicFeatures (>= 1.3.14),
 	hgu95av2cdf, affy (>= 1.41.3), affydata (>= 1.11.5),
-	RUnit, BiocStyle, knitr
+	RUnit, BiocStyle, knitr, testthat (>= 3.0.0), covr
 VignetteBuilder: knitr
 Collate: utils.R
 	IUPAC_CODE_MAP.R

R/QualityScaledXStringSet.R

@@ -186,6 +186,13 @@ readQualityScaledDNAStringSet <- function(filepath,
                           nrec, skip, seek.first.rec,
                           use.names, with.qualities=TRUE)
     qualities <- mcols(x)[ , "qualities"]
+    ## Clear out the qualities parameter from the DNAStringSet,
+    ## since it gets passed into the QualityScaledDNAStringSet
+    ## constructor via quals anyway
+    ## (otherwise we get a warning that doesn't make sense)
+    mcols(x)[,"qualities"] <- NULL
+    if(ncol(mcols(x)) == 0)
+        mcols(x) <- NULL
     quals <- switch(quality.scoring,
                     phred=PhredQuality(qualities),
                     solexa=SolexaQuality(qualities),
@@ -201,4 +208,3 @@ writeQualityScaledXStringSet <- function(x, filepath,
     writeXStringSet(x, filepath, append, compress, compression_level,
                        format="fastq", qualities=quality(x))
 }
-

R/XStringViews-class.R

@@ -478,14 +478,14 @@ setMethod("as.matrix", "XStringViews",
     function(x, use.names=TRUE)
     {
         ## TODO: Supress this warning in BioC 2.12.
-        msg <- c("as.matrix() on an XStringViews object 'x' has changed ",
-                 "behavior: now the\n  views in 'x' must be of equal width ",
-                 "and each view is converted into a row of\n",
-                 "  single characters. To achieve the old behavior, ",
-                 "do 'as.matrix(ranges(x))'.\n  To supress this warning, do ",
-                 "'suppressWarnings(as.matrix(x))'.\n  This warning will be ",
-                 "removed in BioC 2.12.")
-        warning(msg)
+        # msg <- c("as.matrix() on an XStringViews object 'x' has changed ",
+        #          "behavior: now the\n  views in 'x' must be of equal width ",
+        #          "and each view is converted into a row of\n",
+        #          "  single characters. To achieve the old behavior, ",
+        #          "do 'as.matrix(ranges(x))'.\n  To supress this warning, do ",
+        #          "'suppressWarnings(as.matrix(x))'.\n  This warning will be ",
+        #          "removed in BioC 2.12.")
+        # warning(msg)
         y <- fromXStringViewsToStringSet(x, out.of.limits="error",
                                          use.names=use.names)
         as.matrix(y)

R/chartr.R

@@ -49,6 +49,9 @@ setMethod("chartr", c(old="ANY", new="ANY", x="MaskedXString"),
 ### A simple wrapper to chartr().
 replaceAmbiguities <- function(x, new="N")
 {
+    if(!(inherits(x, c("XString", "XStringSet", "XStringViews"))) ||
+       !(seqtype(x) %in% c("DNA", "RNA")))
+      stop("replaceAmbiguities is only supported for DNA and RNA")
     if (!(isSingleString(new) && nchar(new) == 1L))
         stop("'new' must be a single letter")
     old <- paste(setdiff(names(IUPAC_CODE_MAP), DNA_BASES), collapse="")

R/coloring.R

@@ -63,7 +63,7 @@ make_DNA_AND_RNA_COLORED_LETTERS <- function()
 ### Colors groupins by
 ###   https://www.jalview.org/help/html/colourSchemes/zappo.html
 ### Called in .onLoad() to initialize AA_COLORED_LETTERS.
-make_AA_COLORED_LETTERS <- function(x){
+make_AA_COLORED_LETTERS <- function(){
     whiter <- make_style(rgb(1, 1, 1))
     dark_grey_bg <- make_style(rgb(0.5,0.5,0.5), bg=TRUE)
 

R/dinucleotideFrequencyTest.R

@@ -113,12 +113,12 @@ g.test <- function(x, y = NULL, correct="none",
   else {
     # x is not a matrix, so we do Goodness of Fit
     METHOD <- "Log likelihood ratio (G-test) goodness of fit test"
-    if (length(x) == 1) 
+    if (length(x) == 1)
       stop("x must at least have 2 elements")
-    if (length(x) != length(p)) 
+    if (length(x) != length(p))
       stop("x and p must have the same number of elements")
     E <- n * p
-    
+
     if (correct=="yates"){ # Do Yates' correction
       if(length(x)!=2)
         stop("Yates' correction requires 2 data values")

R/letter.R

@@ -12,8 +12,8 @@ setGeneric("letter", signature="x",
 setMethod("letter", "character",
     function(x, i)
     {
-        if (!is.numeric(i) || any(is.na(i)))
-            stop("'i' must be an NA-free numeric vector")
+        if (!is.numeric(i) || anyNA(i))
+            stop("subscript 'i' must be an NA-free numeric vector")
         if (length(x) == 0)
             return(character(0))
         if (length(i) == 0)
@@ -42,10 +42,13 @@ setMethod("letter", "character",
 setMethod("letter", "XString",
     function(x, i)
     {
-        if (!is.numeric(i))
-            stop("subscript 'i' must be an integer vector")
+        if (!is.numeric(i) || anyNA(i))
+            stop("subscript 'i' must be an NA-free numeric vector")
         if (!is.integer(i))
             i <- as.integer(i)
+        imax <- length(x)
+        if (!all(i >= 1) || !all(i <= imax))
+            stop("subscript out of bounds")
         extract_character_from_XString_by_positions(x, i, collapse=TRUE)
     }
 )
@@ -54,12 +57,10 @@ setMethod("letter", "XString",
 setMethod("letter", "XStringViews",
     function(x, i)
     {
-        if (!is.numeric(i))
-            stop("subscript 'i' must be an integer vector")
+        if (!is.numeric(i) || anyNA(i))
+            stop("subscript 'i' must be an NA-free numeric vector")
         if (!is.integer(i))
             i <- as.integer(i)
-        if (anyNA(i))
-            stop("subscript 'i' cannot contain NAs")
         if (length(x) == 0)
             return(character(0))
         imax <- min(width(x))

R/letterFrequency.R

@@ -794,9 +794,15 @@ setMethod("consensusMatrix", "XStringSet",
         } else {
             removeUnused <- FALSE
         }
-        ans <- .Call2("XStringSet_consensus_matrix",
-                     x, shift, width, baseOnly, codes,
-                     PACKAGE="Biostrings")
+        if(length(x) == 0){
+            ans <- matrix(ifelse(as.prob, 0, 0L), nrow=0,
+                          ncol=ifelse(removeUnused, 0, length(codes)))
+            if(!removeUnused) colnames(ans) <- names(codes)
+        } else {
+            ans <- .Call2("XStringSet_consensus_matrix",
+                         x, shift, width, baseOnly, codes,
+                         PACKAGE="Biostrings")
+        }
         if (removeUnused) {
             ans <- ans[rowSums(ans) > 0, , drop=FALSE]
         }

R/maskMotif.R

@@ -53,6 +53,8 @@ setMethod("maskMotif", signature(x="XString", motif="ANY"),
 ### Deprecate in Biostrings 2.9!
 mask <- function(x, start=NA, end=NA, pattern)
 {
+    warning("`mask()` is deprecated and will be removed in a future release.\n",
+              "Please use `Mask()` or `maskMotif()` instead.")
     if (!is(x, "XString"))
         x <- XString(NULL, x)
     if (missing(pattern)) {