Изменить шрифт markup (т. Е. Полужирный, курсив) для checkboxGroupInput метки

Question

Я создаю веб-приложение с Shiny в R. У меня есть набор данных, который я рисую на карте. Использование виджета checkboxGroupInput позволяет выбирать категории, которые они хотят видеть на карте (или нет). Однако набор данных изменяется со временем, и не все категории всегда доступны. Чтобы уточнить, какие из доступных в текущем наборе, а какие нет, я хочу отформатировать доступные категории как жирные.

До сих пор я не мог получить виджет checkboxGroupInput, чтобы показывать жирным шрифтом этикетки. Есть ли способ сделать это? Я хочу, чтобы некоторые ярлыки были смелыми, а другие - нет. Кроме того, используя updateCheckboxGroupInput, я могу изменить параметры (т. Е. Показать только доступные категории), но это не то, что я хочу/нуждаюсь.

Я попытался, например:

x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3) 

checkboxGroupInput(inputId="test", label="this is a test", choices=x) 

Но такой подход отображает только теги форматирования текста, как в пользовательском интерфейсе. Решения, использующие функцию Shiny, не работают, или ... Я делаю это неправильно.

Любые идеи?

Вот простой пример Блестящей интерфейса, используя подход, описанный выше, (который не работает):

library("shiny") 

x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3) 

server = function(input, output) {} 

ui = fluidPage(
    checkboxGroupInput(inputId="test", label="this is a test", choices=x) 
) 

runApp(list(ui = ui, server = server)) 

Следующий пример работает, но это решение при инициализации группы флажка. Включение функции observe в серверной части показывает, что одно и то же решение не работает для updateCheckboxGroupInput. Это имеет смысл, поскольку эта функция не возвращает HTML-код. Я не знаю, как получить доступ к выводам этой функции обновления или как ее решить иначе.

library("shiny") 

x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3) 
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3) 

server = function(input, output, session) { 
    # observe({ 
     # input$test 
     # gsub("&gt;", ">", gsub("&lt;", "<", updateCheckboxGroupInput(session, "test", choices=y))) 
    # }) 
} 

ui = fluidPage(
    gsub("&gt;", ">", gsub("&lt;", "<", checkboxGroupInput(inputId="test", label="this is a test", choices=x))) 
) 

runApp(list(ui = ui, server = server)) 

Answer 1

На данный момент я нашел решение. Не очень элегантный и, вероятно, склонный к ошибкам, но он работает. Я узнал, что символы < и> экранированы для целей HTML с помощью функции htmltools под названием escapeHtml. Временно заменяя эту функцию до вызова updateCheckboxGroupInput, с помощью фиктивной функции текст не экранируется. После вызова updateCheckboxGroupInputhtmlEscape, конечно, необходимо восстановить.

Пример, который работает. После запуска приложения вам необходимо проверить первый флажок, чтобы увидеть его работу:

library("shiny") 

x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3) 
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3) 

server = function(input, output, session) { 
    observe({ 
     value <- input$test 

     if (length(value) > 0 && value == 1) { 
      ## save htmlEscape function and replace htmlEscape 
      saved.htmlEscape <- htmltools::htmlEscape 
      assignInNamespace("htmlEscape", function(x, attribute) return(x), "htmltools") 

      updateCheckboxGroupInput(session, "test", label="OK", choices=y) 

      ## restore htmlEscape function 
      assignInNamespace("htmlEscape", saved.htmlEscape, "htmltools") 
     } 
    }) 
} 

ui = fluidPage(
    checkboxGroupInput(inputId="test", label="this is a test", choices=x) 
) 

runApp(list(ui = ui, server = server))