9

我想将复选框标签的帮助文本作为工具提示。在下面的示例中,我使用了该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)
4

2 回答 2

11

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

但就像大多数时候一样,一些 JavaScript 可以解决问题。我给你写了一个函数,它bsButton在正确的位置插入并调用一个 shinyBS 函数来插入工具提示。(我主要是重构什么tipifybdButton会做什么。)使用该功能,您可以轻松修改您的工具提示,而无需进一步了解 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 加载到网站中。以前,这(或多或少是偶然的)是由于对bsButton.

编辑 Nr.2:更加闪亮

所以这个 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)
于 2016-04-18T14:02:18.390 回答
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)
于 2017-09-19T13:57:09.027 回答