英文:
Creating tooltip for radioGroupButtons while using bslib
问题
我想为shinywidgets::radiogroupButton（或shiny::radioButton）获取一个工具提示，用于警告用户选择每个选项的后果。我想要实现与此答案中提到的完全相同的输出。问题是上述解决方案在我使用bslib布局我的仪表板时不起作用。
这是在帖子中定义的函数：
# 用于显示工具提示的函数
radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '", "'}")
bsTag <- shiny::tags$script(shiny::HTML(paste0("
$(document).ready(function() {
setTimeout(function() {
$('input', $('#", id, "')).each(function(){
if(this.getAttribute('value') == '", choice, "') {
opts = $.extend(", options, ", {html: true});
$(this.parentElement).tooltip('destroy');
$(this.parentElement).tooltip(opts);
}
})
}, 500)
});
")))
htmltools::attachDependencies(bsTag, shinyBS:::shinyBSDep)
}
这是我希望能够正常工作的部分：
library(shiny)
library(bslib)
# 小的shiny应用程序
ui <- page_sidebar(title = "App ",
sidebar = sidebar(
shinyWidgets::radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
),
page_fillable(
column(9,'Plot')
)
)
server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)
作为参考，这完美地运行，唯一的区别是这里没有使用bslib函数：
## 如果您改为运行：
ui <- shinyUI(
fluidPage(
fluidRow(
column(3,
radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C"))
),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover"),
column(9,'Plot')
)
)
)
我尝试使用上面定义的函数。当您使用bslib函数布局仪表板时，它将停止工作。
英文:
I want to get a tooltip for a shinywidgets::radiogroupButton (or shiny::radioButton) that warns the user about the consecuences of choosing each option, sepparately. I want to achieve the exact same output mentioned in this answer. The problem is the afore-mentioned solution won't work y I lay out my dashboard using bslib.
This is the function defined in the post
# function creeated to display tooltips
radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
bsTag <- shiny::tags$script(shiny::HTML(paste0("
$(document).ready(function() {
setTimeout(function() {
$('input', $('#", id, "')).each(function(){
if(this.getAttribute('value') == '", choice, "') {
opts = $.extend(", options, ", {html: true});
$(this.parentElement).tooltip('destroy');
$(this.parentElement).tooltip(opts);
}
})
}, 500)
});
")))
htmltools::attachDependencies(bsTag, shinyBS:::shinyBSDep)
}
This is what I'd like to se working:
library(shiny)
library(bslib)
# small shiny app
ui <- page_sidebar(title = "App ",
sidebar = sidebar(
shinyWidgets::radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
),
page_fillable(
column(9,'Plot')
)
)
server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)
For reference, this work perfectly, the only difference is that no bslib functions are used here
## it works perfectly if you instead run:
ui <- shinyUI(
fluidPage(
fluidRow(
column(3,
radioGroupButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C"))
),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover"),
column(9,'Plot')
)
)
)
I tried to use the functions defined above. It stops working when you lay out the dashboead using bslib functions.
答案1
得分: 0
- 将
destroy替换为dispose - 移除 HTML 依赖
- 使用普通的单选按钮，而不是 shinyWidgets 的单选按钮
radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '", "'}"))
bsTag <- shiny::tags$script(shiny::HTML(paste0("
$(document).ready(function() {
setTimeout(function() {
$('input', $('#", id, "')).each(function(){
if(this.getAttribute('value') == '", choice, "') {
opts = $.extend(', options, ', {html: true});
$(this.parentElement).tooltip('dispose');
$(this.parentElement).tooltip(opts);
}
})
}, 500)
});
")))
}
library(shiny)
library(bslib)
# small shiny app
ui <- page_sidebar(
title = "App ",
sidebar = sidebar(
radioButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
),
page_fillable(
column(9,'Plot')
)
)
server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)
英文:
You have to:
- replace
destroywithdispose - remove the html dependency
- use ordinary radio buttons, not those of shinyWidgets
radioTooltip <- function(id, choice, title, placement = "bottom", trigger = "hover", options = NULL){
options = shinyBS:::buildTooltipOrPopoverOptionsList(title, placement, trigger, options)
options = paste0("{'", paste(names(options), options, sep = "': '", collapse = "', '"), "'}")
bsTag <- shiny::tags$script(shiny::HTML(paste0("
$(document).ready(function() {
setTimeout(function() {
$('input', $('#", id, "')).each(function(){
if(this.getAttribute('value') == '", choice, "') {
opts = $.extend(", options, ", {html: true});
$(this.parentElement).tooltip('dispose');
$(this.parentElement).tooltip(opts);
}
})
}, 500)
});
")))
}
library(shiny)
library(bslib)
# small shiny app
ui <- page_sidebar(
title = "App ",
sidebar = sidebar(
radioButtons("radioSelection", label = "So many options!", choices = c("A", "B", "C")),
radioTooltip(id = "radioSelection", choice = "A", title = "Button 1 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "B", title = "Button 2 Explanation", placement = "right", trigger = "hover"),
radioTooltip(id = "radioSelection", choice = "C", title = "Button 3 Explanation", placement = "right", trigger = "hover")
),
page_fillable(
column(9,'Plot')
)
)
server <- function(input, output, session) {}
shinyApp(ui = ui, server = server)
答案2
得分: 0
以下是翻译好的部分：
# 使用 `htmltools::tagQuery()` + Bootstrap 工具提示
# 单选按钮带工具提示
#
# @param explanation 包含要显示在选项工具提示中的说明的字符向量
# @inheritDotParams [shiny::radioButtons]
# @return shiny::tagList
radioButtonsWithTooltip <- function(..., explanations = NULL) {
radios <- shiny::radioButtons(...)
choices <- list(...) $choices
if (is.null(explanations) || is.null(choices)) {
return(radios)
}
radios_tag_q <- htmltools::tagQuery(radios)
explanations <- rep(explanations, length.out = length(choices))
labels <- radios_tag_q$find(".radio label")$selectedTags()
labels <- lapply(seq_along(labels), function(i) {
label_tag_q <- labels[[i]] |>
htmltools::tagQuery()
label_tag_q$addAttrs(
`data-bs-toggle` = "tooltip",
`data-bs-title` = explanations[[i]],
`data-bs-placement` = "right",
`data-bs-trigger` = "hover focus"
)
tags$div(class = "radio", label_tag_q$allTags())
})
radios_tag_q$find(".radio")$remove()
radios_tag_q$append(labels)
tagList(
radios_tag_q$allTags(),
# 在需要时重新初始化工具提示，以处理 `uiOutput` + `renderUI`：
tags$script(
shiny::HTML(
r"{
tooltipTriggerList = document.querySelectorAll('[data-bs-toggle=\"tooltip\"]');
tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
}"
)
)
)
}
# `ui.R`
ui <- bslib::page(
title = "RadioGroup tooltip",
theme = bslib::bs_theme(version = 5),
tags$div(
class = "container",
radioButtonsWithTooltip(
inputId = "dist",
label = "Distribution type:",
choices = c(
"Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp"
),
explanations = c(
"正态分布",
"这是均匀分布",
"对数正态分布！",
"指数分布"
)
),
tags$p(
class = "muted",
"演示一些占位文本",
tags$a(
href = "#",
`data-bs-toggle` = "tooltip",
`data-bs-title` = "默认工具提示",
`data-bs-trigger` = "hover focus",
"内联链接"
)
)
),
# 初始化 Bootstrap 工具提示：
tags$script(
shiny::HTML(
r"{
let tooltipTriggerList = document.querySelectorAll('[data-bs-toggle=\"tooltip\"]');
let tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
}"
)
)
)
# `server.R`
server <- function(input, output, session) {
}
<details>
<summary>英文:</summary>
You can use `htmltools::tagQuery()` + bootstrap tooltips.
[![tooltip showcase][1]][1]
Here is a reprex of how to achieve that:
```r
#' Radio buttons with tooltip
#'
#' @param explanation Character vector containing explanations to be shown in
#' the tooltips of the choices
#' @inheritDotParams [shiny::radioButtons]
#' @return shiny::tagList
radioButtonsWithTooltip <- \(..., explanations = NULL) {
radios <- shiny::radioButtons(...)
choices <- list(...)$choices
if (is.null(explanations) || is.null(choices)) {
return(radios)
}
radios_tag_q <- htmltools::tagQuery(radios)
explanations <- rep(explanations, length.out = length(choices))
labels <- radios_tag_q$find(".radio label")$selectedTags()
labels <- lapply(seq_along(labels), \(i) {
label_tag_q <- labels[[i]] |> htmltools::tagQuery()
label_tag_q$addAttrs(
`data-bs-toggle` = "tooltip",
`data-bs-title` = explanations[[i]],
`data-bs-placement` = "right",
`data-bs-trigger` = "hover focus"
)
tags$div(class = "radio", label_tag_q$allTags())
})
radios_tag_q$find(".radio")$remove()
radios_tag_q$append(labels)
tagList(
radios_tag_q$allTags(),
# re-initialize tooltips incase of `uiOutput` + `renderUI`:
tags$script(
shiny::HTML(
r"{
tooltipTriggerList = document.querySelectorAll('[data-bs-toggle="tooltip"]');
tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
}"
)
)
)
}
ui.R
ui <- bslib::page(
title = "RadioGroup tooltip",
theme = bslib::bs_theme(version = 5),
tags$div(
class = "container",
radioButtonsWithTooltip(
inputId = "dist",
label = "Distribution type:",
choices = c(
"Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp"
),
explanations = c(
"The normal distribution",
"This is the uniform dist",
"Log normal here!",
"Exponential dwistibushion"
)
),
tags$p(
class = "muted",
"Placeholder text to demonstrate some",
tags$a(
href = "#",
`data-bs-toggle` = "tooltip",
`data-bs-title` = "Default tooltip",
`data-bs-trigger` = "hover focus",
"inline links"
)
)
),
# initialize bootstrap tooltips:
tags$script(
shiny::HTML(
r"{
let tooltipTriggerList = document.querySelectorAll('[data-bs-toggle="tooltip"]');
let tooltipList = [...tooltipTriggerList].map(tooltipTriggerEl => new bootstrap.Tooltip(tooltipTriggerEl));
}"
)
)
)
server.R
server <- function(input, output, session) {
}
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论