Choosing brewer colour

[galib36]

Hello Dean Attali, The colourpicker tool is really great. I was wondering do you plan to introduce choosing colorBrewer here instead of a single colour? I want to choose a colour brewer for scale_colour_gradientn function in my shiny app. It is for a Heatmap I am making where the user will choose the colour gradient.

Thank you.

[daattali]

I've tried thinking in the past about adding a way to select a gradient , but I couldn't think of a nice simple way to include it. If you have javascript and UI skills, I'd be very happy to get your ideas for how that feature would look. It would need to be implemented here

[galib36]

Thank you @daattali . I am looking for a simple option like the following image.

[daattali]

That looks like a completely different widget. It could be added as a new input, but I don't really have strong opinion on it. If anyone would like to submit a PR I'd be happy to help getting it in

[gitdemont]

I have also some interest for this kind of feature. I wrote some lines for this to incorporate in a shiny app I am working on.

FWIW

library(shiny)

# choices has to be a named list of color palettes
# colorbreak = TRUE is not compatible with all browsers (not working for me with Rstudio RStudio 2022.02.1+461 for instance)

# create the gradient input
gradientInput <- function (inputId, label, choices, selected = NULL,
                           multiple = FALSE, selectize = TRUE, size = NULL,         # will be forced
                           colorbreak = FALSE,             # to use continuous vs categorical colors
                           colorid = paste0(inputId, "-gradient"),       # to retrieve colors values
                           width = NULL, options = NULL) {
  # force "multiple", "selectize", and "size" arguments
  if(length(multiple) != 1 || multiple) {
    message("'multiple' has been forced to FALSE")
    multiple <- FALSE
  }
  if(length(selectize) != 1 || !selectize) {
    message("'selectize' has been forced to TRUE")
    selectize <- TRUE
  }
  if(!is.null(size)) {
    message("'size' has been forced to NULL")
    size <- NULL
  }

  # prepare colorid
  colorid = na.omit(as.character(colorid))
  if(length(colorid) != 1) stop("chen provided 'colorid' should be a non-empty string")

  # validate and prepare choices
  choices_n <- names(choices)
  if(length(unique(choices_n)) != length(choices)) stop("'choices' should be named")
  choices <- sapply(choices, simplify = FALSE, USE.NAMES = TRUE, FUN = function(x) {
    tryCatch({rgb(t(col2rgb(x, alpha = TRUE)), maxColorValue = 255)}, error = function(e) stop("'choices' should contain colors"))
  })

  # options to pass to selectize for displaying gradient as background
  on_init_chg <- sprintf("function(){
    var self = this;
    var sel = $(self.$input[0]);
    var cols = sel.data('colors');
    var brk = sel.data('colorbreak');
    var itm = self.$control.find('.item').data('value');
    var k = cols[itm];
    var vals = k.map((element, index) => element + ' ' + index * 100 / (k.length) + '%%' + ' ' + (index + 1) * 100 / (k.length) + '%%');
    if(brk !== true) vals = k;
    self.$control.css({'font-weight':'bold', 'color':'#fff', 'text-shadow':'#000 0px 0px 5px', '-webkit-font-smoothing':'antialiased', 'background':'linear-gradient(to right, ' + vals + ')'})
    Shiny.onInputChange('%s', k);
    return null;
  }", colorid)
  on_dropdown <- "function(el){
    var gdpar = el.parent().parent();
    var sel = gdpar.find('select');
    var cols = sel.data('colors');
    var brk = sel.data('colorbreak');
    var kid = el.children();
    kid.children().each(function () {
      var ele = $(this);
      var k = cols[ele.data('value')]
      var vals = k.map((element, index) => element + ' ' + index * 100 / (k.length) + '%' + ' ' + (index + 1) * 100 / (k.length) + '%');
      if(brk !== true) vals = k;
      ele.css({'font-weight':'bold', 'color':'#fff', 'text-shadow':'#000 0px 0px 5px', '-webkit-font-smoothing':'antialiased', 'background':'linear-gradient(to right, ' + vals + ')'})
    });
    return null;
  }"

  # additional options to selectInput, note that the use of paste(opt$ ...) is putative, I did not check it works
  opt = options
  if(!missing(options)) {
    options = as.list(options[!(names(options) %in% c("onInitialize", "onChange", "onDropdownOpen"))])
  } else {
    options = list()
  }
  res <- selectizeInput(options = c(options, list(
    onInitialize = I(paste0(opt$onInitialize, on_init_chg, collapse = "\n;")),
    onChange = I(paste0(opt$onChange, on_init_chg, collapse = "\n;")),
    onDropdownOpen = I(paste0(opt$onDropdownOpen, on_dropdown, collapse = "\n;")))
  ), inputId = inputId, label = label, selected = restoreInput(id = inputId, default = selected),
  multiple = multiple, choices = choices_n, width = width)

  # add colors data to select
  res$children[[2]]$children[[1]]$attribs[["data-colors"]] <- jsonlite::toJSON(choices)
  res$children[[2]]$children[[1]]$attribs[["data-colorbreak"]] <- ifelse(colorbreak,"true","false")
  res$children[[2]]$children[[1]]$attribs[["data-colorid"]] <- colorid

  # add class to select
  res$children[[2]]$children[[1]]$attribs$class <- c(res$children[[2]]$children[[1]]$attribs$class, "colourgradient")
  res
}

