159: add validate_prefix (#165)

* adding validate_prefix * Update R/HermesData-validate.R Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * Update R/HermesData-validate.R Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * Update R/HermesData-validate.R Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * Update R/HermesData-validate.R Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * add some tests * some additional changes to tests * additional changes * add additional test for validate_prefix and HermesData * Update R/HermesData-validate.R Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * Apply suggestions from code review Co-Authored-By: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]> * add validate_prefix to yml file * add prefix argument to internal constructor calls in tests Co-authored-by: Sabanes Bove, Daniel {MDBR~Basel} <[email protected]>
insightsengineering · Jun 30, 2021 · 93888d0 · 93888d0
1 parent a8405bb
commit 93888d0
Show file tree

Hide file tree

Showing 7 changed files with 79 additions and 19 deletions.
diff --git a/R/HermesData-class.R b/R/HermesData-class.R
@@ -86,6 +86,7 @@ S4Vectors::setValidity2("AnyHermesData", function(object) {
   msg <- c(msg, validate_row_data(object))
   msg <- c(msg, validate_col_data(object))
   msg <- c(msg, validate_names(object))
+  msg <- c(msg, validate_prefix(object))
 
   if (is.null(msg)) TRUE else msg
 })

diff --git a/R/HermesData-validate.R b/R/HermesData-validate.R
@@ -101,5 +101,26 @@ validate_names <- function(object) {
   if (any(duplicated(colnames(object)))) {
     msg <- c(msg, "'object' must have unique colnames")
   }
+
+  msg
+}
+
+#' @describeIn validate validates that the object prefix is a string
+#' without whitespace, special characters or digits.
+validate_prefix <- function(object) {
+  prefix <- object@prefix
+  msg <- NULL
+
+  if (!is.string(prefix)) {
+    msg <- c(msg, "'prefix' must be string")
+  } else {
+    if (grepl("[^[:alpha:]]", prefix)) {
+      msg <- c(msg, "'prefix' can only consist of alphabetic characters")
+    }
+    gene_ids <- rownames(object)
+    if (!all(grepl(paste0("^", prefix), gene_ids))) {
+      msg <- c(msg, "'prefix' does not match at least one gene ID")
+    }
+  }
   msg
 }
diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -33,6 +33,7 @@ reference:
       - validate_row_data
       - validate_col_data
       - validate_names
+      - validate_prefix
       - h_rpkm
       - h_cpm
       - h_tpm

diff --git a/man/validate.Rd b/man/validate.Rd
diff --git a/tests/testthat/test-HermesData-class.R b/tests/testthat/test-HermesData-class.R
@@ -2,7 +2,7 @@
 
 test_that("HermesData objects can be created with default constructor .HermesData", {
   object <- get_se()
-  result <- expect_silent(.HermesData(object))
+  result <- expect_silent(.HermesData(object, prefix = "GeneID"))
   expect_is(result, "HermesData")
   expect_true(validObject(result))
 })
@@ -14,11 +14,16 @@ test_that("HermesData validation fails as expected", {
   expect_error(.HermesData(object), "required columns .+ not present")
 })
 
+test_that("HermesData prefix slot can not be assigned numeric", {
+  object <- HermesData(summarized_experiment)
+  expect_error(object@prefix <- 124)
+})
+
 # .RangedHermesData ----
 
 test_that("RangedHermesData objects can be created with default constructor .RangedHermesData", {
   object <- get_rse()
-  result <- expect_silent(.RangedHermesData(object))
+  result <- expect_silent(.RangedHermesData(object, prefix = "ENSG"))
   expect_is(result, "RangedHermesData")
   expect_true(validObject(result))
 })

