diff --git a/DESCRIPTION b/DESCRIPTION index 81a89c49e..72ad39930 100644 --- a/DESCRIPTION +++ b/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, diff --git a/R/FilterStates.R b/R/FilterStates.R index 4fceca00d..5ac79756e 100644 --- a/R/FilterStates.R +++ b/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, diff --git a/R/FilterStatesMatrix.R b/R/FilterStatesMatrix.R index 776c1bbc9..d5ed4d136 100644 --- a/R/FilterStatesMatrix.R +++ b/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( diff --git a/R/FilterStatesSE.R b/R/FilterStatesSE.R index 686bb44c4..06e14eac1 100644 --- a/R/FilterStatesSE.R +++ b/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 + ) } }, diff --git a/R/FilteredData.R b/R/FilteredData.R index 9b56ee937..c36227c80 100644 --- a/R/FilteredData.R +++ b/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] diff --git a/R/FilteredDataset.R b/R/FilteredDataset.R index 998f5f4d8..2ffefe420 100644 --- a/R/FilteredDataset.R +++ b/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) diff --git a/R/utils.R b/R/utils.R index 725f5a8c9..caceb09c5 100644 --- a/R/utils.R +++ b/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) +} diff --git a/man/check_simple_name.Rd b/man/check_simple_name.Rd deleted file mode 100644 index b8472b5fb..000000000 --- a/man/check_simple_name.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{check_simple_name} -\alias{check_simple_name} -\title{Test whether variable name can be used within \verb{Show R Code}} -\usage{ -check_simple_name(name) -} -\arguments{ -\item{name}{(\code{character}) vector of names to check} -} -\value{ -Returns \code{NULL} or raises error. -} -\description{ -Variable names containing spaces are problematic and must be wrapped in backticks. -Also, they should not start with a number as \code{R} may silently make it valid by changing it. -Therefore, we only allow alphanumeric characters with underscores. -The first character of the \code{name} must be an alphabetic character and can be followed by alphanumeric characters. -} -\keyword{internal} diff --git a/man/sanitize_id.Rd b/man/sanitize_id.Rd new file mode 100644 index 000000000..7a67ebd69 --- /dev/null +++ b/man/sanitize_id.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{sanitize_id} +\alias{sanitize_id} +\title{Encodes ids to be used in JavaScript and Shiny} +\usage{ +sanitize_id(id) +} +\arguments{ +\item{id}{(\code{character(1)}) The id string.} +} +\value{ +Sanitized string that removes special characters and spaces. +} +\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 \code{"_"} +and a 4 character hash of the original id is added to the start of the +resulting id. +} +\keyword{internal} diff --git a/tests/testthat/test-DataframeFilteredDataset.R b/tests/testthat/test-DataframeFilteredDataset.R index 7ab9f8b65..d90987aa9 100644 --- a/tests/testthat/test-DataframeFilteredDataset.R +++ b/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", { diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 91cb3a6aa..6d9d542fd 100644 --- a/tests/testthat/test-utils.R +++ b/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_" + ) + ) + }) +})