234 range selection with plotly

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,

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)

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)
 }