用于帮助文本的闪亮UI中的工具提示

Question

我想将复选框标签的帮助文本作为工具提示。 在下面的示例中，我使用了shinyBS包 - 但我只能使用它来处理复选框输入组的标题。

任何想法如何在“Lernerfolg”或“Enthusiasmus”标签之后起作用？

library(shiny)
library(shinyBS)
 server <- function(input, output) {
  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

  output$rendered <-   renderUI({
    checkboxGroupInput("qualdim",  tags$span("Auswahl der Qualitätsdimension",   
      tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"),
             "Here, I can place some help")),

                       c("Lernerfolg"             = "Lernerfolg"   , 
                         "Enthusiasmus"           = "Enthusiasmus"          
                         ),
                       selected = c("Lernerfolg"))


  })

  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

Answer 1

可悲的是，这是其中一个时刻，闪亮隐藏了大部分建筑，这使得很难将你想要的东西带到正确的地方。

但是和大多数时候一样，一些JavaScript可以解决这个问题。我写了一个函数，在正确的位置插入bsButton并调用shinyBS函数来插入工具提示。 （我主要重构tipify和bdButton会做什么。）使用该功能，您可以轻松地修改工具提示，而无需进一步了解JavaScript。

如果您想了解更多详情，请在评论中提问。

注意：当您参考该复选框时，请使用它的值（发送到input$qualdim的值）

library(shiny)
library(shinyBS)

server <- function(input, output) {

  makeCheckboxTooltip <- function(checkboxValue, buttonLabel, Tooltip){
    script <- tags$script(HTML(paste0("
          $(document).ready(function() {
            var inputElements = document.getElementsByTagName('input');
            for(var i = 0; i < inputElements.length; i++){
              var input = inputElements[i];

              if(input.getAttribute('value') == '", checkboxValue, "'){
                var buttonID = 'button_' + Math.floor(Math.random()*1000);

                var button = document.createElement('button');
                button.setAttribute('id', buttonID);
                button.setAttribute('type', 'button');
                button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
                button.appendChild(document.createTextNode('", buttonLabel, "'));

                input.parentElement.parentElement.appendChild(button);
                shinyBS.addTooltip(buttonID, \"tooltip\", {\"placement\": \"bottom\", \"trigger\": \"hover\", \"title\": \"", Tooltip, "\"}) 
              };
            }
          });
        ")))
     htmltools::attachDependencies(script, shinyBS:::shinyBSDep)
  }

  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

    output$rendered <-   renderUI({
      list(
        checkboxGroupInput("qualdim",  tags$span("Auswahl der Qualitätsdimension",   
          tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"), "Here, I can place some help")),
          choices = c("Lernerfolg" = "Lernerfolg", "Enthusiasmus" = "Enthusiasmus"),
          selected = c("Lernerfolg")),
        makeCheckboxTooltip(checkboxValue = "Lernerfolg", buttonLabel = "?", Tooltip = "Look! I can produce a tooltip!")
      )
    })

  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

编辑：

添加了ShinyBS依赖项，以便将shinyBS的JavaScript API加载到WebSite中。之前，由于对bsButton的另一次调用，这或多或少意外地发生了。

编辑Nr.2：更多In-Shiny

所以这个JavaScript的东西非常好，但有点容易出错，并要求开发人员有一些额外的语言技能。

在这里，我提出另一个答案，受@CharlFrancoisMarais的启发，仅在R内有效，并使事物比以前更加整合。

主要内容是：checkboxGrouInput的扩展功能，允许向每个Checkbox元素添加任何元素。在那里，可以像在普通标记中一样自由放置bsButton和工具提示，并支持所有函数参数。

其次，对bsButton进行扩展以使其正确。这仅仅是针对@CharlFrancoisMarais请求的自定义内容。

我建议您仔细阅读Shiny - 元素操作，因为这会在R级别上提供如此多的自定义。我有点退出。

以下完整代码：

library(shiny)
library(shinyBS)

extendedCheckboxGroup <- function(..., extensions = list()) {
  cbg <- checkboxGroupInput(...)
  nExtensions <- length(extensions)
  nChoices <- length(cbg$children[[2]]$children[[1]])

  if (nExtensions > 0 && nChoices > 0) {
    lapply(1:min(nExtensions, nChoices), function(i) {
      # For each Extension, add the element as a child (to one of the checkboxes)
      cbg$children[[2]]$children[[1]][[i]]$children[[2]] <<- extensions[[i]]
    })
  }
  cbg
}

bsButtonRight <- function(...) {
  btn <- bsButton(...)
  # Directly inject the style into the shiny element.
  btn$attribs$style <- "float: right;"
  btn
}

server <- function(input, output) {
  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

    output$rendered <-   renderUI({
      extendedCheckboxGroup("qualdim", label = "Checkbox", choiceNames  = c("cb1", "cb2"), choiceValues = c("check1", "check2"), selected = c("check2"), 
                              extensions = list(
                                tipify(bsButtonRight("pB1", "?", style = "inverse", size = "extra-small"),
                                       "Here, I can place some help"),
                                tipify(bsButtonRight("pB2", "?", style = "inverse", size = "extra-small"),
                                       "Here, I can place some other help")
                              ))
    })
  })
}

ui <- fluidPage(
  shinyjs::useShinyjs(),

  tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),

  # useShinyBS

  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

Answer 2

这是一个小小的改动 - 仅向复选框添加工具提示。

library(shiny)
library(shinyBS)

server <- function(input, output) {

makeCheckboxTooltip <- function(checkboxValue, buttonLabel, buttonId, Tooltip){
tags$script(HTML(paste0("
                        $(document).ready(function() {
                          var inputElements = document.getElementsByTagName('input');
                          for(var i = 0; i < inputElements.length; i++) {

                            var input = inputElements[i];
                            if(input.getAttribute('value') == '", checkboxValue, "' && input.getAttribute('value') != 'null') {

                              var button = document.createElement('button');
                              button.setAttribute('id', '", buttonId, "');
                              button.setAttribute('type', 'button');
                              button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
                              button.style.float = 'right';
                              button.appendChild(document.createTextNode('", buttonLabel, "'));

                              input.parentElement.parentElement.appendChild(button);
                              shinyBS.addTooltip('", buttonId, "', \"tooltip\", {\"placement\": \"right\", \"trigger\": \"click\", \"title\": \"", Tooltip, "\"}) 
                            };
                          }
                        });
                        ")))
                        }

output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')

output$rendered <-   renderUI({
    checkboxGroupInput("qualdim", 
                       label = "Checkbox",
                       choiceNames  = c("cb1", "cb2"),
                       choiceValues = c("check1", "check2"),
                       selected = c("check2"))
})

output$tooltips <-   renderUI({
  list(
    makeCheckboxTooltip(checkboxValue = "check1", buttonLabel = "?", buttonId = "btn1", Tooltip = "tt1!"),
    makeCheckboxTooltip(checkboxValue = "check2", buttonLabel = "?", buttonId = "btn2", Tooltip = "tt2!")
  )
})

  })
}

ui <- fluidPage(
  shinyjs::useShinyjs(),

  tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),

  # useShinyBS

  sidebarLayout(
sidebarPanel(
  sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
  uiOutput("rendered"),
  uiOutput("tooltips")
),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)