# update the gradient input
updateGradientInput <- function (session = getDefaultReactiveDomain(), inputId, label = NULL, choices = NULL, selected = NULL, colorbreak = NULL) {
  choices_n <- choices
  choices_n <- if(!is.null(choices_n)) {
    choices_n <- names(choices)
    if(length(unique(choices_n)) != length(choices)) stop("'choices' should be named")
    choices <- sapply(choices, simplify = FALSE, USE.NAMES = TRUE, FUN = function(x) {
      tryCatch({rgb(t(col2rgb(x, alpha = TRUE)), maxColorValue = 255)}, error = function(e) stop("'choices' should contain colors"))
    })
    shinyjs::runjs(sprintf("$('#%s').data('colors',JSON.parse('%s'));", inputId, jsonlite::toJSON(choices)))
    choices_n <- structure(as.list(choices_n), names = choices_n)
  }
  if(!is.null(colorbreak)) shinyjs::runjs(sprintf("$('#%s').data('colorbreak', %s);", inputId, ifelse(colorbreak,"true","false")))
  updateSelectInput(session = session, inputId = inputId, label = label, choices = choices_n, selected = selected)
}

# example
shinyApp(
  ui = fluidPage(
    shinyjs::useShinyjs(),
    gradientInput(inputId = "color", label = "Choose a color gradient:",
                  list("rgb" = colorRampPalette(c("red","blue","green"))(5),
                       "viridis" = viridisLite::viridis(5))
    ),
    textOutput("result")
  ),
  server = function(input, output) {
    output$result <- renderText({
      paste("You chose", input$color, "\n",
            "which is", paste0(input[["color-gradient"]], collapse = ","))
    })
    # update gradient after 5 sec
    shinyjs::delay(5000,
                   updateGradientInput(inputId = "color",
                                       colorbreak = TRUE,
                                       choices = list("rgb" = colorRampPalette(c("red","blue","green"))(5),
                                                      "viridis" = viridisLite::viridis(5),
                                                      "plasma" = viridisLite::plasma(5),
                                                      "purples" = RColorBrewer::brewer.pal(name = "Purples", n = 9)),
                                       selected = "viridis"))
  }
)

[daattali]

Thank you for the information @gitdemont

After having thought about this for a bit, I highly doubt I'll ever introduce such a widget so I'm closing this issue. It would be a cool and useful input type, but I just don't see it realistically happening