r语言 - 闪亮BS模态不适用于连续观察事件

Question

我正在尝试实现闪亮的弹出窗口，如这篇文章中所述 shinyBS 弹出窗口。 我的应用程序包装在基于 Enter 键和isolate()的observeEvent()中，以防止我们在按 Enter 键之前键入汽车名称时表格发生变化。

问题是第一次效果很好，我能够查看弹出窗口，但是使用不同的汽车名称连续搜索并按 Enter 键，弹出窗口不起作用。实际上，经过几次尝试后，该应用程序会变灰。

如何无缝地串联实现这 3 个(弹出模式、基于 Enter 键观察事件并隔离以防止反应(？

我的代码如下

library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
library(tidyverse)
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
mtcarsDf <- mtcars %>%
mutate(car_name = row.names(mtcars)) %>%
select(car_name, cyl, mpg, gear)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Tab1", tabName = "Tab1", icon = icon("dashboard"))
)),
dashboardBody(
tags$script('
$(document).on("keyup", function(e) {
if(e.keyCode == 13){
Shiny.onInputChange("keyPressed", Math.random());
}
});
'),
tabItems(
tabItem(tabName = "Tab1",
div("try typing mazda, ferrari, volvo, camaro, 
lotus, maserati, porsche, fiat, dodge, toyota, honda, merc"),
textInput("name", "Car Name"),
uiOutput("popup1"),
DT::dataTableOutput('table1'))
)))

server <- function(input, output, session) {     
observeEvent(input[["keyPressed"]], {
data <- reactive({
if (input$name != "") {
reactiveDf <- reactive({
if (input$name != "") {          
mtcarsDf <- mtcarsDf %>%
filter(grepl(input$name, car_name, ignore.case = TRUE))             
}
})
testdata <- reactiveDf()
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),
'button_', label = "View", 
onclick = 'Shiny.onInputChange("select_button",  this.id)' ),
testdata))
}
}) 
isolate(data <- data())#### this is required to avoid the table changing as we type the name    
output$table1 <- DT::renderDataTable(data,
selection = 'single',
options = list(searching = FALSE,pageLength = 10),
server = FALSE, escape = FALSE,rownames= FALSE)

SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})

observeEvent(input$select_button, {
toggleModal(session, "modal1", "open")
})
DataRow <- eventReactive(input$select_button,{
data[SelectedRow(),2:ncol(data)]
})
output$popup1 <- renderUI({
bsModal("modal1", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,                   
DT::renderDataTable(DataRow())
))
})
})
}
shinyApp(ui, server)

Answer 1

library(shiny)
library(shinydashboard)
library(sqldf)
library(statquotes)
library(DT)
library(shinyBS)
library(shinyjs)
library(tidyverse)
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
data(quotes)
quotes
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("TexSearch", tabName = "Tabs", icon = icon("object-ungroup"))) ),

dashboardBody(
tags$script('
$(document).on("keyup", function(e) {
if(e.keyCode == 13){
Shiny.onInputChange("keyPressed", Math.random());
}
});
'),
shinyjs::useShinyjs(),
#js function to reset a button, variableName is the button name whose value we want to reset
tags$script("Shiny.addCustomMessageHandler('resetInputValue', function(variableName){
Shiny.onInputChange(variableName, null);
});
"),
tabItem(tabName = "Tabs",
fluidRow(
column(width=3, 
box(
title="Search ",
solidHeader=TRUE,
collapsible=TRUE,
width=NULL,
div("try typing data, history, visualization, graph, method, value"),
textInput("wordsearch", "Search"))),
column( width=9,
tabBox(
width="100%",
tabPanel("tab1", 
uiOutput("quotepopup"),
DT::dataTableOutput('table')
)))))))
server <- function(input, output, session) {
#detach("package:RMySQL", unload=TRUE)

observeEvent(input[["keyPressed"]], {
###get data from sql queries
results <- reactive({
if (input$wordsearch != "") {
searches <- reactive({
if (input$wordsearch != "") {
sqldf(paste0("SELECT  qid, topic
FROM quotes
WHERE text LIKE '%",input$wordsearch,"%'"))
}
})
#### add view button
testdata <- searches()
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),
'button_', label = "View", 
onclick = 'Shiny.onInputChange("select_button",  this.id)' ),
testdata))
}
})
results_ <<- results()
####pass data to datatable 
output$table <- DT::renderDataTable(results_,
selection = 'single',
options = list(searching = FALSE,pageLength = 10),
server = FALSE, escape = FALSE,rownames= FALSE)
})
###update modal on clicking view button
observeEvent(input$select_button, {
s <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
rowselected <<- results_[input$table_rows_selected, "qid"]
output$quotepopup <- renderUI({
bsModal(paste('model', s ,sep=''), "Quote Details", "", size = "large",
column(12,                   
htmlOutput("clickedquotedetails")
# HTML("Hello")
)
)
})
toggleModal(session, paste('model', s ,sep=''), toggle = "Assessment")
session$sendCustomMessage(type = 'resetInputValue', message =  "select_button")
})
output$clickedquotedetails <- renderUI({


selectedd <-  stringr::str_c(stringr::str_c("'", rowselected, "'"), collapse = ',')
print(rowselected)
print(selectedd)
quotesearch <- reactive({
sqldf(paste0("SELECT  *
FROM quotes
WHERE qid IN (",
selectedd,
")"))
})
output = ""
relevantquotes <- quotesearch()
output <-
paste(output,
"<b>Number of quotes: ",
as.character(dim(relevantquotes)[1]),
"</b>.<br/>")
for (i in seq(from = 1,
to = dim(relevantquotes)[1])) {
output <- paste(output,
paste("qid: ", relevantquotes[i, "qid"]),
sep = "<br/><br/>")
output <- paste(output,
paste("topic: ", relevantquotes[i, "topic"]),
sep = "<br/><br/>")
output <- paste(output,
paste("text: ", relevantquotes[i, "text"]),
sep = "<br/><br/><br/>")
}
HTML(output)
})




#end of observe ENTER event
}
shinyApp(ui, server)

只需复制粘贴此代码即可。😉