diff --git a/DESCRIPTION b/DESCRIPTION index 4efb76aa2..1a7071b05 100644 --- a/DESCRIPTION +++ b/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 diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index 32b2b19c8..450414fb5 100644 --- a/R/FilterStateChoices.R +++ b/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) } } ) diff --git a/R/FilteredData.R b/R/FilteredData.R index f3db0c40b..f0b56dc2e 100644 --- a/R/FilteredData.R +++ b/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) { diff --git a/R/choices_labeled.R b/R/choices_labeled.R index 57f795984..21464c62a 100644 --- a/R/choices_labeled.R +++ b/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, diff --git a/man/FilteredData.Rd b/man/FilteredData.Rd index 0f4b16320..d288e8ce6 100644 --- a/man/FilteredData.Rd +++ b/man/FilteredData.Rd @@ -62,7 +62,7 @@ isolate(datasets$get_filter_state()) isolate(datasets$get_call("iris")) isolate(datasets$get_call("mtcars")) -\dontshow{if (requireNamespace("MultiAssayExperiment")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (requireNamespace("MultiAssayExperiment")) withAutoprint(\{ # examplesIf} ### set_filter_state library(shiny) diff --git a/man/MAEFilteredDataset.Rd b/man/MAEFilteredDataset.Rd index 77fc77e97..c746b0c4a 100644 --- a/man/MAEFilteredDataset.Rd +++ b/man/MAEFilteredDataset.Rd @@ -10,7 +10,7 @@ \code{MAEFilteredDataset} \code{R6} class } \examples{ -\dontshow{if (requireNamespace("MultiAssayExperiment")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (requireNamespace("MultiAssayExperiment")) withAutoprint(\{ # examplesIf} # use non-exported function from teal.slice MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice") diff --git a/man/choices_labeled.Rd b/man/choices_labeled.Rd index a37a77fb3..c424703c7 100644 --- a/man/choices_labeled.Rd +++ b/man/choices_labeled.Rd @@ -4,7 +4,7 @@ \alias{choices_labeled} \title{Set "\verb{: