0

我正在尝试按照有关shinyBS popup的帖子中的描述实现闪亮的弹出窗口。我的应用程序observeEvent()基于 Enter 键包装，isolate()以防止表格在我们在按 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)
4

1 回答 1

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)

只需复制粘贴此代码..

于 2019-09-03T10:24:47.420 回答