Shiny- Tooltip for each check-able box (basic) - r

Question

I have a check-able list of ~60 different inputs, and I was hoping to set a tooltip for each individual box. Currently, using bsTooltip, I can only set a tooltip for the entire panel. Here is the relevant script...
library(shiny)
library(shinyBS)
library(networkD3)
ui <- fluidPage(
tabPanel("Analyze By Experiment",
sidebarLayout(
sidebarPanel(
width = 2,
fluid = FALSE,
bsTooltip("data1", "PDRF = Parkinsons Disease Risk Factors", placement = "right", trigger = "hover"),
checkboxGroupInput ( inputId = "data1", label = "High Throughput Experiment",
choices = unique(unlist(data$Present_In)))),
mainPanel(simpleNetworkOutput("coolplot", height = "800px"),
width = 10))
)
)
server <- function(input, output, session) { }
shinyApp(ui, server)

Answer 1

Building on the brilliant answer by #K. Rohde from this answer, we can do the same for your example. The issue you have is that you have 60 checkboxinputs, so writing out the tipify and bsButtonright for each one becomes tedious and longwinded. However, since if you notice from the two calls to tipify in the second part of his answer, only the id and help text changes, the rest stays the same. So we can write a function that takes id and help text and produces html code for a help info using that code. Then we can use lapply to create 60 or even more of these items, by simply passing a list of ids and help text to with our function to lapply. I've used the euStockMarkets dataset for this. It has 1720 unique rows, which with your code will give 1720 checkbox inputs. This is of course ridiculous but it demonstrates that the code works and hence will likely work on much fewer checkboxes
I've generated the help text using R but you'll probably type yours out.
Here is the full code below:
library(shiny)
library(shinyBS)
library(networkD3)
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
}
data("EuStockMarkets")
eustocks <- as.data.frame(EuStockMarkets)
choiceNames <- paste0("cb", 1:length(unique(unlist(eustocks$FTSE))))
txt <- paste(rep("Help", length(unique(unlist(eustocks$FTSE)))), seq(1:length(unique(unlist(eustocks$FTSE)))))
txt[1] <- "PDRF = Parkinsons Disease Risk Factors"
ids <- paste0("pB", rep(1:length(unique(unlist(eustocks$FTSE)))))
inputData <- data.frame(cbid = ids, helpInfoText = txt)
inputData$cbid <- sapply(inputData$cbid, as.character)
inputData$helpInfoText <- sapply(inputData$helpInfoText, as.character)
checkBoxHelpList <- function(id, Text){
extensionsList <- tipify(bsButtonRight(id, "?", style = "inverse", size = "extra-small"), Text)
return(extensionsList)
}
# checkBoxHelpList(id = x["cbid"], Text = x["helpInfoText"])
helpList <- split(inputData, f = rownames(inputData))
checkboxExtensions <- lapply(helpList, function(x) checkBoxHelpList(x[1], as.character(x[2])))
server <- function(input, output, session) {
output$rendered <- renderUI({
extendedCheckboxGroup("qualdim", label = "High Throughput Experiment", choiceNames = choiceNames, choiceValues = unique(unlist(eustocks$FTSE)), selected = c("check2"),
extensions = checkboxExtensions)
})
}
ui <- fluidPage(
tabPanel("Analyze By Experiment",
sidebarLayout(
sidebarPanel(
width = 2,
fluid = FALSE,
uiOutput("rendered")),
mainPanel(simpleNetworkOutput("coolplot", height = "800px"),
width = 10))
)
)
shinyApp(ui, server)
As you can see below, the tool tip works.