如何使动作按钮 eventReactive() 到 Shiny 中的多个滑动条

Question

我试图让 shiny 在用户单击操作按钮后使用滑动条值进行计算。这些滑动条代表五个维度，用户可以拖动这些维度来设置他喜欢的每个变量的权重值。单击操作按钮后，应用程序应显示荷兰地图，其中包含根据这些权重值 'score' 最高的城市。目前我得到了以下代码运行，但在您单击操作按钮后速度非常慢，因为它会在反应性滑动条发生变化时自动重新执行。有人建议让我的代码更快，并且操作按钮 eventReactive 必须单击它才能让 shiny 知道进行新计算吗？

我已经在我的主脚本中添加了一个要点 link，因为我想不出更简单的方法来共享我的数据 (spatialpolygonsdataframe)：https://gist.github.com/anonymous/602948bce91e61f36fd3eb0c4259d26c

Shiny 应用截图：https://i.stack.imgur.com/k0Vg9.png

app.R

library(shiny)
library(leaflet)

ui <- fluidPage(
  titlePanel("Quality-of-life-o-meter of The Netherlands"),

  sidebarLayout(
    sidebarPanel(
      h3("Dimensions"),
      h6("Assign a weight value for every dimension and press the 'find!' button"),
      sliderInput("housingslider", 
                  label = h4("Housing"), 
                  min = 1, 
                  max = 5, 
                  value = 1),
      sliderInput("populationslider", 
                  label = h4("Population"), 
                  min = 1, 
                  max = 5, 
                  value = 1),
      sliderInput("provisionsslider", 
                  label = h4("Provisions"), 
                  min = 1, 
                  max = 5, 
                  value = 1),
      sliderInput("safetyslider", 
                  label = h4("Safety"), 
                  min = 1, 
                  max = 5, 
                  value = 1),
      sliderInput("physicalenvslider", 
                  label = h4("Physical Environment"), 
                  min = 1, 
                  max = 5, 
                  value = 1),
      actionButton("action", label = "Find!")
    ),
    mainPanel(
      leafletOutput("mymap", height = "800")
    )
  )
)

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

  output$mymap <-renderLeaflet({
    # Create interactive map of Total Score of Muncipalities in 2016 to display first
    leaflet(data = MunScores2016) %>% addTiles() %>%
      addPolygons(fillColor = ~pal(Total_Score_2016), 
                  fillOpacity = 1, 
                  color = 'white', 
                  weight = 1,
                  popup = popup_dat) %>%
      addLegend("bottomright", # Legend position
                pal=pal, # color palette
                values=~Total_Score_2016, # legend values
                opacity = 0.7,
                title="Percentage difference from national average")
  })  

  observeEvent(input$action,
               output$mymap <-renderLeaflet({
                 Total_Score <- NA
                 Total_Score <- ((input$housingslider * MunScores2016$Housing_Score_2016 +
                                input$populationslider * MunScores2016$Population_Score_2016 +
                                input$provisionsslider * MunScores2016$Provisions_Score_2016 +
                                input$safetyslider * MunScores2016$Safety_Score_2016 +
                                input$physicalenvslider * MunScores2016$PhysicalEnvironment_Score_2016)/
                               (input$housingslider + input$populationslider + input$provisionsslider + input$safetyslider + input$physicalenvslider))
             #Create interactive map
                 leaflet(data = MunScores2016) %>% addTiles() %>%
                   addPolygons(fillColor = ~pal(Total_Score), 
                               fillOpacity = 1, 
                               color = 'white', 
                               weight = 1,
                               popup = paste0("<strong>Municipality:</strong>", 
                                          MunScores2016$Municipality_Name, 
                                          "<br><strong>Quality-of-life-o-meter says: </strong>", 
                                          Total_Score)) %>%
                   addLegend("bottomright", # Legend position
                             pal=pal, # color palette
                             values=~Total_Score_2016, # legend values
                             opacity = 0.7,
                             title="Weighted percentage difference from national average")
               })

  )
}  
shinyApp(ui = ui, server = server)

Answer 1

您的代码很慢，因为您在不知情的情况下不断地重新创建所有内容。

刷新

让我先解决您的滑块刷新问题：

在 observeEvent 中（实际上仅在按下按钮时触发），您将 反应环境 分配给 output$mymap （所有渲染函数都是反应环境）。

里面的renderLeaflet，你再name输入参数，此时Shiny会自动跟踪 这些输入作为可观察值。

因此，您对渲染函数的分配会在单击按钮后发生，但渲染函数本身不受限制对于这个事件，因为反应环境比赋值调用的寿命更长。

有两种方法可以将此逻辑从渲染函数中拉出。

