在调用onRender（）之后，擦除所有selectizeInput（）值而没有Shiny app关闭

Question

我正在尝试创建一个Shiny应用程序来探索具有4个变量/列（A，B，C，D）和10,000行的数据框。有一个输入字段，用户必须在其中选择4个变量/列中的2个。一旦他们这样做了，那么右边会显示一个散点图。散点图是一个Plotly对象，带有六边形分箱，汇总了两个用户选择的变量/列之间10,000行的值。

此时，用户可以选择“开始！”按钮，它使与这2个变量/列的第一行对应的橙色点叠加​​到Plotly对象上。用户可以按顺序选择“开始！”然后对应于第二，第三，第四等行的橙色点将叠加到Plotly对象上。行ID的名称输出在散点图矩阵上方。

在大多数情况下，应用程序正在运行。我只想改进两件事：

1）我希望用户能够在输入字段中选择新对。这在很大程度上起作用。但是，有一种特殊情况会导致应用程序突然关闭。它发生在橙色点叠加​​到散点图上之后。如果用户随后擦除了两个输入对，则应用程序突然关闭。我希望用户能够擦除两个输入对值并输入两个新的对值，即使在将橙色点绘制到散点图之后，应用程序也不会关闭。

2）我注意到在绘制橙色点后行ID的输出略有滞后。我想知道为什么会发生这种情况，因为我在绘制脚本中的橙色点之前输出行ID。我希望有更少的滞后，但不确定如何处理。

如何解决这两个问题中的任何一个的任何建议将不胜感激！我的MWE显示了这个问题如下。

library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)

myPairs <- c("A", "B", "C", "D")

ui <- shinyUI(fluidPage(
  titlePanel("title panel"),

  sidebarLayout(position = "left",
    sidebarPanel(
      selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE, options = list(maxItems = 2)),
      actionButton("goButton", "Go!"),
      width = 3
    ),
    mainPanel(
      verbatimTextOutput("info"),
      plotlyOutput("scatMatPlot")
    )
  )
))

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

  # Create data and subsets of data based on user selection of pairs
  dat <- data.frame(ID = paste0("ID", 1:10000), A = rnorm(10000), B = rnorm(10000), C = rnorm(10000), D = rnorm(10000))
  pairNum <- reactive(input$selPair)
  group1 <- reactive(pairNum()[1])
  group2 <- reactive(pairNum()[2])
  sampleIndex <- reactive(which(colnames(dat) %in% c(group1(), group2())))

  # Create data subset based on two letters user chooses
  datSel <- eventReactive(sampleIndex(), {
    datSel <- dat[, c(1, sampleIndex())]
    datSel$ID <- as.character(datSel$ID)
    datSel <- as.data.frame(datSel)
    datSel
  })

  sampleIndex1 <- reactive(which(colnames(datSel()) %in% c(group1())))
  sampleIndex2 <- reactive(which(colnames(datSel()) %in% c(group2())))

  # Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
  ggPS <- eventReactive(datSel(), {
    minVal = min(datSel()[,-1])
    maxVal = max(datSel()[,-1])
    maxRange = c(minVal, maxVal)
    xbins=7
    buffer = (maxRange[2]-maxRange[1])/xbins/2
    x = unlist(datSel()[,(sampleIndex1())])
    y = unlist(datSel()[,(sampleIndex2())])
    h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE, xbnds=maxRange, ybnds=maxRange)
    hexdf <- data.frame (hcell2xy (h),  hexID = h@cell, counts = h@count)
    attr(hexdf, "cID") <- h@cID
    p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) + geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) + coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer), ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) + coord_equal(ratio=1) + labs(x = colnames(datSel()[sampleIndex1()]), y = colnames(datSel()[sampleIndex2()]))
    ggPS <- ggplotly(p)
    ggPS})

  # Output hex bin plot created just above
  output$scatMatPlot <- renderPlotly({
    # Each time user pushes Go! button, the next row of the data frame is selected
    datInput <- eventReactive(input$goButton, {
      g <- datSel()$ID[input$goButton]

      # Output ID of selected row
      output$info <- renderPrint({
        g
      })

      # Get x and y values of seleced row
      currGene <- datSel()[which(datSel()$ID==g),]
      currGene1 <- unname(unlist(currGene[,sampleIndex1()]))
      currGene2 <- unname(unlist(currGene[,sampleIndex2()]))
      c(currGene1, currGene2)
    })

    # Send x and y values of selected row into onRender() function
    observe({
      session$sendCustomMessage(type = "points", datInput())
    })

    # Use onRender() function to draw x and y values of seleced row as orange point
    ggPS() %>% onRender("
      function(el, x, data) {

      noPoint = x.data.length;

      Shiny.addCustomMessageHandler('points', function(drawPoints) {
        if (x.data.length > noPoint){
          Plotly.deleteTraces(el.id, x.data.length-1);
        }

        var Traces = [];
        var trace = {
          x: drawPoints.slice(0, drawPoints.length/2),
          y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
          mode: 'markers',
          marker: {
            color: 'orange',
            size: 7
          },
          hoverinfo: 'none'
        };
        Traces.push(trace);
        Plotly.addTraces(el.id, Traces);
      });}")
    })
})

