Test coverage

DESCRIPTION

@@ -59,6 +59,7 @@ Suggests:
     knitr (>= 1.42),
     MultiAssayExperiment,
     rmarkdown (>= 2.23),
+    rvest (>= 1.0.0),
     shinytest2 (>= 0.4.1),
     SummarizedExperiment,
     testthat (>= 3.2.2),
@@ -79,4 +80,4 @@ Encoding: UTF-8
 Language: en-US
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3

R/FilterStateChoices.R

@@ -122,7 +122,6 @@ ChoicesFilterState <- R6::R6Class( # nolint
   # public methods ----
 
   public = list(
-
     #' @description
     #' Initialize a `FilterState` object.
     #'
@@ -309,14 +308,15 @@ ChoicesFilterState <- R6::R6Class( # nolint
     },
     # If multiple forbidden but selected, restores previous selection with warning.
     check_length = function(values) {
-      if (!private$is_multiple() && length(values) > 1) {
+      if (!private$is_multiple() && length(values) != 1) {
         warning(
           sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
           "Maintaining previous selection."
         )
-        values <- isolate(private$get_selected())
+        isolate(private$get_selected())
+      } else {
+        values
       }
-      values
     },
     remove_out_of_bounds_values = function(values) {
       in_choices_mask <- values %in% private$get_choices()
@@ -463,14 +463,7 @@ ChoicesFilterState <- R6::R6Class( # nolint
               eventExpr = input$selection,
               handlerExpr = {
                 logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
-
-                selection <- if (is.null(input$selection) && private$is_multiple()) {
-                  character(0)
-                } else {
-                  input$selection
-                }
-
-                private$set_selected(selection)
+                private$set_selected(input$selection)
               }
             )
           } else {
@@ -482,11 +475,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
                 if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
                   logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
 
-                  selection <- if (is.null(input$selection) && private$is_multiple()) {
-                    character(0)
-                  } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
-                    # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple
-                    # we should prevent this selection to be processed further.
+                  if (length(input$selection) != 1 && !private$is_multiple()) {
+                    # In optionalSelectInput user is able to select mutliple options.
+                    # But if FilterState is not multiple we should prevent this selection to be processed further.
                     # This is why notification is thrown and dropdown is changed back to latest selected.
                     showNotification(paste(
                       "This filter exclusively supports single selection.",
@@ -496,11 +487,9 @@ ChoicesFilterState <- R6::R6Class( # nolint
                       session, "selection",
                       selected = private$get_selected()
                     )
-                    return(NULL)
-                  } else {
-                    input$selection
                   }
-                  private$set_selected(selection)
+
+                  private$set_selected(input$selection)
                 }
               }
             )

R/FilteredData.R

@@ -741,7 +741,7 @@ FilteredData <- R6::R6Class( # nolint
     #'   panel will be hidden.
     #' @return `NULL`.
     srv_overview = function(id, active_datanames = self$datanames) {
-      checkmate::assert_class(active_datanames, "reactive")
+      checkmate::assert_function(active_datanames)
       moduleServer(
         id = id,
         function(input, output, session) {

R/choices_labeled.R

@@ -11,50 +11,16 @@
 #' @param choices (`character` or `numeric` or `logical`) vector
 #' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then
 #' "Label Missing" will be used.
-#' @param subset a vector that is a subset of `choices`. This is useful if
-#'   only a few variables need to be named. If this argument is used, the returned vector will
-#'   match its order.
 #' @param types vector containing the types of the columns.
 #'
 #' @return A named character vector.
 #'
 #' @keywords internal
 #'
-choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
-  if (is.factor(choices)) {
-    choices <- as.character(choices)
-  }
-
-  stopifnot(
-    is.character(choices) ||
-      is.numeric(choices) ||
-      is.logical(choices) ||
-      (length(choices) == 1 && is.na(choices))
-  )
-
-  if (is.factor(labels)) {
-    labels <- as.character(labels)
-  }
-
-  checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)
-  if (length(choices) != length(labels)) {
-    stop("length of choices must be the same as labels")
-  }
-  stopifnot(is.null(subset) || is.vector(subset))
-  stopifnot(is.null(types) || is.vector(types))
-
-  if (is.vector(types)) {
-    stopifnot(length(choices) == length(types))
-  }
-
-  if (!is.null(subset)) {
-    if (!all(subset %in% choices)) {
-      stop("all of subset variables must be in choices")
-    }
-    labels <- labels[choices %in% subset]
-    types <- types[choices %in% subset]
-    choices <- choices[choices %in% subset]
-  }
+choices_labeled <- function(choices, labels, types = NULL) {
+  checkmate::assert_character(choices)
+  checkmate::assert_character(labels[!is.na(labels)], len = length(choices))
+  checkmate::assert_character(types, len = length(choices), null.ok = TRUE)
 
   is_dupl <- duplicated(choices)
   choices <- choices[!is_dupl]
@@ -68,13 +34,6 @@ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
     character(0)
   }
 
-  if (!is.null(subset)) {
-    ord <- match(subset, choices)
-    choices <- choices[ord]
-    raw_labels <- raw_labels[ord]
-    combined_labels <- combined_labels[ord]
-    types <- types[ord]
-  }
   choices <- structure(
     choices,
     names = combined_labels,