Превратите метку selectInput в вариант, который отображается по умолчанию и не может быть выбран

Question

У меня внизу блестящая приборная панель с selectInput(). Мне было интересно, смогу ли я превратить label «Переменная» в выбор, который будет отображаться по умолчанию вместо «Цилиндры», в то время как «Цилиндры» по-прежнему будут выбором selected. Конечно, label не будет отображаться. Это будет выглядеть так:

#app.r
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)

shinyApp(
  ui = dashboardPagePlus(
    header = dashboardHeaderPlus(

    ),
    sidebar = dashboardSidebar(
      selectInput("variable", "Variable:",
                  c("Cylinders" = "cyl",
                    "Transmission" = "am",
                    "Gears" = "gear"),
                  selected = "Cylinders")
    ),
    body = dashboardBody(
    ),
    rightsidebar = rightSidebar(),
    title = "DashboardPage"
  ),
  server = function(input, output) { }
)

Answer 1

Используя пакет shinyjs, я определяю, находится ли мышь на selectInput или нет, и адаптирую содержимое selectInput с этим условием.

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

Затем я определяю два события:

• , если указатель мыши находится на входе, и если «Переменная» находится в списке вариантов ввода (choices_input), затем я обновляю selectInput, чтобы удалить «Переменную» из этого списка вариантов.

• , если мышь покидает поле ввода, и если «Переменная» отсутствует в списке выбор, я делаю наоборот.

Кроме того, во втором событии вам нужно добавить оператор if, чтобы зафиксировать значение selectInput к вашему выбору, даже после того, как мышь уходит.

Полный код:

#app.r
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)

choices_input <- c("Variable",
                   "Cylinders" = "cyl",
                   "Transmission" = "am",
                   "Gears" = "gear")

shinyApp(
  ui = dashboardPagePlus(
    useShinyjs(),
    header = dashboardHeaderPlus(),
    sidebar = dashboardSidebar(
      selectInput("variable", "",
                  choices = choices_input,
                  selected = "Variable")
    ),
    body = dashboardBody(),
    rightsidebar = rightSidebar(),
    title = "DashboardPage"
  ),
  server = function(input, output, session) { 

    onevent("mouseenter", "variable",
            if ("Variable" %in% choices_input) {
              updateSelectInput(
                session = session,
                inputId = "variable",
                choices = c("Cylinders" = "cyl",
                            "Transmission" = "am",
                            "Gears" = "gear"),
                selected = input$variable)

              choices_input <<- c("Cylinders" = "cyl",
                                  "Transmission" = "am",
                                  "Gears" = "gear")
            })

    onevent("mouseleave", "variable", {
            if (!("Variable" %in% choices_input)) {
              updateSelectInput(
                session = session,
                inputId = "variable",
                choices = c("Variable",
                            "Cylinders" = "cyl",
                            "Transmission" = "am",
                            "Gears" = "gear"),
                selected = "Variable")

              choices_input <<- c("Variable",
                                  "Cylinders" = "cyl",
                                  "Transmission" = "am",
                                  "Gears" = "gear")
            }
            if(input$variable != "Variable"){
              updateSelectInput(
                session = session,
                inputId = "variable",
                choices = c("Variable",
                            "Cylinders" = "cyl",
                            "Transmission" = "am",
                            "Gears" = "gear"),
                selected = input$variable)
            }
      })

  }
)

Примечание: очевидно, мышь считается «на входе», если она находится чуть выше ввода, где находится метка ( ничего в этом случае) не должно быть. Пока я не знаю, как это исправить.

Примечание 2. Конечно, вы можете заполнить пробел, когда мышь в первый раз нажата на selectInput, отобразив сообщение (т.е. добавив еще один вариант в choice_input) и вложив событие onclick() (тот же пакет) в onevent() (чтобы удалить это сообщение / выбор, если вы нажмете на вход).