R shiny - 带有选项的弹出窗口

Question

我正在创建一个查询 SQL 数据库的 Shiny 应用程序。如果查询的数据在两个日期有条目，我想警告用户。此外，我希望用户能够选择要查询的数据集。这是一个例子:

服务器

# Create example data

set.seed(10)
MeasurementA <- rnorm(1000, 5, 2)
MeasurementB <- rnorm(1000, 5, 2)
Wafer <- rep(c(1:100), each=10)
ID <- rep(c(101:200), each=10)
Batch <- rep(LETTERS[seq(from=1, to =10)], each=100)
Date <- rep(seq(as.Date("2001-01-01"), length.out = 100, by="1 day"), each=10)

# Add data for Wafer 1 with a new date

W2 <- rep(1, each=10)
ID2 <- rep(101, each=10)
Batch2 <- rep("A", each=10)
Date2 <- rep(as.Date("2001-04-11"), each=10)
MA2 <- rnorm(10, 5, 2)
MB2 <- rnorm(10, 5, 2)

df <- data.frame(Batch, Wafer, ID, MeasurementA, MeasurementB, Date)
ee <- data.frame(Batch2, W2, ID2, MA2, MB2, Date2)
colnames(ee) <- c("Batch", "Wafer", "ID", "MeasurementA", "MeasurementB", "Date")

# Data frame now how two sets of date for Wafer 1 on different dates
dd <- rbind(df, ee)
dd$Date <- factor(dd$Date)


# Create local connection (in reality this will be a connection to a host site)

con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbWriteTable(con, "dd", dd)
query <-  function(...) dbGetQuery(con, ...)

# Create empty data frames to populate

wq = data.frame()
sq = data.frame()

shinyServer(function(input, output){

  # create data frame to store reactive data set from query
  values <- reactiveValues()
  values$df <- data.frame()

  # Action button for first query
  d <- eventReactive(input$do, { input$wafer })

  # First stage of reactive query
  a <- reactive({ paste("Select ID from dd where Wafer=",d(), sep="") })

  wq <- reactive({  query( a() ) })

  # Output to confirm query is correct
  output$que <- renderPrint({ a() }) 
  output$pos <- renderPrint( wq()[1,1] )  

  # Action button to add results from query to a data frame
  e <- eventReactive(input$do2, { wq()[1,1] })

  b <- reactive({ paste("select cast(Wafer as varchar) as Wafer, cast(Batch as varchar) as Batch, MeasurementA, MeasurementB, Date from dd where ID=",e()," Order by  ID asc ;", sep="") })

  # observe e() so that data is not added until user presses action button  
  observe({
    if (!is.null(e())) {
      sq <- reactive({  query( b() ) })

      # add query to reactive data frame
      values$df <- rbind(isolate(values$df), sq())
    }
  })



  asub <- eventReactive(input$do3,{subset(values$df, MeasurementA > input$Von[1] & MeasurementA < input$Von[2] )})

  observeEvent(input$do4, {

    values$df <- NULL

  })

  output$boxV <- renderPlot({
    ggplot(asub(), aes_string('Wafer', input$char, fill='Batch')) + geom_boxplot() 
  })

  })

用户界面

shinyUI(fluidPage(
  titlePanel("Generic grapher"),
  sidebarLayout(
    sidebarPanel(

      numericInput("wafer", label = h3("Input wafer ID:"), value = NULL),

      actionButton("do", "Search wafer"),
      actionButton("do2", "Add to data frame"),
      actionButton("do3", "Show"),
      actionButton("do4", "Clear"),
      selectInput("char", label="Boxplot choice:",
                  choices = list("A"="MeasurementA", "B"="MeasurementB"),                            
                  selected="Von.fwd"),
      sliderInput("Von", label = "A range:",
                  min=0, max=10, value=c(0,10), step=0.1)

      ),

      mainPanel(
        verbatimTextOutput("que"), 
        verbatimTextOutput("pos"),
        plotOutput("boxV")
        #dataTableOutput(outputId="posi")
      )
    )
  )
)

