r - Shiny 的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

不幸的是，这是其中的一刻， Shiny 的东西掩盖了大部分结构，这使得很难将想要的东西放到正确的地方。

但是像大多数时候一样，一些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:更多 Shiny 内容

因此，这种JavaScript的东西很不错，但是很容易出错，并且要求开发人员具有一些其他的语言技能。

在这里，我给出了另一个受@CharlFrancoisMarais启发的答案，该答案仅在 R中起作用，并使事情比以前更集成。

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

第二，扩展 bsButton以使其正确放置。这仅是针对@CharlFrancoisMarais请求的自定义内容。

我建议您仔细阅读 Shiny -element操作，因为这在 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)