Allow non-standard datanames in filter data

DESCRIPTION

@@ -45,6 +45,7 @@ Imports:
     methods,
     plotly (>= 4.9.2.2),
     R6 (>= 2.2.0),
+    rlang (>= 1.0.0),
     shiny (>= 1.6.0),
     shinycssloaders (>= 1.0.0),
     shinyjs,

R/FilterStates.R

@@ -57,7 +57,11 @@ FilterStates <- R6::R6Class( # nolint
 
       private$dataname <- dataname
       private$datalabel <- datalabel
-      private$dataname_prefixed <- dataname
+      private$dataname_prefixed <- if (identical(dataname, make.names(dataname))) {
+        dataname
+      } else {
+        sprintf("`%s`", dataname)
+      }
       private$data <- data
       private$data_reactive <- data_reactive
       private$state_list <- reactiveVal()
@@ -165,7 +169,12 @@ FilterStates <- R6::R6Class( # nolint
       )
       if (length(filter_items) > 0L) {
         filter_function <- private$fun
-        data_name <- str2lang(private$dataname_prefixed)
+        data_name <- tryCatch(
+          {
+            str2lang(private$dataname_prefixed)
+          },
+          error = function(e) str2lang(paste0("`", private$dataname_prefixed, "`"))
+        )
         substitute(
           env = list(
             lhs = data_name,

R/FilterStatesMatrix.R

@@ -35,6 +35,11 @@ MatrixFilterStates <- R6::R6Class( # nolint
       checkmate::assert_matrix(data)
       super$initialize(data, data_reactive, dataname, datalabel)
       private$set_filterable_varnames(include_varnames = colnames(private$data))
+      if (!is.null(datalabel)) {
+        private$dataname_prefixed <- sprintf(
+          "%s[['%s']]", private$dataname_prefixed, datalabel
+        )
+      }
     }
   ),
   private = list(

R/FilterStatesSE.R

@@ -39,7 +39,9 @@ SEFilterStates <- R6::R6Class( # nolint
       checkmate::assert_class(data, "SummarizedExperiment")
       super$initialize(data, data_reactive, dataname, datalabel)
       if (!is.null(datalabel)) {
-        private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel)
+        private$dataname_prefixed <- sprintf(
+          "%s[['%s']]", private$dataname_prefixed, datalabel
+        )
       }
     },
 

R/FilteredData.R

@@ -307,9 +307,6 @@ FilteredData <- R6::R6Class( # nolint
     set_dataset = function(data, dataname) {
       checkmate::assert_string(dataname)
       logger::log_debug("FilteredData$set_dataset setting dataset, name: { dataname }")
-      # to include it nicely in the Show R Code;
-      # the UI also uses `datanames` in ids, so no whitespaces allowed
-      check_simple_name(dataname)
 
       parent_dataname <- teal.data::parent(private$join_keys, dataname)
       keys <- private$join_keys[dataname, dataname]

R/FilteredDataset.R

@@ -30,7 +30,7 @@ FilteredDataset <- R6::R6Class( # nolint
     #' @return Object of class `FilteredDataset`, invisibly.
     #'
     initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
-      check_simple_name(dataname)
+      checkmate::assert_string(dataname)
       logger::log_debug("Instantiating { class(self)[1] }, dataname: { dataname }")
       checkmate::assert_character(keys, any.missing = FALSE)
       checkmate::assert_character(label, null.ok = TRUE)

R/utils.R

@@ -1,28 +1,3 @@
-#' Test whether variable name can be used within `Show R Code`
-#'
-#' Variable names containing spaces are problematic and must be wrapped in backticks.
-#' Also, they should not start with a number as `R` may silently make it valid by changing it.
-#' Therefore, we only allow alphanumeric characters with underscores.
-#' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.
-#'
-#' @md
-#'
-#' @param name (`character`) vector of names to check
-#' @return Returns `NULL` or raises error.
-#' @keywords internal
-#'
-check_simple_name <- function(name) {
-  checkmate::assert_character(name, min.len = 1, any.missing = FALSE)
-  if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
-    stop(
-      "name '",
-      name,
-      "' must only contain alphanumeric characters (with underscores)",
-      " and the first character must be an alphabetic character"
-    )
-  }
-}
-
 #' Include `JS` files from `/inst/js/` package directory to application header
 #'
 #' `system.file` should not be used to access files in other packages, it does
@@ -81,3 +56,56 @@ make_c_call <- function(choices) {
   if (length(private$session_bindings) > 0) lapply(private$session_bindings, function(x) x$destroy())
   invisible(NULL)
 }
+
+
+
+#' Encodes ids to be used in JavaScript and Shiny
+#'
+#' @description
+#' Replaces non-ASCII characters into a format that can be used in HTML,
+#' JavaScript and Shiny.
+#'
+#' When the id has a character that is not allowed, it is replaced with `"_"`
+#' and a 4 character hash of the original id is added to the start of the
+#' resulting id.
+#'
+#'
+#' @param id (`character(1)`) The id string.
+#'
+#' @return Sanitized string that removes special characters and spaces.
+#'
+#' @keywords internal
+sanitize_id <- function(id) {
+  pattern_escape <- "[^0-9A-Za-z_]"
+
+  id_new <- gsub(pattern_escape, "_", id)
+  hashes <- vapply(id[id != id_new], rlang::hash, character(1), USE.NAMES = FALSE)
+
+  id[id != id_new] <- paste0("h", substr(hashes, 1, 4), "_", id_new[id != id_new])
+  id
+}
+
+#' `NS` wrapper to sanitize ids for shiny
+#'
+#' Special characters and spaces are not allowed in shiny ids (in JS)
+#'
+#' @noRd
+NS <- function(namespace, id = NULL) { # nolint: object_name.
+  if (!missing(id)) {
+    return(shiny::NS(namespace, sanitize_id(id)))
+  }
+
+  function(id) {
+    shiny::NS(namespace, sanitize_id(id))
+  }
+}
+
+#' `moduleServer` wrapper to sanitize ids for shiny
+#'
+#' Special characters and spaces are not allowed in shiny ids (in JS)
+#'
+#' @noRd
+moduleServer <- function(id, module, session = getDefaultReactiveDomain()) { # nolint: object_name.
+  id <- sanitize_id(id)
+  shiny::moduleServer(id, module, session)
+}

tests/testthat/test-DataframeFilteredDataset.R

@@ -4,7 +4,9 @@ testthat::test_that("constructor accepts data.frame object with a dataname", {
   testthat::expect_error(DataframeFilteredDataset$new(dataset = head(iris)), "argument .+ missing, with no default")
   testthat::expect_error(DataframeFilteredDataset$new(dataname = "iris"), "argument .+ missing, with no default")
   testthat::expect_error(DataframeFilteredDataset$new(dataset = as.list(iris)), "Assertion on 'dataset' failed")
-  testthat::expect_error(DataframeFilteredDataset$new(dataset = iris, dataname = iris), "Assertion on 'name' failed")
+  testthat::expect_error(
+    DataframeFilteredDataset$new(dataset = iris, dataname = iris), "Assertion on 'dataname' failed"
+  )
 })
 
 testthat::test_that("filter_states list is initialized with single `FilterStates` element named filter", {

tests/testthat/test-utils.R

@@ -1,25 +1,96 @@
-# check_simple_name ----
-test_that("check_simple_name behaves as expected", {
-  testthat::expect_silent(check_simple_name("aas2df"))
-  testthat::expect_silent(check_simple_name("ADSL"))
-  testthat::expect_silent(check_simple_name("ADSLmodified"))
-  testthat::expect_silent(check_simple_name("a1"))
-  testthat::expect_silent(check_simple_name("ADSL_modified"))
-  testthat::expect_silent(check_simple_name("ADSL_filtered"))
-  testthat::expect_silent(check_simple_name("FILTERED_ADSL"))
-  testthat::expect_silent(check_simple_name("FILTERED"))
-  testthat::expect_silent(check_simple_name("ADSLFILTERED"))
-  testthat::expect_silent(check_simple_name("a_1_2_b_"))
-
-  testthat::expect_error(check_simple_name("1a"), "name '.+' must only contain alphanumeric characters")
-  testthat::expect_error(check_simple_name("ADSL.modified"), "name '.+' must only contain alphanumeric characters")
-  testthat::expect_error(check_simple_name("a1..."), "name '.+' must only contain alphanumeric characters")
-  testthat::expect_error(check_simple_name("a a"), "name '.+' must only contain alphanumeric characters")
-  testthat::expect_error(check_simple_name("_A_b"), "name '.+' must only contain alphanumeric characters")
-})
-
 # make_c_call ----
 testthat::test_that("make_c_call", {
   testthat::expect_identical(make_c_call(1:3), quote(c(1L, 2L, 3L)))
   testthat::expect_identical(make_c_call(1), 1)
 })
+
+# sanitize_id ----
+testthat::describe("sanitize_id", {
+  testthat::it("should replace dots with `_` when id is otherwise valid", {
+    id <- "a.b"
+    ns <- teal.slice:::NS("app")
+    testthat::expect_identical(
+      ns(id),
+      paste0("app-h", substr(rlang::hash(id), 1, 4), "_a_b")
+    )
+  })
+
+  testthat::it("should take vector input", {
+    id <- c("a.b", "a", "b", " c")
+    ns <- teal.slice:::NS("app")
+    testthat::expect_identical(
+      ns(id),
+      c(
+        paste0("app-h", substr(rlang::hash(id[1]), 1, 4), "_a_b"),
+        "app-a",
+        "app-b",
+        paste0("app-h", substr(rlang::hash(id[4]), 1, 4), "__c")
+      )
+    )
+  })
+
+  testthat::it("should allow for integer input", {
+    id <- c(1L, 2L, 3L)
+    ns <- teal.slice:::NS("app")
+    testthat::expect_identical(
+      ns(id),
+      c("app-1", "app-2", "app-3")
+    )
+  })
+
+  testthat::it("should replace non-ASCII characters in middle of id with `_`", {
+    id <- "a$b"
+    ns <- teal.slice:::NS("app")
+    testthat::expect_identical(
+      ns(id),
+      paste0("app-h", substr(rlang::hash(id), 1, 4), "_a_b")
+    )
+  })
+
+  # Test using moduleServer to access the sanitized id
+  testthat::it("should replace non-ASCII characters in the start/end of id with `_`", {
+    id <- "%a bad symbol$"
+    id2 <- "a&b#"
+    id_from_module <- shiny::withReactiveDomain(
+      MockShinySession$new(),
+      teal.slice:::moduleServer(id, function(input, output, session) session$ns("a_good_name"))
+    )
+
+    testthat::expect_identical(
+      id_from_module,
+      paste0("h", substr(rlang::hash(id), 1, 4), "__a_bad_symbol_-a_good_name")
+    )
+  })
+
+  testthat::it("should replace all quotes characters with `_`", {
+    id <- " a.b.c\"d`e'j"
+    testthat::expect_identical(
+      teal.slice:::NS("app", id),
+      paste0("app-h", substr(rlang::hash(id), 1, 4), "__a_b_c_d_e_j")
+    )
+  })
+
+  testthat::it("should replace all escape characters from JQuery selectors", {
+    forbidden <- " !\"#$%&'()*+,./:;<=>?@[\\]^`{|}~]"
+    testthat::expect_identical(
+      teal.slice:::NS("app", forbidden),
+      paste0(
+        "app-h",
+        substr(rlang::hash(forbidden), 1, 4),
+        paste(rep("_", nchar(forbidden) + 1), collapse = "")
+      )
+    )
+  })
+
+  testthat::it("should replace UTF characters outside the allowed range", {
+    id <- "\U41\U05E\U30\U5F\U7A\U1F4AA" # "A:circumflex_accent:0_z:flexed_biceps:
+    testthat::expect_identical(
+      teal.slice:::NS("app", id),
+      paste0(
+        "app-h",
+        substr(rlang::hash(id), 1, 4),
+        "_A_0_z_"
+      )
+    )
+  })
+})