在上面，如果您搜索晶片“1”，它会绘制所有数据，即使晶片 1 有两个日期(这是预期的)。所以我在想，如果当我点击“搜索晶圆”时，如果该晶圆存在两个日期，我会得到一个弹出窗口。到目前为止，我已经阅读了这个:

Add a popup with error, warning to shiny

还有这个:

Create a pop-up menu with right click about an object

这表明我可以产生警告消息(尽管我还没有尝试过这样做)。但是我想知道是否有某种方法可以使弹出窗口具有交互性以选择所需的日期。也许我应该联系 shinyBS 的创建者，这看起来是我最好的选择？

Answer 1

我创建了一个示例应用程序，它应该可以很好地介绍如何使用警报。我没有使用来自 shinyBS 的警报如您所见，我使用了 session$sendCustomMessage用JS发送消息alert功能。我在代码中添加了一些注释，所以看看。请注意，我使用了 sub通过将我的表达式替换为 来创建所需文本的函数一些东西字符串的一部分。

rm(list = ls())
library(shiny)
library(DT)

ui <- fluidPage(

  # Inlcude the line below in ui.R so you can send messages
  tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});'))),
  titlePanel("Pop-up Alerts"),
  sidebarPanel(
    sliderInput("my_slider", "Range Slider:", min = 0, max = 150, value = 40, step=1),
    dateInput('my_daterange',label = '',value = Sys.Date()),
    actionButton("run","Execute")),
  mainPanel(DT::dataTableOutput('tbl'))
)

server <- function(input, output, session) {

  # Alert below will trigger if the slider is over 100
  observe({
    if(input$my_slider >= 100)
    {
      my_slider_check_test <- "Your slider value is above 100 - no data will be displayed"
      js_string <- 'alert("SOMETHING");'
      js_string <- sub("SOMETHING",my_slider_check_test,js_string)
      session$sendCustomMessage(type='jsCode', list(value = js_string))
    }
  })


  # Alert below about dates will notify you if you selected today
  observe({
    if (is.null(input$run) || input$run == 0){return()}
    isolate({
      input$run
      if(input$my_daterange == Sys.Date())
      {
        my_date_check_test <- "Today Selected"
        js_string <- 'alert("SOMETHING");'
        js_string <- sub("SOMETHING",my_date_check_test,js_string)
        session$sendCustomMessage(type='jsCode', list(value = js_string))
      }
      # Alert will also trigger and will notify about the dates
      if(input$my_daterange == Sys.Date())
      {
        my_date_check_test <- paste0("You selected: ",input$my_daterange)
        js_string <- 'alert("SOMETHING");'
        js_string <- sub("SOMETHING",my_date_check_test,js_string)
        session$sendCustomMessage(type='jsCode', list(value = js_string))
      }

    })
  })

  my_data <- reactive({

    if(input$run==0){return()}
    isolate({
      input$run
      if(input$my_slider >= 100)
      {
        # Alert below will trigger if you adjusted the date but slider is still 100
        my_slider_check_test <- "Slider is still over 100"
        js_string <- 'alert("SOMETHING");'
        js_string <- sub("SOMETHING",my_slider_check_test,js_string)
        session$sendCustomMessage(type='jsCode', list(value = js_string))
      }
      if(input$my_slider < 100)
      {
        iris[1:input$my_slider,]
      }
    })  
})
output$tbl = DT::renderDataTable(my_data(), options = list(lengthChange = FALSE))
}

shinyApp(ui = ui, server = server)

一些弹出窗口的输出在 IE 中, Google Chrome会有所不同:

#1 slider 超过 100 个警报


#2 日期:今天选择


#3 日期:只需打印日期 即可发出警报


#4 警告显示 slider 仍然超过 100


#5 如果 slider 小于 100，则得到 tableoutput