Skip to content

Commit

Permalink
234 range selection with plotly (#289)
Browse files Browse the repository at this point in the history 
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 <[email protected]>
Signed-off-by: Aleksander Chlebowski <[email protected]>
Co-authored-by: Dawid Kałędkowski <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: kartikeya kirar <[email protected]>
Co-authored-by: kartikeya <[email protected]>
  • Loading branch information
@chlebowa @gogonzo
@github-actions @kartikeyakirar
5 people authored Jun 14, 2023
1 parent 64a1ea0 commit 4ec0499
Show file tree
Hide file tree
Showing 13 changed files with 370 additions and 573 deletions.
8 changes: 4 additions & 4 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
10 changes: 0 additions & 10 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
198 changes: 49 additions & 149 deletions R/FilterState-utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
Loading

0 comments on commit 4ec0499

Please sign in to comment.