diff --git a/tests/testthat/test-HermesData-methods.R b/tests/testthat/test-HermesData-methods.R
@@ -2,9 +2,9 @@
 
 test_that("rbind function works as expected for HermesData objects", {
   object <- get_se()
-  h1 <- .HermesData(object[1])
-  h2 <- .HermesData(object[2])
-  h3 <- .HermesData(object)
+  h1 <- HermesData(object[1])
+  h2 <- HermesData(object[2])
+  h3 <- HermesData(object)
   result <- expect_silent(rbind(h1, h2))
   expect_is(result, "HermesData")
   expect_equal(dim(result), dim(h3))
@@ -15,25 +15,25 @@ test_that("rbind function works as expected for HermesData objects", {
 test_that("rbind function works as expected when binding SummarizedExperiment with HermesData", {
   object <- get_se()
   se <- object[1]
-  h1 <- .HermesData(object[2])
+  h1 <- HermesData(object[2])
   result1 <- expect_silent(rbind(se, h1))
   expect_is(result1, "SummarizedExperiment")
   result2 <- expect_silent(rbind(h1, se))
   expect_is(result2, "SummarizedExperiment")
 })
 
 test_that("rbind function fails as expected when rbind results in duplicated rownames", {
-  object <- .HermesData(summarized_experiment)
+  object <- HermesData(summarized_experiment)
   expect_error(rbind(object, object))
 })
 
 # cbind ----
 
 test_that("cbind function works as expected for HermesData objects", {
   object <- get_se()
-  h1 <- .HermesData(object[, 1])
-  h2 <- .HermesData(object[, 2])
-  h3 <- .HermesData(object)
+  h1 <- HermesData(object[, 1])
+  h2 <- HermesData(object[, 2])
+  h3 <- HermesData(object)
   result <- expect_silent(cbind(h1, h2))
   expect_is(result, "HermesData")
   expect_equal(dim(result), dim(h3))
@@ -44,23 +44,23 @@ test_that("cbind function works as expected for HermesData objects", {
 test_that("cbind function works as expected when binding SummarizedExperiment with HermesData", {
   object <- get_se()
   se <- object[, 1]
-  h1 <- .HermesData(object[, 2])
+  h1 <- HermesData(object[, 2])
   result1 <- expect_silent(cbind(se, h1))
   expect_is(result1, "SummarizedExperiment")
   result2 <- expect_silent(cbind(h1, se))
   expect_is(result2, "SummarizedExperiment")
 })
 
 test_that("rbind function fails as expected when rbind results in duplicated colnames", {
-  object <- .HermesData(summarized_experiment)
+  object <- HermesData(summarized_experiment)
   expect_error(cbind(object, object))
 })
 
 # metadata ----
 
 test_that("metadata accessor works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   result <- expect_silent(metadata(h1))
   expected <- list(
     filename = "bla.txt",
@@ -71,7 +71,7 @@ test_that("metadata accessor works as expected", {
 
 test_that("metadata setter works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   value <- list(a = "foo")
   expect_silent(metadata(h1) <- value)
   expect_identical(metadata(h1), value)
@@ -81,7 +81,7 @@ test_that("metadata setter works as expected", {
 
 test_that("annotation accessor works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   result <- expect_silent(annotation(h1))
   expect_s4_class(result, "DataFrame")
   expect_named(result, .row_data_annotation_cols)
@@ -90,7 +90,7 @@ test_that("annotation accessor works as expected", {
 
 test_that("annotation setter works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   value <- S4Vectors::DataFrame(
     StartBP = c(0, 10),
     EndBP = c(11, 12),
@@ -134,15 +134,15 @@ test_that("annotation setter gives a warning, saves gene IDs in attribute if gen
 
 test_that("counts accessor works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   result <- expect_silent(counts(h1))
   expect_is(result, "matrix")
   expect_identical(dim(result), dim(h1))
 })
 
 test_that("counts setter works as expected", {
   object <- get_se()
-  h1 <- .HermesData(object)
+  h1 <- HermesData(object)
   value <- matrix(0L, nrow = nrow(h1), ncol = ncol(h1))
   expect_silent(counts(h1) <- value)
   expect_equivalent(counts(h1), value)
@@ -178,7 +178,7 @@ test_that("samples accessor works as expected", {
 # subset ----
 
 test_that("subset function works as expected for HermesData objects", {
-  h <- .HermesData(get_se())
+  h <- HermesData(get_se())
   result <- expect_silent(subset(
     h,
     subset = LowExpressionFlag,

diff --git a/tests/testthat/test-HermesData-validate.R b/tests/testthat/test-HermesData-validate.R
@@ -183,3 +183,29 @@ test_that("validate_names returns messages as expected for invalid object", {
     "'object' must have unique colnames"
   )
 })
+
+# validate_prefix  ----
+
+test_that("validate_prefix returns NULL for a valid object", {
+  object <- HermesData(summarized_experiment)
+  expect_null(validate_prefix(object))
+})
+
+test_that("validate_prefix returns messages as expected for wrong prefix with whitespace", {
+  object <- HermesData(summarized_experiment)
+  object@prefix <- "Gene ID"
+  result <- validate_prefix(object)
+  expected <- c(
+    "'prefix' can only consist of alphabetic characters",
+    "'prefix' does not match at least one gene ID"
+  )
+  expect_identical(result, expected)
+})
+
+test_that("validate_prefix returns correct message when prefix has two elements", {
+  object <- HermesData(summarized_experiment)
+  object@prefix <- c("GeneID", "ENSGID")
+  result <- expect_silent(validate_prefix(object))
+  expected <- "'prefix' must be string"
+  expect_identical(result, expected)
+})