Merge branch 'main' into 612-finalize_objects_session@main

.github/workflows/scheduled.yaml

@@ -38,6 +38,8 @@ jobs:
       strategy: ${{ matrix.test-strategy }}
       additional-env-vars: |
         PKG_SYSREQS_DRY_RUN=true
+      extra-deps: |
+        insightsengineering/teal.code
   branch-cleanup:
     if: >
       github.event_name == 'schedule' || (

.pre-commit-config.yaml

@@ -1,12 +1,12 @@
 ---
 # All available hooks: https://pre-commit.com/hooks.html
 # R specific hooks: https://github.com/lorenzwalthert/precommit
-default_stages: [commit]
+default_stages: [pre-commit]
 default_language_version:
   python: python3
 repos:
   - repo: https://github.com/lorenzwalthert/precommit
-    rev: v0.4.3.9001
+    rev: v0.4.3.9003
     hooks:
       - id: style-files
         name: Style code with `styler`
@@ -30,6 +30,7 @@ repos:
           - shinycssloaders
           - shinyjs
           - shinyWidgets
+          - insightsengineering/teal.code
           - insightsengineering/teal.data
           - insightsengineering/teal.logger
           - insightsengineering/teal.widgets

DESCRIPTION

@@ -1,8 +1,8 @@
 Type: Package
 Package: teal.slice
 Title: Filter Module for 'teal' Applications
-Version: 0.5.1.9012
-Date: 2024-09-16
+Version: 0.5.1.9016
+Date: 2024-11-14
 Authors@R: c(
     person("Dawid", "Kaledkowski", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9533-457X")),
@@ -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,
@@ -58,10 +59,11 @@ Suggests:
     MultiAssayExperiment,
     rmarkdown (>= 2.23),
     SummarizedExperiment,
-    testthat (>= 3.1.5),
+    testthat (>= 3.1.8),
     withr (>= 2.1.0)
 VignetteBuilder:
-    knitr
+    knitr,
+    rmarkdown
 RdMacros:
     lifecycle
 Config/Needs/verdepcheck: rstudio/shiny, rstudio/bslib, mllg/checkmate,

NEWS.md

@@ -1,8 +1,9 @@
-# teal.slice 0.5.1.9012
+# teal.slice 0.5.1.9016
 
 ### Enhancements
 
 * Reduced the space of the filter panel by not displaying the "add filters" UI in a separate panel.
+* The deprecated parameters `code` and `check` were removed from `init_filtered_data()`.
 
 ### Bug fixes
 

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()
@@ -174,7 +178,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-utils.R

@@ -4,8 +4,6 @@
 #'
 #' @param x (`named list`) of datasets.
 #' @param join_keys (`join_keys`) see [`teal.data::join_keys()`].
-#' @param code `r lifecycle::badge("deprecated")`
-#' @param check `r lifecycle::badge("deprecated")`
 #'
 #' @return Object of class `FilteredData`.
 #'
@@ -14,21 +12,9 @@
 #' datasets
 #'
 #' @export
-init_filtered_data <- function(x, join_keys = teal.data::join_keys(), code, check) { # nolint
+init_filtered_data <- function(x, join_keys = teal.data::join_keys()) { # nolint
   checkmate::assert_list(x, any.missing = FALSE, names = "unique")
   checkmate::assert_class(join_keys, "join_keys")
-  if (!missing(code)) {
-    lifecycle::deprecate_stop(
-      "0.5.0",
-      "init_filtered_data(code = 'No longer supported')"
-    )
-  }
-  if (!missing(check)) {
-    lifecycle::deprecate_stop(
-      "0.5.0",
-      "init_filtered_data(check = 'No longer supported')"
-    )
-  }
   FilteredData$new(x, join_keys = join_keys)
 }
 

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
@@ -87,3 +62,56 @@ make_c_call <- function(choices) {
   }
   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", {