闪亮 UI 的帮助文本工具提示
Tooltip in shiny UI for help text
我想为 check-box 标签放置一个帮助文本作为工具提示。
在下面的示例中，我使用 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)
遗憾的是，这是其中一个时刻，闪亮的结构隐藏了大部分结构，这使得很难将您想要的东西放在正确的位置。
但是像大多数时候一样，一些 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 加载到网站中。之前，这是（或多或少是偶然的）由于对 bsButton.
的另一个调用而发生的
编辑 Nr.2：更加闪亮
所以这个 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)
此处略有变化 - 仅向复选框添加工具提示。
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)
我想为 check-box 标签放置一个帮助文本作为工具提示。
在下面的示例中，我使用 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)
遗憾的是，这是其中一个时刻，闪亮的结构隐藏了大部分结构，这使得很难将您想要的东西放在正确的位置。
但是像大多数时候一样，一些 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 加载到网站中。之前，这是（或多或少是偶然的）由于对 bsButton.
编辑 Nr.2：更加闪亮
所以这个 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)
此处略有变化 - 仅向复选框添加工具提示。
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)