Shiny - всплывающая подсказка для каждого флажка (базовый c)

Question

У меня есть проверяемый список из ~ 60 различных входных данных, и я надеялся установить всплывающую подсказку для каждого отдельного окна. В настоящее время, используя bsTooltip, я могу установить только всплывающую подсказку для всей панели. Вот соответствующий сценарий ...

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

Опираясь на блестящий ответ @K. Роде от этот ответ , мы можем сделать то же самое для вашего примера. Проблема в том, что у вас есть 60 входов checkbox, поэтому выписывание tipify и bsButtonright для каждого из них становится утомительным и длинным. Однако, так как если вы заметили во время двух звонков подсказку во второй части своего ответа, только идентификатор и текст справки изменится, остальные останутся прежними. Таким образом, мы можем написать функцию, которая принимает идентификатор и текст справки и создает код html для справочной информации, используя этот код. Затем мы можем использовать lapply, чтобы создать 60 или даже больше этих элементов, просто передав список идентификаторов и текст справки с нашей функцией lapply. Для этого я использовал набор данных euStockMarkets. Он имеет 1720 уникальных строк, которые с вашим кодом дадут 1720 входов для флажков. Это, конечно, смешно, но это демонстрирует, что код работает и, следовательно, вероятно, будет работать с гораздо меньшим количеством флажков

Я сгенерировал текст справки, используя R, но вы, вероятно, напечатаете свой.

Ниже приведен полный код:

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)

Как видно ниже, подсказка работает.