悲しいことに、これはこれらの瞬間の 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 用の JavaScript API が Web サイトに読み込まれるように、ShinyBS 依存関係を追加しました。以前は、これは (多かれ少なかれ偶然に) への別の呼び出しが原因で発生していましたbsButton。
編集番号 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)