R shiny custom icon/image in selectInput

Here is a working example. The aim here is to display the colours in the colour palette (rather than just the palette name) to the user in the dropdown menu. Here the images in dropdown are created during runtime. This may or may not be desirable. If the images in dropdown never change (ie; static), See SeGa's answer.

This is modified from the example shown here.

enter image description here

ui.R file

## UI.R

fluidPage(
  title='Plots in Selectize Input',
  tags$h2('Plots in Selectize Input'),
  fluidRow(
    column(4,
           selectizeInput('palette',label="Palette",choices=NULL,options=list(
             placeholder='Select a colour palette',maxOptions=4)
           )),
    column(8,
      plotOutput('plot')
      )
    )
  )

server.R file

## SERVER.R

library(ggplot2)

data(diamonds)
len <- length(levels(diamonds$cut))
clist <- list("rainbow"=rainbow(len),"topo"=topo.colors(len),
              "terrain"=terrain.colors(len),"cm"=cm.colors(len))

function(input,output,session) {

  paletteurl <- session$registerDataObj(

    name='uniquename1',
    data=clist,
    filter=function(data,req) {

      query <- parseQueryString(req$QUERY_STRING)
      palette <- query$palette
      cols <- clist[[palette]]

      image <- tempfile()
      tryCatch({
        png(image,width=100,height=50,bg='transparent')
        par(mar=c(0,0,0,0))
        barplot(rep(1,length(cols)),col=cols,axes=F)
      },finally = dev.off())

      shiny:::httpResponse(
        200,'image/png',readBin(image,'raw',file.info(image)[,'size'])
      )
    }
  )

  updateSelectizeInput(
    session,'palette',server=TRUE,
    choices=names(clist),
    selected=1,
    options=list(render=I(sprintf(
      "{
        option: function(item, escape) {
        return '<div><img width=\"100\" height=\"50\" ' +
        'src=\"%s&palette=' + escape(item.value) + '\" />' +
        escape(item.value) + '</div>';
        }
      }",
      paletteurl
    )))
    )

  output$plot <- renderPlot({
    shiny::req(input$palette)

    cols <- clist[[input$palette]]
    ggplot(diamonds,aes(x=carat,y=price,colour=cut))+
      geom_point()+
      scale_colour_manual(values=cols)+
      theme_minimal(base_size=18)
  })

}

If someone understands this better, you are welcome to improve/update this answer. Even add another answer to show a different usage.


Not a full answer, but need formatting:

I have seen it before here: http://shiny.rstudio.com/gallery/selectize-examples.html. Look at the "Select a GitHub repo" input.

Using the I() expression within a render call:

selectizeInput('github', 'Select a Github repo', choices = '', options = list(
        valueField = 'url',
        labelField = 'name',
        searchField = 'name',
        options = list(),
        create = FALSE,
        render = I("{
      option: function(item, escape) {
        return '<div>' +
               '<strong><img src=\"http://brianreavis.github.io/selectize.js/images/repo-' + (item.fork ? 'forked' : 'source') + '.png\" width=20 />' + escape(item.name) + '</strong>:' +
               ' <em>' + escape(item.description) + '</em>' +
               ' (by ' + escape(item.username) + ')' +
            '<ul>' +
                (item.language ? '<li>' + escape(item.language) + '</li>' : '') +
                '<li><span>' + escape(item.watchers) + '</span> watchers</li>' +
                '<li><span>' + escape(item.forks) + '</span> forks</li>' +
            '</ul>' +
        '</div>';
      }
    }"),

Specifically the '<strong><img src=\"http://brianreavis.github.io/selectize.js/images/repo-' line.

The issue now is to call a unique image for each option, which should also be possible within I().


There is also the pickerInput from shinyWidgets, that can be customized with html/css. With it you can include any image or icon into a selection widget.

However, the images must already exist with this approach.

library(shiny)
library(shinyWidgets)

df <- data.frame(
  val = c("pal1","pal2", "pal3", "pal4")
)

df$img = c(
  sprintf("<img src='https://d9np3dj86nsu2.cloudfront.net/image/eaf97ff8dcbc7514d1c1cf055f2582ad' width=30px><div class='jhr'>%s</div></img>", df$val[1]),
  sprintf("<img src='https://www.color-hex.com/palettes/33187.png' width=30px><div class='jhr'>%s</div></img>", df$val[2]),
  sprintf("<img src='https://www.color-hex.com/palettes/16042.png' width=30px><div class='jhr'>%s</div></img>", df$val[3]),
  sprintf("<img src='https://www.stlawrencegallery.com/wp-content/uploads/2018/09/unique-navy-blue-color-palette-five-stunning-palettes-for-weddings-dark.jpg' width=30px><div class='jhr'>%s</div></img>", df$val[4])
  )


ui <- fluidPage(
  tags$head(tags$style("
                       .jhr{
                       display: inline;
                       vertical-align: middle;
                       padding-left: 10px;
                       }")),
 pickerInput(inputId = "Id0109",
             label = "pickerInput Palettes",
             choices = df$val,
             choicesOpt = list(content = df$img))

  )

server <- function(input, output) {}
shinyApp(ui, server)

enter image description here

Tags:

R

Shiny