1) 在每个输入引用周围使用 isolate。（即 isolate(input$housingslider) ）。这样你抑制对输入滑块的反应 link 和渲染可观察对象将不再有更新触发器，只在你创建它时更新一次。

output$mymap <-renderLeaflet({
  Total_Score <- NA
  # isolate(expr) prevents observables in expr from being subscribed to.
  Total_Score <- isolate(
    (
      input$housingslider * MunScores2016$Housing_Score_2016
      + input$populationslider * MunScores2016$Population_Score_2016  
      + input$provisionsslider * MunScores2016$Provisions_Score_2016 
      + input$safetyslider * MunScores2016$Safety_Score_2016
      + input$physicalenvslider * PhysicalEnvironment_Score_2016
    ) / (
      input$housingslider
      + input$populationslider
      + input$provisionsslider 
      +  input$safetyslider 
      + input$physicalenvslider
    )
  )

  ...
})

2) 更好：将 Total_Score 的计算移到 renderLeaflet 函数的 之外。这样，输入的 observables 不会在反应环境中得到 named，即 renderLeaflet，然后它只知道它无法订阅的值 Total_Score到。然后输入可观察量只属于外部 observeEvent，它将忽略除动作按钮点击之外的输入变化。

observeEvent(input$action, {
  Total_Score <- NA
  # isolate(expr) prevents observables in expr from being subscribed to.
  Total_Score <- (
    input$housingslider * MunScores2016$Housing_Score_2016
    + input$populationslider * MunScores2016$Population_Score_2016  
    + input$provisionsslider * MunScores2016$Provisions_Score_2016 
    + input$safetyslider * MunScores2016$Safety_Score_2016
    + input$physicalenvslider * PhysicalEnvironment_Score_2016
  ) / (
    input$housingslider
    + input$populationslider
    + input$provisionsslider 
    +  input$safetyslider 
    + input$physicalenvslider
  )

  output$mymap <-renderLeaflet({
    # Use Total_Score here and no input$
    ...
  })
})

重画

但是现在你应该如何实现这个：使用 leafletProxy!!

每次调用 renderLeaflet 时，您都会销毁之前使用过的地图对象并创建一个全新的地图对象（并再次创建所有图块，这意味着也获取这些资源）。当您看到每次都重置缩放和视图位置时，您就会意识到这一点。

有一种方法可以重复使用您之前创建的地图。

函数 leafletProxy(<name>) 允许您访问您使用 output$<name> <- renderLeaflet(...) 创建的地图，并允许访问常规传单调用的所有函数。

因此我们重写了您的代码，使其在开始时只有一个渲染函数，不再重新创建。服务器功能如下：

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

  # Create Map once.
  output$mymap <-renderLeaflet({
    leaflet(data = MunScores2016)
      %>% addTiles()
      %>% addPolygons(
        fillColor = ~pal(Total_Score_2016),
        fill2Opacity = 1, 
        color = 'white', 
        weight = 1,
        popup = popup_dat)
      %>% addLegend(
        "bottomright",
        pal=pal,
        values=~Total_Score_2016,
        opacity = 0.7,
        title="Percentage difference from national average")
  })

  observeEvent(input$action, {
    Total_Score <- NA
    Total_Score <- ((input$housingslider * MunScores2016$Housing_Score_2016 +
      input$populationslider * MunScores2016$Population_Score_2016 +
      input$provisionsslider * MunScores2016$Provisions_Score_2016 +
      input$safetyslider * MunScores2016$Safety_Score_2016 +
      input$physicalenvslider * MunScores2016$PhysicalEnvironment_Score_2016)/
      (input$housingslider + input$populationslider + input$provisionsslider + input$safetyslider + input$physicalenvslider))

    # Just update the existing map
    leafletProxy("mymap")
      # This you have to do now: remove the existing polygons, before you paint new ones.
      %>% clearShapes()
      %>% addPolygons(
        fillColor = ~pal(Total_Score), 
        fillOpacity = 1, 
        color = 'white', 
        weight = 1,
        popup = paste0("<strong>Municipality:</strong>", 
          MunScores2016$Municipality_Name, 
          "<br><strong>Quality-of-life-o-meter says: </strong>", 
          Total_Score))
      # As you can see, no addLegend is needed, since the legend does not change. 
  })
}

使用它，以上所有刷新问题都不会再出现，因为您不需要为地图重新创建反应环境。不过，我认为第一部分对以后会有帮助。

如何使动作按钮 eventReactive() 到 Shiny 中的多个滑动条

How to make action button eventReactive() to multiple slide bars in Shiny

r

shiny

leaflet

r-leaflet

刷新

重画