更改串扰的 filter_slider() 函数背后的代码

Question

我正在尝试通过更改颜色和字体来修改串扰滤波器滑块的外观。 filter_slider() 函数中没有执行此操作的内置选项，所以我查找了该函数背后的代码，看它是否指定了输出的颜色和字体。我没有发现任何迹象表明它确实如此，所以我想知道是否可以向函数中添加一些行来更改滑块的颜色及其字体。我对编写函数的知识非常有限，所以我不知道如何修改像这样的复杂函数。我在下面附上 filter_slider() 函数背后的代码。

function (id, label, sharedData, column, step = NULL, round = FALSE, 
    ticks = TRUE, animate = FALSE, width = NULL, sep = ",", 
    pre = NULL, post = NULL, timeFormat = NULL, timezone = NULL, 
    dragRange = TRUE, min = NULL, max = NULL) 
{
    if (is.character(column)) {
        column <- lazyeval::f_new(as.symbol(column))
    }
    df <- sharedData$data(withKey = TRUE)
    col <- lazyeval::f_eval(column, df)
    values <- na.omit(col)
    if (is.null(min)) 
        min <- min(values)
    if (is.null(max)) 
        max <- max(values)
    value <- range(values)
    ord <- order(col)
    options <- list(values = col[ord], keys = df$key_[ord], group = sharedData$groupName())
    findStepSize <- function(min, max, step) {
        if (!is.null(step)) 
            return(step)
        range <- max - min
        if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
            step <- pretty(c(min, max), n = 100)
            step[2] - step[1]
        }
        else {
            1
        }
    }
    if (inherits(min, "Date")) {
        if (!inherits(max, "Date") || !inherits(value, 
            "Date")) 
            stop("`min`, `max`, and `value must all be Date or non-Date objects")
        dataType <- "date"
        if (is.null(timeFormat)) 
            timeFormat <- "%F"
    }
    else if (inherits(min, "POSIXt")) {
        if (!inherits(max, "POSIXt") || !inherits(value, 
            "POSIXt")) 
            stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
        dataType <- "datetime"
        if (is.null(timeFormat)) 
            timeFormat <- "%F %T"
    }
    else {
        dataType <- "number"
    }
    if (isTRUE(round)) 
        round <- 0
    else if (!is.numeric(round)) 
        round <- NULL
    step <- findStepSize(min, max, step)
    step <- signif(step, 14)
    if (dataType %in% c("date", "datetime")) {
        to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
        step <- to_ms(max) - to_ms(max - step)
        min <- to_ms(min)
        max <- to_ms(max)
        value <- to_ms(value)
    }
    range <- max - min
    if (ticks) {
        n_steps <- range/step
        scale_factor <- ceiling(n_steps/10)
        n_ticks <- n_steps/scale_factor
    }
    else {
        n_ticks <- NULL
    }
    sliderProps <- dropNulls(list(`data-type` = if (length(value) > 
        1) "double", `data-min` = formatNoSci(min), 
        `data-max` = formatNoSci(max), `data-from` = formatNoSci(value[1]), 
        `data-to` = if (length(value) > 1) formatNoSci(value[2]), 
        `data-step` = formatNoSci(step), `data-grid` = ticks, 
        `data-grid-num` = n_ticks, `data-grid-snap` = FALSE, 
        `data-prettify-separator` = sep, `data-prefix` = pre, 
        `data-postfix` = post, `data-keyboard` = TRUE, 
        `data-keyboard-step` = step/(max - min) * 100, 
        `data-drag-interval` = dragRange, `data-round` = round, 
        `data-data-type` = dataType, `data-time-format` = timeFormat, 
        `data-timezone` = timezone))
    sliderProps <- lapply(sliderProps, function(x) {
        if (identical(x, TRUE)) 
            "true"
        else if (identical(x, FALSE)) 
            "false"
        else x
    })
    sliderTag <- div(class = "form-group crosstalk-input", 
        class = "crosstalk-input-slider js-range-slider", 
        id = id, style = if (!is.null(width)) 
            paste0("width: ", validateCssUnit(width), ";"), 
        if (!is.null(label)) 
            controlLabel(id, label), do.call(tags$input, sliderProps), 
        tags$script(type = "application/json", `data-for` = id, 
            jsonlite::toJSON(options, dataframe = "columns", 
                pretty = TRUE)))
    if (identical(animate, TRUE)) 
        animate <- shiny::animationOptions()
    if (!is.null(animate) && !identical(animate, FALSE)) {
        if (is.null(animate$playButton)) 
            animate$playButton <- shiny::icon("play", lib = "glyphicon")
        if (is.null(animate$pauseButton)) 
            animate$pauseButton <- shiny::icon("pause", 
                lib = "glyphicon")
        sliderTag <- tagAppendChild(sliderTag, tags$div(class = "slider-animate-container", 
            tags$a(href = "#", class = "slider-animate-button", 
                `data-target-id` = id, `data-interval` = animate$interval, 
                `data-loop` = animate$loop, span(class = "play", 
                  animate$playButton), span(class = "pause", 
                  animate$pauseButton))))
    }
    htmltools::browsable(attachDependencies(sliderTag, c(ionrangesliderLibs(), 
        crosstalkLibs())))
}

Answer 1

要更改滑块的字体和颜色，您无需修改函数。相反，您可以添加一些额外的 CSS 来自定义外观。

如果您运行以下 Rmarkdown 文件，您可以看到滑块现在有蓝色文本并且是草书字体，带有红色条。

---
title: "Crosstalk Slider CSS"
output: html_document
---

<style>
.crosstalk-input-slider, .irs-grid-text{
  color: blue;
  font-family: cursive;
}
.irs-bar {
  background-color:red; 
}
</style>

## Crosstalk Slider CSS

```{r}
library(crosstalk)
shared_mtcars <- SharedData$new(mtcars)
filter_checkbox("cyl", "Cylinders", shared_mtcars, ~cyl, inline = TRUE)
filter_slider("hp", "Horsepower", shared_mtcars, ~hp, width = "100%")
filter_select("auto", "Automatic", shared_mtcars, ~ifelse(am == 0, "Yes", "No"))
```

更改串扰的 filter_slider() 函数背后的代码

Altering code behind crosstalk's filter_slider() function

r

slider

crosstalk