SelectizeInput in Shiny - making part of a choice bold

Question

I'd like to alter a part of a SelectizeInput dropdown option. For example, if any choice ends with a "*", the "*" should be bold (or in a bigger font). I'm not sure that the individual choices can be manipulated in such a way. For example:

library(shiny)

ui <- fluidPage(
  selectizeInput("select",
                 label = "Chooose one",
                 choices = c("Option 1", "Option 2 *", "Option 3"))
)

server <- function(input, output, session) {
  
}

shinyApp(ui, server)

The second choice should have a bold "*" at the end. Can this be achieved?

Answer 1

Adding div[data-value*="*"] to your css will fuzzily match any of the choices containing "*". The request you make for anything ending with the would be dealt with using div[data-value$="the"]. See https://www.w3.org/TR/selectors/#attribute-substrings for more options and thanks to How to change css style based on value and How can I select elements in CSS by partial ID value? for getting me there.

library(shiny)

ui <- fluidPage(   tags$head(
    
    tags$style(HTML('
    div[data-value*="*"] {
    font-weight: bold;   }
    '))),   selectizeInput("select",
                 label = "Chooose one",
                 choices = c("Option 1", "Option 2 *", "Option 3")) )

server <- function(input, output, session) {

}

shinyApp(ui, server)

Edit:

This is the closest I can get (via Change last letter color) but it is extremely hacky and I can't get it to work properly. If only there was ::last-letter !

reverse_string <- function(x)
  sapply(lapply(strsplit(x, NULL), rev), paste, collapse="")

ui <- fluidPage(
  tags$head(
    # Note the wrapping of the string in HTML()
    tags$style(HTML('

div[data-value*="*"] {
  unicode-bidi:bidi-override;
  direction:rtl;
}

div[data-value*="*"]::first-letter {
    font-weight: bold;
}

    '))),
  selectizeInput("select",
                 label = "Chooose one",
                 choices = c("Option 1", "Option 2 *", reverse_string("Option 3 *"), "Option 4"))
)

server <- function(input, output, session) {

}

Answer 2

library(shiny)

selectInputWithStars <- function(
    inputId, inputLabel, labels, values, stars,
    selected = NULL, multiple = FALSE, width = NULL
){
  options <- mapply(function(label, value, star){
    list(
      "label" = label,
      "value" = value,
      "star"  = as.character(star)
    )
  }, labels, values, stars, SIMPLIFY = FALSE, USE.NAMES = FALSE)
  render <- paste0(
    "{",
    "  item: function(item, escape) {", 
    "    let label = escape(item.label);",
    "    if(item.star === 'TRUE') {",
    "      label += '<sup><b>&#10045;</b></sup>';",
    "    }",
    "    return '<span>' + label + '</span>';", 
    "  },",
    "  option: function(item, escape) {", 
    "    let label = escape(item.label);",
    "    if(item.star === 'TRUE') {",
    "      label += '<sup><b>&#10045;</b></sup>';",
    "    }",
    "    return '<div>' + label + '</div>';", 
    "  }",
    "}"
  )
  selectizeInput(
    inputId  = inputId, 
    label    = inputLabel,
    choices  = NULL, 
    selected = selected,
    multiple = multiple,
    width    = width,
    options  = list( 
      "options"    = options,
      "valueField" = "value", 
      "labelField" = "label",
      "render"     = I(render),
      "items"      = as.list(selected)
    )
  )
}


ui <- fluidPage(
  br(),
  selectInputWithStars(
    "slctz",
    "Select an option:",
    labels    = c("Option 1", "Option 2", "Option 3"),
    values    = c("1", "2", "3"),
    stars     = c(FALSE, TRUE, FALSE),
    selected  = "1"
  )
)

server <- function(input, output, session){
  
  observe({
    print(input[["slctz"]])
  })
  
}

shinyApp(ui, server)