From 4ec0499f97078c4698df9ee792f1990facf1c4bf Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Date: Wed, 14 Jun 2023 17:59:43 +0200 Subject: [PATCH] 234 range selection with `plotly` (#289) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Closes #234 Closes #233 Replaces the range slider in `RangeFilterState` with an interactive `plotly` graph. Two shapes (lines) are drawn on the plot that can be dragged and their position is tracked. An observer listens to events emitted by the plot when shapes are altered (this event is called a "plotly_relayout") and updates selection. Another observer listens to the manual input and updates selection. Finally, a third observer listens to the selection and updates the manual input as well as the shapes on the plot. Since the graph is slower to render, a spinner is added to it to alleviate the negative effect on UX. Numeric (manual) input is now displayed simultaneously with the graphic input, not alternatively. Numeric input receives a debounce. --------- Signed-off-by: kartikeya kirar Signed-off-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Co-authored-by: Dawid Kałędkowski Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: kartikeya kirar Co-authored-by: kartikeya --- DESCRIPTION | 8 +- NAMESPACE | 10 - R/FilterState-utils.R | 198 +++-------- R/FilterStateRange.R | 439 ++++++++++++------------ R/FilterStates-utils.R | 2 +- R/FilteredDataset.R | 2 +- R/teal.slice.R | 10 - R/zzz.R | 29 ++ inst/css/filter-panel.css | 22 +- man/contain_interval.Rd | 45 --- man/fetch_bs_color.Rd | 28 ++ tests/testthat/test-FilterState-utils.R | 78 ----- tests/testthat/test-RangeFilterState.R | 72 ++-- 13 files changed, 370 insertions(+), 573 deletions(-) delete mode 100644 man/contain_interval.Rd create mode 100644 man/fetch_bs_color.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 37ac71e39..65d7c027f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,23 +19,23 @@ Depends: R (>= 4.0), shiny Imports: + bslib (>= 0.4.0), checkmate, dplyr, - ggplot2, grDevices, lifecycle, logger (>= 0.2.0), methods, + plotly, R6, rlang, + shinycssloaders, shinyjs, - shinyWidgets (>= 0.5.0), - stats, + shinyWidgets (>= 0.6.2), teal.data (>= 0.1.2.9011), teal.logger (>= 0.1.1), teal.widgets (>= 0.2.0) Suggests: - bslib, formatters (>= 0.3.1), knitr, MultiAssayExperiment, diff --git a/NAMESPACE b/NAMESPACE index 08229902a..c557a7641 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -45,14 +45,4 @@ export(remove_filter_state) export(set_filter_state) import(R6) import(shiny) -importFrom(dplyr,filter) -importFrom(ggplot2,ggplot) -importFrom(grDevices,rgb) -importFrom(lifecycle,badge) -importFrom(logger,log_trace) importFrom(methods,is) -importFrom(shinyWidgets,pickerOptions) -importFrom(shinyjs,hide) -importFrom(stats,setNames) -importFrom(teal.data,dataset) -importFrom(teal.widgets,optionalSelectInput) diff --git a/R/FilterState-utils.R b/R/FilterState-utils.R index 7022f3545..18bcc8aa8 100644 --- a/R/FilterState-utils.R +++ b/R/FilterState-utils.R @@ -536,163 +536,63 @@ check_in_subset <- function(subset, choices, pre_msg = "") { return(invisible(NULL)) } -#' Find containing limits for interval. -#' -#' Given an interval and a numeric vector, -#' find the smallest interval within the numeric vector that contains the interval. -#' -#' This is a helper function for `RangeFilterState` that modifies slider selection -#' so that the _subsetting call_ includes the value specified by the filter API call. + +#' Get hex code of the current Bootstrap theme color. #' -#' Regardless of the underlying numeric data, the slider always presents 100 steps. -#' The ticks on the slider do not represent actual observations but rather borders between virtual bins. -#' Since the value selected on the slider is passed to `private$selected` and that in turn -#' updates the slider selection, programmatic selection of arbitrary values may inadvertently shift -#' the selection to the closest tick, thereby dropping the actual value set (if it exists in the data). +#' Determines the color specification for the currently active Bootstrap color theme and returns one queried color. #' -#' This function purposely shifts the selection to the closest ticks whose values form an interval -#' that will contain the interval defined by the filter API call. +#' @param color `character(1)` naming one of the available theme colors +#' @param alpha either a `numeric(1)` or `character(1)` specifying transparency +#' in the range of `0-1` or a hexadecimal value `00-ff`, respectively; +#' set to NULL to omit adding the alpha channel #' -#' @param x `numeric(2)` interval to contain -#' @param range `numeric(>=2)` vector of values to contain `x` in +#' @return Named `character(1)` containing a hexadecimal color representation. #' -#' @return Numeric vector of length 2 that lies within `range`. +#' @examples +#' teal.slice:::fetch_bs_color("primary") +#' teal.slice:::fetch_bs_color("danger", 0.35) +#' teal.slice:::fetch_bs_color("danger", "80") #' #' @keywords internal #' -#' @examples -#' \donttest{ -#' ticks <- 1:10 -#' values1 <- c(3, 5) -#' teal.slice:::contain_interval(values1, ticks) -#' values2 <- c(3.1, 5.7) -#' teal.slice:::contain_interval(values2, ticks) -#' values3 <- c(0, 20) -#' teal.slice:::contain_interval(values3, ticks) -#'} -contain_interval <- function(x, range) { - checkmate::assert_numeric(x, len = 2L, any.missing = FALSE, sorted = TRUE) - checkmate::assert_numeric(range, min.len = 2L, any.missing = FALSE, sorted = TRUE) - - x[1] <- Find(function(i) i <= x[1], range, nomatch = min(range), right = TRUE) - x[2] <- Find(function(i) i >= x[2], range, nomatch = max(range)) - x -} +fetch_bs_color <- function(color, alpha = NULL) { + checkmate::assert_string(color) + checkmate::assert( + checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE), + checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE) + ) + # locate file that describes the current theme + ## TODO this is not ideal + sass_file <- bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]] + sass_file <- attr(sass_file, "sass_file_path") -#' Formats selected values of a RangeFilterState for display in the header summary. -#' -#' If a number has more significant digits than the threshhold, it will be -#' formatted in scientific notation. The resulting number will have 'threshold' -#' significant digits. If any `NA`s are present, they will be converted to the -#' character "NA". Similarly `Inf` and `-Inf` will be converted to the strings -#' "Inf" and "-Inf" respectively. -#' -#' -#' @param values Vector of values to format. Can contain `NA`, `Inf`, `-Inf`. -#' @param threshold Number of significant digits above which the number will be -#' formatted in scientific notation. -#' -#' @return Vector of `length(values)` as a string suitable for display. -#' @keywords internal -#' @noRd -format_range_for_summary <- function(values, threshold = 4) { - checkmate::assert_numeric(values, min.len = 1) - checkmate::assert_number(threshold, lower = 1, finite = TRUE) - - ops <- options(scipen = 9999) - on.exit(options(ops)) - - # convert to a string representation - values_str <- vapply( - values, - FUN.VALUE = character(1), - USE.NAMES = FALSE, - FUN = function(value) { - if (is.na(value) || is.finite(value)) { - format(value) - } else { - as.character(value) - } - }) - - n_digits <- n_sig_digits(values_str) - - mapply( - values_str, - n_digits, - USE.NAMES = FALSE, - MoreArgs = list(threshold = threshold), - FUN = function(value, digits, threshold) { - if (digits == -1) { # special case for Inf, -Inf, NA - value - } else if (digits > threshold) { - val <- format(as.numeric(value), digits = threshold, scientific = TRUE) - val <- sub("e", "E", val) - val - } else { - value - } - } - ) -} + # load scss file that encodes variables + variables_file <- readLines(sass_file) + # locate theme color variables + ind <- grep("// scss-docs-(start|end) theme-color-variables", variables_file) + color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)] -#' Count the number of significant digits in a number. -#' -#' Adapted from https://www.r-bloggers.com/2010/04/significant-figures-in-r-and-info-zeros/ -#' The supplied vector should be numbers represented as a character. `NA`, `Inf`, -#' and `-Inf` should be coded as the strings "NA", "Inf", and "-Inf". In these -#' cases, a count of -1 is returned. -#' -#' @param nums A vector of numbers that have been converted to character. -#' -#' @return Vector of `length(nums)` with counts of significant digits. -#' @keywords internal -#' @noRd -n_sig_digits <- function(nums) { - checkmate::assert_character(nums, any.missing = FALSE) - - vapply(nums, FUN.VALUE = numeric(1), USE.NAMES = FALSE, FUN = function(num) { - - if (grepl("e", num)) return(-1) - if (num == "NA") return(-1) - if (num == "Inf" || num == "-Inf") return(-1) - - sig_digits <- 1 - i <- 0 - - if (grepl("\\.", num)) { - - num_split <- unlist(strsplit(num, "\\.")) - num_str <- paste(num_split[1], num_split[2], sep = "") - current_n_digits <- nchar(num_str) - - while (i < current_n_digits) { - - if (substr(num_str, i + 1, i + 1) == "0") { - i <- i + 1 - next - } else { - sig_digits <- current_n_digits - i - break - } - } - } else { - - num_str <- num - current_n_digits <- nchar(num_str) - - while (i < current_n_digits) { - if (substr(num_str, current_n_digits - i, current_n_digits - i) == "0") { - i <- i + 1 - next - } else { - sig_digits <- current_n_digits - i - break - } - } - } - - return(sig_digits) - }) + # extract colors names + color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions) + + # verify that an available color was requested + checkmate::assert_choice(color, color_names) + + # extract color references + color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions) + + # translate references to color codes + color_specification <- structure(color_references, names = color_names) + color_specification <- vapply(color_specification, function(x) { + line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE) + code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line) + code + }, character(1L)) + + if (!is.null(alpha)) { + if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha)) + } + + paste0(color_specification[color], alpha) } diff --git a/R/FilterStateRange.R b/R/FilterStateRange.R index a62793e44..3c2b398c3 100644 --- a/R/FilterStateRange.R +++ b/R/FilterStateRange.R @@ -205,18 +205,58 @@ RangeFilterState <- R6::R6Class( # nolint } private$set_selected(selected) - private$unfiltered_histogram <- ggplot2::ggplot(data.frame(x = Filter(is.finite, private$x))) + - ggplot2::geom_histogram( - ggplot2::aes(x = Filter(is.finite, private$x)), - bins = 100, - fill = grDevices::rgb(211 / 255, 211 / 255, 211 / 255), - color = grDevices::rgb(211 / 255, 211 / 255, 211 / 255) - ) + - ggplot2::theme_void() + - ggplot2::coord_cartesian( - expand = FALSE, - xlim = c(private$choices[1L], private$choices[2L]) + private$plot_data <- list( + type = "histogram", + nbinsx = 50, + x = Filter(Negate(is.na), Filter(is.finite, private$x)), + color = I(fetch_bs_color("secondary")), + alpha = 0.2, + bingroup = 1, + showlegend = FALSE, + hoverinfo = "none" + ) + private$plot_mask <- list(list( + type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0), + x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper" + )) + private$plot_layout <- reactive({ + shapes <- private$get_shape_properties(private$get_selected()) + if (private$is_disabled()) shapes <- c(shapes, private$plot_mask) + list( + barmode = "overlay", + xaxis = list( + range = private$choices, + rangeslider = list(thickness = 0), + showticklabels = TRUE, + ticks = "outside", + ticklen = 2, + tickmode = "auto", + nticks = 10 + ), + yaxis = list(showgrid = FALSE, showticklabels = FALSE), + margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE), + plot_bgcolor = "#FFFFFF00", + paper_bgcolor = "#FFFFFF00", + shapes = shapes + ) + }) + private$plot_config <- reactive({ + list( + doubleClick = "reset", + displayModeBar = FALSE, + edits = list(shapePosition = TRUE), + staticPlot = private$is_disabled() + ) + }) + private$plot_filtered <- reactive({ + finite_values <- Filter(is.finite, private$x_reactive()) + list( + x = finite_values, + bingroup = 1, + color = I(fetch_bs_color("primary")) ) + }) + invisible(self) }, @@ -253,12 +293,15 @@ RangeFilterState <- R6::R6Class( # nolint # private fields---- private = list( - unfiltered_histogram = NULL, # ggplot object inf_count = integer(0), inf_filtered_count = NULL, is_integer = logical(0), - slider_step = numeric(0), # step for the slider input widget, calculated from input data (x) - slider_ticks = numeric(0), # allowed values for the slider input widget, calculated from input data (x) + numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x) + plot_data = NULL, + plot_mask = list(), + plot_layout = NULL, + plot_config = NULL, + plot_filtered = NULL, # private methods ---- @@ -295,13 +338,10 @@ RangeFilterState <- R6::R6Class( # nolint # Required for displaying ticks on the slider, can modify choices! if (identical(diff(x_range), 0)) { choices <- x_range - private$slider_ticks <- signif(x_range, digits = 10) - private$slider_step <- NULL } else { x_pretty <- pretty(x_range, 100L) choices <- range(x_pretty) - private$slider_ticks <- signif(x_pretty, digits = 10) - private$slider_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) + private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) } private$choices <- choices invisible(NULL) @@ -360,23 +400,16 @@ RangeFilterState <- R6::R6Class( # nolint cast_and_validate = function(values) { if (!is.atomic(values)) stop("Values to set must be an atomic vector.") values <- as.numeric(values) - if (any(is.na(values))) stop("The array of set values must contain values coercible to numeric.") - if (length(values) != 2) stop("The array of set values must have length two.") - - values_adjusted <- contain_interval(values, private$slider_ticks) - if (!isTRUE(all.equal(values, values_adjusted))) { - logger::log_warn(sprintf( - paste( - "Programmatic range specification on %s was adjusted to existing slider ticks.", - "It is now broader in order to contain the specified values." - ), - private$varname - )) - } - values_adjusted + if (any(is.na(values))) stop("Vector of set values must contain values coercible to numeric.") + if (length(values) != 2) stop("Vector of set values must have length two.") + if (values[1L] > values[2L]) stop("Vector of set values must be sorted.") + + values }, - # for numeric ranges selecting out of bound values is allowed + # Trim selection to limits imposed by private$choices remove_out_of_bound_values = function(values) { + if (values[1L] < private$choices[1L]) values[1L] <- private$choices[1L] + if (values[2L] > private$choices[2L]) values[2L] <- private$choices[2L] values }, @@ -398,6 +431,15 @@ RangeFilterState <- R6::R6Class( # nolint } }, + # obtain shape determination for histogram + # returns a list that is passed to plotly's layout.shapes property + get_shape_properties = function(values) { + list( + list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"), + list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper") + ) + }, + # shiny modules ---- # UI Module for `RangeFilterState`. @@ -408,59 +450,65 @@ RangeFilterState <- R6::R6Class( # nolint ui_inputs = function(id) { ns <- NS(id) - ui_input_slider <- teal.widgets::optionalSliderInput( - inputId = ns("selection"), - label = NULL, - min = private$choices[1L], - max = private$choices[2L], - value = shiny::isolate(private$selected()), - step = private$slider_step, - width = "100%" - ) - ui_input_manual <- shinyWidgets::numericRangeInput( + ui_input <- shinyWidgets::numericRangeInput( inputId = ns("selection_manual"), label = NULL, min = private$choices[1L], max = private$choices[2L], value = shiny::isolate(private$selected()), - step = private$slider_step, + step = private$numeric_step, width = "100%" ) - if (shiny::isolate(private$is_disabled())) { - ui_input_slider <- shinyjs::disabled(ui_input_slider) - ui_input_manual <- shinyjs::disabled(ui_input_manual) - } + if (shiny::isolate(private$is_disabled())) ui_input <- shinyjs::disabled(ui_input) tagList( - shinyWidgets::switchInput( - ns("manual"), - label = "Enter manually", - size = "small", - labelWidth = "100px", - onLabel = "Yes", - offLabel = "No", - onStatus = "info", - offStatus = "info", - disabled = shiny::isolate(private$is_disabled()) - ), - conditionalPanel( - ns = ns, - condition = "input.manual === false", + div( + class = "choices_state", + tags$head(tags$script( + # Inline JS code for popover functionality. + # Adding the script inline because when added from a file with include_js_files(), + # it only works in the first info_button instance and not others. + HTML( + '$(document).ready(function() { + $("[data-toggle=\'popover\']").popover(); + + $(document).on("click", function (e) { + if (!$("[data-toggle=\'popover\']").is(e.target) && + $("[data-toggle=\'popover\']").has(e.target).length === 0 && + $(".popover").has(e.target).length === 0) { + $("[data-toggle=\'popover\']").popover("hide"); + } + }); + });' + ) + )), div( - class = "choices_state", - div( - class = "filterPlotOverlayRange", - plotOutput(ns("plot"), height = "100%"), + actionLink( + ns("plotly_info"), + label = NULL, + icon = icon("question-circle"), + "data-toggle" = "popover", + "data-html" = "true", + "data-placement" = "left", + "data-trigger" = "click", + "data-title" = "Plot actions", + "data-content" = "

+ Drag vertical lines to set selection.
+ Drag across plot to zoom in.
+ Drag axis to pan.
+ Double click to zoom out." ), - div(class = "filterRangeSlider", ui_input_slider) + style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;" + ), + shinycssloaders::withSpinner( + plotly::plotlyOutput(ns("plot"), height = "50px"), + type = 4, + size = 0.25, + hide.ui = FALSE ) ), - conditionalPanel( - ns = ns, - condition = "input.manual === true", - ui_input_manual - ), + ui_input, div( class = "filter-card-body-keep-na-inf", private$keep_inf_ui(ns("keep_inf")), @@ -480,87 +528,96 @@ RangeFilterState <- R6::R6Class( # nolint function(input, output, session) { logger::log_trace("RangeFilterState$server initializing, dataname: { private$dataname }") - finite_values <- reactive(Filter(is.finite, private$x_reactive())) - output$plot <- bindCache( - finite_values(), - cache = "session", - x = renderPlot( - bg = "transparent", - height = 25, - expr = { - private$unfiltered_histogram + - if (!is.null(finite_values())) { - ggplot2::geom_histogram( - data = data.frame(x = finite_values()), - ggplot2::aes(x = x), - bins = 100, - fill = grDevices::rgb(173 / 255, 216 / 255, 230 / 255), - color = grDevices::rgb(173 / 255, 216 / 255, 230 / 255) + # Capture manual input with debounce. + selection_manual <- debounce(reactive(input$selection_manual), 200) + + # Prepare for histogram construction. + plot_data <- c(private$plot_data, source = session$ns("histogram_plot")) + + # Display histogram, adding a second trace that contains filtered data. + output$plot <- plotly::renderPlotly({ + histogram <- do.call(plotly::plot_ly, plot_data) + histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) + histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config())) + histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) + histogram + }) + + # Dragging shapes (lines) on plot updates selection. + private$observers$relayout <- + observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, + eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")), + handlerExpr = { + logger::log_trace( + sprintf( + "RangeFilterState$server@1 selection of variable %s changed, dataname: %s", + private$varname, + private$dataname + ) + ) + event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")) + if (any(grepl("shapes", names(event)))) { + line_positions <- private$get_selected() + if (any(grepl("shapes[0]", names(event), fixed = TRUE))) { + line_positions[1] <- event[["shapes[0].x0"]] + } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) { + line_positions[2] <- event[["shapes[1].x0"]] + } + # If one line was dragged past the other, abort action and reset lines. + if (line_positions[1] > line_positions[2]) { + showNotification( + "Numeric range start value must be less than end value.", + type = "warning" + ) + plotly::plotlyProxyInvoke( + plotly::plotlyProxy("plot"), + "relayout", + shapes = private$get_shape_properties(private$get_selected()) ) - } else { - NULL + return(NULL) } - } - ) - ) - # this observer is needed in the situation when private$selected has been - # changed directly by the api - then it's needed to rerender UI element - # to show relevant values - private$observers$selection_api <- observeEvent( - ignoreNULL = FALSE, - ignoreInit = TRUE, - eventExpr = private$get_selected(), - handlerExpr = { - logger::log_trace( - sprintf( - "RangeFilterState$server@2 state of %s changed, dataname: %s", - private$get_varname(), - private$dataname - ) - ) - if (!isTRUE(all.equal(input$selection, private$get_selected()))) { - updateSliderInput( - session = session, - inputId = "selection", - value = private$selected() - ) + private$set_selected(signif(line_positions, digits = 4L)) + } } - } - ) + ) - private$observers$selection <- observeEvent( - ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in `selectInput` - ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = input$selection, - handlerExpr = { - logger::log_trace( - sprintf( - "RangeFilterState$server@3 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname + # Change in selection updates shapes (lines) on plot and numeric input. + private$observers$selection_api <- + observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, + eventExpr = private$get_selected(), + handlerExpr = { + logger::log_trace( + sprintf( + "RangeFilterState$server@2 state of %s changed, dataname: %s", + private$get_varname(), + private$dataname + ) ) - ) - if (!isTRUE(all.equal(input$selection, private$get_selected()))) { - private$set_selected(input$selection) + if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) { + shinyWidgets::updateNumericRangeInput( + session = session, + inputId = "selection_manual", + value = private$get_selected() + ) + } } - } - ) + ) + # Manual input updates selection. private$observers$selection_manual <- observeEvent( ignoreNULL = FALSE, ignoreInit = TRUE, - eventExpr = input$selection_manual, + eventExpr = selection_manual(), handlerExpr = { - # 3 separate checks are required here to prevent errors - # - # if the user sets either input to 'e' it will return NA - # this NA would cause the lower > upper check to return NA - # and the if(lower > upper) check would throw an error - # - # if lower > manual, contain_interval() will error because it - # expects it's input to be sorted - if (any(is.na(input$selection_manual))) { + selection <- selection_manual() + + # Abort and reset if non-numeric values is entered. + if (any(is.na(selection))) { showNotification( "Numeric range values must be numbers.", type = "warning" @@ -572,7 +629,9 @@ RangeFilterState <- R6::R6Class( # nolint ) return(NULL) } - if (input$selection_manual[1] > input$selection_manual[2]) { + + # Abort and reset if reversed choices are specified. + if (selection[1] > selection[2]) { showNotification( "Numeric range start value must be less than end value.", type = "warning" @@ -584,24 +643,7 @@ RangeFilterState <- R6::R6Class( # nolint ) return(NULL) } - # all.equal not enough here b/c tolerance - # all.equal(0.000000001, 0) is TRUE - out_of_range <- isFALSE(identical( - input$selection_manual, - contain_interval(input$selection_manual, private$slider_ticks) - )) - if (out_of_range) { - showNotification( - "Numeric range values should correspond to slider values.", - type = "warning" - ) - shinyWidgets::updateNumericRangeInput( - session = session, - inputId = "selection_manual", - value = private$get_selected() - ) - return(NULL) - } + logger::log_trace( sprintf( "RangeFilterState$server@3 selection of variable %s changed, dataname: %s", @@ -609,8 +651,8 @@ RangeFilterState <- R6::R6Class( # nolint private$dataname ) ) - if (!isTRUE(all.equal(input$selection_manual, private$get_selected()))) { - private$set_selected(input$selection_manual) + if (!isTRUE(all.equal(selection, private$get_selected()))) { + private$set_selected(selection) } } ) @@ -619,34 +661,12 @@ RangeFilterState <- R6::R6Class( # nolint private$keep_na_srv("keep_na") observeEvent(private$is_disabled(), { - shinyWidgets::updateSwitchInput( - session = session, - inputId = "manual", - disabled = private$is_disabled() + shinyjs::toggleState( + id = "selection_manual", + condition = !private$is_disabled() ) }) - observeEvent(input$manual, - { - if (input$manual) { - private$set_selected(input$selection) - shinyWidgets::updateNumericRangeInput( - session = session, - inputId = "selection_manual", - value = input$selection - ) - } else { - private$set_selected(input$selection_manual) - updateSliderInput( - session = session, - inputId = "selection", - value = input$selection_manual - ) - } - }, - ignoreInit = TRUE - ) - logger::log_trace("RangeFilterState$server initialized, dataname: { private$dataname }") NULL } @@ -658,32 +678,23 @@ RangeFilterState <- R6::R6Class( # nolint function(input, output, session) { logger::log_trace("RangeFilterState$server initializing, dataname: { private$dataname }") - finite_values <- reactive(Filter(is.finite, private$x_reactive())) - output$plot <- bindCache( - finite_values(), - cache = "session", - x = renderPlot( - bg = "transparent", - height = 25, - expr = { - private$unfiltered_histogram + - if (!is.null(finite_values())) { - ggplot2::geom_histogram( - data = data.frame(x = finite_values()), - ggplot2::aes(x = x), - bins = 100, - fill = grDevices::rgb(173 / 255, 216 / 255, 230 / 255), - color = grDevices::rgb(173 / 255, 216 / 255, 230 / 255) - ) - } else { - NULL - } - } - ) - ) + plot_config <- private$plot_config() + plot_config$staticPlot <- TRUE + + output$plot <- plotly::renderPlotly({ + histogram <- do.call(plotly::plot_ly, private$plot_data) + histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) + histogram <- do.call(plotly::config, c(list(p = histogram), plot_config)) + histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) + histogram + }) output$selection <- renderUI({ - plotOutput(session$ns("plot"), height = "2em") + shinycssloaders::withSpinner( + plotly::plotlyOutput(session$ns("plot"), height = "50px"), + type = 4, + size = 0.25 + ) }) logger::log_trace("RangeFilterState$server initialized, dataname: { private$dataname }") @@ -698,11 +709,9 @@ RangeFilterState <- R6::R6Class( # nolint # if NA or Inf are included also # @return `shiny.tag` to include in the `ui_summary` content_summary = function() { - fmt_selected <- format_range_for_summary(private$get_selected()) - min <- fmt_selected[1] - max <- fmt_selected[2] + selection <- private$get_selected() tagList( - tags$span(shiny::HTML(min, "–", max), class = "filter-card-summary-value"), + tags$span(shiny::HTML(selection[1], "–", selection[2]), class = "filter-card-summary-value"), tags$span( class = "filter-card-summary-controls", if (isTRUE(private$get_keep_na()) && private$na_count > 0) { diff --git a/R/FilterStates-utils.R b/R/FilterStates-utils.R index 1ea3e768d..44c044894 100644 --- a/R/FilterStates-utils.R +++ b/R/FilterStates-utils.R @@ -205,7 +205,7 @@ data_choices_labeled <- function(data, if (length(choices) == 0) { return(character(0)) } - choice_types <- setNames(variable_types(data = data, columns = choices), choices) + choice_types <- stats::setNames(variable_types(data = data, columns = choices), choices) choice_types[keys] <- "primary_key" choices_labeled( diff --git a/R/FilteredDataset.R b/R/FilteredDataset.R index 86095f75a..442e217b6 100644 --- a/R/FilteredDataset.R +++ b/R/FilteredDataset.R @@ -402,7 +402,7 @@ FilteredDataset <- R6::R6Class( # nolint add_filter_states = function(filter_states, id) { checkmate::assert_class(filter_states, "FilterStates") checkmate::assert_string(id) - x <- setNames(list(filter_states), id) + x <- stats::setNames(list(filter_states), id) private$filter_states <- c(private$get_filter_states(), x) }, diff --git a/R/teal.slice.R b/R/teal.slice.R index ef716d2a0..1e3de3d9d 100644 --- a/R/teal.slice.R +++ b/R/teal.slice.R @@ -8,15 +8,5 @@ # Fix R CMD check notes #' @import R6 #' @import shiny -#' @importFrom dplyr filter -#' @importFrom ggplot2 ggplot -#' @importFrom grDevices rgb -#' @importFrom lifecycle badge -#' @importFrom logger log_trace #' @importFrom methods is -#' @importFrom shinyWidgets pickerOptions -#' @importFrom shinyjs hide -#' @importFrom stats setNames -#' @importFrom teal.data dataset -#' @importFrom teal.widgets optionalSelectInput NULL diff --git a/R/zzz.R b/R/zzz.R index 6e1656208..88113345a 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -18,3 +18,32 @@ ### END GLOBAL VARIABLES ### + + +### ENSURE CHECK PASSES + +# This function is necessary for check to properly process code dependencies within R6 classes. +# If `package` is listed in `Imports` in `DESCRIPTION`, +# (1) check goes through `NAMESPACE` looking for any `importFrom(package,)` statements +# or an `import(package)` statement. If none are found, +# (2) check looks for `package::*` calls in the code. If none are found again, +# (3) check throws a NOTE; +# # Namespaces in Imports field not imported from: +# # 'package' +# # All declared Imports should be used. +# This note is banned by our CI. +# When package::* statements are made within an R6 class, they are not registered. +# This function provides single references to the imported namespaces for check to notice. +.rectify_dependencies_check <- function() { + dplyr::filter + grDevices::rgb + lifecycle::badge + logger::log_trace + plotly::plot_ly + shinycssloaders::withSpinner + shinyWidgets::pickerOptions + teal.widgets::optionalSelectInput +} + + +### END ENSURE CHECK PASSES diff --git a/inst/css/filter-panel.css b/inst/css/filter-panel.css index 42c52c902..cc64a6319 100644 --- a/inst/css/filter-panel.css +++ b/inst/css/filter-panel.css @@ -164,15 +164,13 @@ a.remove_all:hover { .choices_state_label_unfiltered { background-color:lightgray; - height:2rem; + height: 2rem; margin-top: -3px; display:inline-block; position: absolute; } .filterPlotOverlayRange { - margin: 10px 0px -25px; - height: 25px; animation: 0.75s ease-out 0s 1 shinyDataFilterEnlargeY, 0.5s ease-in 0s 1 shinyDataFilterFadeIn; transform-origin: bottom; @@ -180,12 +178,6 @@ a.remove_all:hover { max-width: 100%; } -/* Needed for bs4 */ -.filterRangeSlider { - width: 100%; - max-width: 100%; -} - .irs.irs--shiny.js-irs-0.irs-with-grid * { font-size: 0.85em; } @@ -361,3 +353,15 @@ a.remove_all:hover { .filter_datelike_input input { font-size: 1em !important; } + +.choices_state { + margin-bottom: .45rem; +} + +.popover-header { + margin-top: 0em; +} + +.popover-body { + margin-bottom: -1rem; +} diff --git a/man/contain_interval.Rd b/man/contain_interval.Rd deleted file mode 100644 index 2d332d982..000000000 --- a/man/contain_interval.Rd +++ /dev/null @@ -1,45 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FilterState-utils.R -\name{contain_interval} -\alias{contain_interval} -\title{Find containing limits for interval.} -\usage{ -contain_interval(x, range) -} -\arguments{ -\item{x}{\code{numeric(2)} interval to contain} - -\item{range}{\verb{numeric(>=2)} vector of values to contain \code{x} in} -} -\value{ -Numeric vector of length 2 that lies within \code{range}. -} -\description{ -Given an interval and a numeric vector, -find the smallest interval within the numeric vector that contains the interval. -} -\details{ -This is a helper function for \code{RangeFilterState} that modifies slider selection -so that the \emph{subsetting call} includes the value specified by the filter API call. - -Regardless of the underlying numeric data, the slider always presents 100 steps. -The ticks on the slider do not represent actual observations but rather borders between virtual bins. -Since the value selected on the slider is passed to \code{private$selected} and that in turn -updates the slider selection, programmatic selection of arbitrary values may inadvertently shift -the selection to the closest tick, thereby dropping the actual value set (if it exists in the data). - -This function purposely shifts the selection to the closest ticks whose values form an interval -that will contain the interval defined by the filter API call. -} -\examples{ -\donttest{ -ticks <- 1:10 -values1 <- c(3, 5) -teal.slice:::contain_interval(values1, ticks) -values2 <- c(3.1, 5.7) -teal.slice:::contain_interval(values2, ticks) -values3 <- c(0, 20) -teal.slice:::contain_interval(values3, ticks) -} -} -\keyword{internal} diff --git a/man/fetch_bs_color.Rd b/man/fetch_bs_color.Rd new file mode 100644 index 000000000..0b6974072 --- /dev/null +++ b/man/fetch_bs_color.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FilterState-utils.R +\name{fetch_bs_color} +\alias{fetch_bs_color} +\title{Get hex code of the current Bootstrap theme color.} +\usage{ +fetch_bs_color(color, alpha = NULL) +} +\arguments{ +\item{color}{\code{character(1)} naming one of the available theme colors} + +\item{alpha}{either a \code{numeric(1)} or \code{character(1)} specifying transparency +in the range of \code{0-1} or a hexadecimal value \code{00-ff}, respectively; +set to NULL to omit adding the alpha channel} +} +\value{ +Named \code{character(1)} containing a hexadecimal color representation. +} +\description{ +Determines the color specification for the currently active Bootstrap color theme and returns one queried color. +} +\examples{ +teal.slice:::fetch_bs_color("primary") +teal.slice:::fetch_bs_color("danger", 0.35) +teal.slice:::fetch_bs_color("danger", "80") + +} +\keyword{internal} diff --git a/tests/testthat/test-FilterState-utils.R b/tests/testthat/test-FilterState-utils.R index 658eedd35..9678bef03 100644 --- a/tests/testthat/test-FilterState-utils.R +++ b/tests/testthat/test-FilterState-utils.R @@ -43,81 +43,3 @@ testthat::test_that("check_in_subset prepends error message", { "^premessage.*not in valid choices" ) }) - - -# contain_interval ---- -testthat::test_that("contain_interval accepts proper arguments", { - testthat::expect_no_error(contain_interval(c(3, 5), 1:10)) - testthat::expect_error(contain_interval(c("1", "2"), 1:10), "Assertion on 'x' failed") - testthat::expect_error(contain_interval(1, 1:10), "Assertion on 'x' failed") - testthat::expect_error(contain_interval(c(1, NA), 1:10), "Assertion on 'x' failed") - testthat::expect_error(contain_interval(c(5, 3), 1:10), "Assertion on 'x' failed") - - testthat::expect_error(contain_interval(c(3, 5), letters[1:10]), "Assertion on 'range' failed") - testthat::expect_error(contain_interval(c(3, 5), 1), "Assertion on 'range' failed") - testthat::expect_error(contain_interval(c(3, 5), c(1:10, NA)), "Assertion on 'range' failed") - testthat::expect_error(contain_interval(c(3, 5), 10:1), "Assertion on 'range' failed") -}) - -testthat::test_that("contain_interval returns containing range", { - testthat::expect_equal(contain_interval(c(3.2, 5.7), 1:10), c(3, 6)) -}) - -testthat::test_that("contain_interval returns 'x' if interval matches ticks", { - testthat::expect_equal(contain_interval(c(3, 5), 1:10), c(3, 5)) -}) - -testthat::test_that("contain_interval returns 'range' if 'x' is x is out of bounds", { - testthat::expect_equal(contain_interval(c(0, 11), 1:10), c(1, 10)) -}) - -testthat::test_that("n_sig_digits counts correctly", { - values <- as.character(c( - 1.23, - exp(1), - pi, - 45678, - 0.0001245 - )) - - expected <- c( - 3, - 15, - 15, - 5, - 4 - ) - - testthat::expect_equal(n_sig_digits(values), expected) -}) - -testthat::test_that("formatting of range filter state for card summary", { - values <- c( - -10.000000235, - -4.5, - 0.00, - 0.00412, - pi, - 12.01, - 20.0, - 14328948789, - -Inf, - Inf, - NA - ) - expected <- c( - "-10", - "-4.5", - "0", - "0.00412", - "3.142E+00", - "12.01", - "20", - "1.433E+10", - "-Inf", - "Inf", - "NA" - ) - - testthat::expect_equal(format_range_for_summary(values), expected) -}) diff --git a/tests/testthat/test-RangeFilterState.R b/tests/testthat/test-RangeFilterState.R index 21135a386..56a986493 100644 --- a/tests/testthat/test-RangeFilterState.R +++ b/tests/testthat/test-RangeFilterState.R @@ -10,7 +10,7 @@ testthat::test_that("constructor accepts numerical values", { testthat::test_that("constructor accepts infinite values but not infinite only", { testthat::expect_no_error( - RangeFilterState$new(c(nums, Inf, -Inf), dataname = "data", varname = "variable") + RangeFilterState$new(c(nums, Inf), dataname = "data", varname = "variable") ) testthat::expect_error( RangeFilterState$new(Inf, dataname = "data", varname = "variable"), @@ -29,22 +29,12 @@ testthat::test_that("constructor initializes keep_inf = TRUE by default if x con testthat::expect_true(shiny::isolate(filter_state$get_state())$keep_inf) }) -testthat::test_that("constructor raises error when selected is not sorted", { - testthat::expect_error( - RangeFilterState$new( - nums, - dataname = "data", varname = "variable", selected = nums[c(10, 1)] - ), - "Assertion on 'x' failed: Must be sorted" - ) -}) - testthat::test_that("constructor raises error when selection is not numeric or coercible", { testthat::expect_error( suppressWarnings( RangeFilterState$new(nums, dataname = "data", varname = "variable", selected = c("a", "b")) ), - "The array of set values must contain values coercible to numeric" + "Vector of set values must contain values coercible to numeric" ) }) @@ -87,7 +77,7 @@ testthat::test_that("set_state: selected accepts vector of two numbers or coerci ) testthat::expect_error( filter_state$set_state(filter_var(dataname = "data", varname = "variable", selected = nums[1])), - "The array of set values must have length two" + "Vector of set values must have length two" ) testthat::expect_no_error( filter_state$set_state(filter_var(dataname = "data", varname = "variable", selected = as.character(1:2))) @@ -96,7 +86,7 @@ testthat::test_that("set_state: selected accepts vector of two numbers or coerci suppressWarnings( filter_state$set_state(filter_var(dataname = "data", varname = "variable", selected = as.character("a", "b"))) ), - "The array of set values must contain values coercible to numeric" + "Vector of set values must contain values coercible to numeric" ) testthat::expect_error( filter_state$set_state(filter_var(dataname = "data", varname = "variable", selected = c(print))), @@ -105,7 +95,6 @@ testthat::test_that("set_state: selected accepts vector of two numbers or coerci }) -# set_state ---- testthat::test_that("set_state: selected accepts numeric vector of length 2", { filter_state <- RangeFilterState$new(nums, dataname = "data", varname = "variable") testthat::expect_no_error( @@ -113,61 +102,42 @@ testthat::test_that("set_state: selected accepts numeric vector of length 2", { ) testthat::expect_error( filter_state$set_state(filter_var(selected = nums[1], dataname = "data", varname = "variable")), - "The array of set values must have length two" + "Vector of set values must have length two" ) testthat::expect_error( suppressWarnings( filter_state$set_state(filter_var(selected = c("a", "b"), dataname = "data", varname = "variable")) ), - "The array of set values must contain values coercible to numeric" + "Vector of set values must contain values coercible to numeric" ) }) -testthat::test_that("set_state: selected raises `logger` warning when selection is not within the possible range", { - filter_state <- RangeFilterState$new(nums, dataname = "data", varname = "variable") - testthat::expect_output( - filter_state$set_state( - filter_var(nums, dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10])) - ), - "Programmatic range specification" - ) - testthat::expect_output( - filter_state$set_state( - filter_var(nums, dataname = "data", varname = "variable", selected = c(nums[1], nums[10] + 1)) - ), - "Programmatic range" - ) - testthat::expect_output( - filter_state$set_state( - filter_var(nums, dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10] + 1)) +testthat::test_that("set_state: selected raises error when selected is not sorted", { + testthat::expect_error( + RangeFilterState$new( + nums, + dataname = "data", varname = "variable", selected = nums[c(10, 1)] ), - "Programmatic range" + "Vector of set values must be sorted" ) }) testthat::test_that("set_state: selected range is limited to lower and upper bound of possible range", { filter_state <- RangeFilterState$new(nums, dataname = "data", varname = "variable") - testthat::expect_output( - filter_state$set_state( - filter_var(dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10])) - ), - "Programmatic range" + filter_state$set_state( + filter_var(dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10])) ) testthat::expect_equal(shiny::isolate(filter_state$get_state()$selected), c(nums[1], nums[10])) - testthat::expect_output( - filter_state$set_state( - filter_var(dataname = "data", varname = "variable", selected = c(nums[1], nums[10] + 1)) - ), - "Programmatic range" + + filter_state$set_state( + filter_var(dataname = "data", varname = "variable", selected = c(nums[1], nums[10] + 1)) ) testthat::expect_equal(shiny::isolate(filter_state$get_state()$selected), c(nums[1], nums[10])) - testthat::expect_output( - filter_state$set_state( - filter_var(dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10] + 1)) - ), - "Programmatic range" + + filter_state$set_state( + filter_var(dataname = "data", varname = "variable", selected = c(nums[1] - 1, nums[10] + 1)) ) testthat::expect_equal(shiny::isolate(filter_state$get_state()$selected), c(nums[1], nums[10])) }) @@ -178,7 +148,7 @@ testthat::test_that("set_state: selected raises error when selection is not coer suppressWarnings( filter_state$set_state(filter_var(dataname = "data", varname = "variable", selected = c("a", "b"))) ), - "The array of set values must contain values coercible to numeric" + "Vector of set values must contain values coercible to numeric" ) })