shinyApp(ui, server)

Answer 1

正如@HubertL所提到的，避免嵌套反应函数会更好。如果你改变它，你的应用程序可能会更顺畅地运行。

关于您的第一个问题，req和validate可能是最好的方法。这些函数检查用户输入是否有效并处理无效输入。

我已经根据这些规则对您的代码进行了一些调整，但您仍然可以更改它。如果您仔细查看ggPS，可能会发现它只使用datSel()，因此您可以将其转换为函数。

library(plotly)
library(GGally)
library(hexbin)
library(htmlwidgets)
library(tidyr)
library(shiny)
library(dplyr)
library(data.table)
library(ggplot2)
library(tibble)
myPairs <- c("A", "B", "C", "D")

ui <- shinyUI(fluidPage(
  titlePanel("title panel"),
  sidebarLayout(
    position = "left",
    sidebarPanel(
      selectizeInput("selPair", "Pairs:", choices = myPairs, multiple = TRUE,
                     options = list(maxItems = 2)),
      actionButton("goButton", "Go!"),
      width = 3
    ),
    mainPanel(
      verbatimTextOutput("info"),
      plotlyOutput("scatMatPlot")
    )
  )
))

server <- shinyServer(function(input, output, session) {
  # Create data and subsets of data based on user selection of pairs
  dat <- data.frame(
    ID = paste0("ID", 1:10000), A = rnorm(10000),
    B = rnorm(10000), C = rnorm(10000), D = rnorm(10000),
    stringsAsFactors = FALSE
  )

  # Create data subset based on two letters user chooses
  datSel <- eventReactive(input$selPair, {
    validate(need(length(input$selPair) == 2, "Select a pair."))
    dat[c("ID", input$selPair)]
  }, ignoreNULL = FALSE)

  # Create background Plotly graph with hex binning all 100 rows of the two user-selected columns
  ggPS <- eventReactive(datSel(), {
    minVal = min(datSel()[,-1])
    maxVal = max(datSel()[,-1])
    maxRange = c(minVal, maxVal)
    xbins=7
    buffer = (maxRange[2]-maxRange[1])/xbins/2
    x = unlist(datSel()[input$selPair[1]])
    y = unlist(datSel()[input$selPair[2]])
    h <- hexbin(x=x, y=y, xbins=xbins, shape=1, IDs=TRUE,
                xbnds=maxRange, ybnds=maxRange)
    hexdf <- data.frame (hcell2xy (h),  hexID = h@cell, counts = h@count)
    attr(hexdf, "cID") <- h@cID
    p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, hexID=hexID)) +
      geom_hex(stat="identity") + geom_abline(intercept = 0, color = "red", size = 0.25) +
      coord_cartesian(xlim = c(maxRange[1]-1*buffer, maxRange[2]+buffer),
                      ylim = c(maxRange[1]-1*buffer, maxRange[2]+buffer)) +
      coord_equal(ratio = 1) +
      labs(x = input$selPair[1], y = input$selPair[2])
    ggPS <- ggplotly(p)
    ggPS
  })

  # Output ID of selected row
  output$info <- renderPrint({ datSel()$ID[req(input$goButton)] })

  # Output hex bin plot created just above
  output$scatMatPlot <- renderPlotly({
    # Use onRender() function to draw x and y values of seleced row as orange point
    ggPS() %>% onRender("
                        function(el, x, data) {
                        noPoint = x.data.length;
                        Shiny.addCustomMessageHandler('points', function(drawPoints) {
                        if (x.data.length > noPoint){
                        Plotly.deleteTraces(el.id, x.data.length-1);
                        }
                        var Traces = [];
                        var trace = {
                        x: drawPoints.slice(0, drawPoints.length/2),
                        y: drawPoints.slice(drawPoints.length/2, drawPoints.length),
                        mode: 'markers',
                        marker: {
                        color: 'orange',
                        size: 7
                        },
                        hoverinfo: 'none'
                        };
                        Traces.push(trace);
                        Plotly.addTraces(el.id, Traces);
                        });}")
  })

  observe({
    # Get x and y values of seleced row
    currGene <- datSel()[input$goButton, -1]
    # Send x and y values of selected row into onRender() function
    session$sendCustomMessage(type = "points", unname(unlist(currGene)))
  })
})

shinyApp(ui, server)