R闪亮和传单：尝试使用反应式表达式更新空间多边形数据框答案

【问题标题】：R shiny and leaflet: Trying to update Spatial Polygon Dataframe using reactive expressionR闪亮和传单：尝试使用反应式表达式更新空间多边形数据框
【发布时间】：2017-08-20 22:04:35
【问题描述】：

我已经为独立工作的输入和传单地图编写了代码，但是当我试图让它们相互依赖时出错。总体而言，我试图允许调整这 4 个滑块以提供“权重”，然后用于计算我的空间多边形数据框中的新字段。然后，我想获取更新后的文件并将其放入 Leaflet。然后我希望能够使用另一个滑块按分数进一步过滤多边形。

我已密切关注RStudio Tutorial 来格式化我的代码。基本上，我使用响应式表达式进行计算，将它们定义为变量（例如 NewVar

我在下面粘贴整个代码。如果有什么突出的地方，请告诉我 - 或者帮助我了解如何从对空间多边形数据框进行计算的反应式表达式中正确调用列。

# Build UI
ui <- fluidPage(

titlePanel("UNCWI Score Evaluation"),

sidebarLayout(

sidebarPanel(
sliderInput(inputId = "weightir", label = "Weight for IR",
          value = 0.19, min = 0, max = 1),
sliderInput(inputId = "weightul", label = "Weight for Upland Protection",
          value = 0.31, min = 0, max = 1),
sliderInput(inputId = "weightva", label = "Weight for Vulnerable Areas",
          value = 0.21, min = 0, max = 1),
sliderInput(inputId = "weightwsc", label = "Weight for WSC",
          value = 0.29, min = 0, max = 1),
actionButton("run", "Run")
),

mainPanel(
leafletOutput("map"),
sliderInput("range", "Scores", min = 0.0, max= 10.0, value = as.numeric(c("0.0", "10.0")), step = 0.1),
actionButton("export", "Export Shapefile")
)
))

# Render Outputs
server <- function(input, output) {
defaultData <- eventReactive(input$run, {
# Multiply by Weights
merge.proj@data$IR_WtScore <- round(merge.proj@data$MEAN_IR_Sc*input$weightir, digits = 1)
merge.proj@data$UL_WtScore <- round(merge.proj@data$MEAN_UL_Sc*input$weightul, digits = 1)
merge.proj@data$VA_WtScore <- round(merge.proj@data$MEAN_VA_Sc*input$weightva, digits = 1)
merge.proj@data$WSC_WtScore <- round(merge.proj@data$MEAN_WSC_S*input$weightwsc, digits = 1)
# Find Total Score
merge.proj@data$Total_Score <- merge.proj@data$IR_WtScore + merge.proj@data$UL_WtScore + merge.proj@data$VA_WtScore + merge.proj@data$WSC_WtScore
})

# Plot with leaflet

# Palette for map
colorpal <-  reactive({
merge.proj <- defaultData()  
colorNumeric(palette = "YlOrRd",
domain = merge.proj$Total_Score)
})

# Label Option for map
labels <- reactive({  
merge.proj <- defaultData()  
lsprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score:</strong>%g", merge.proj$PARCEL_ID, merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})

# Render Default Map
output$map <- renderLeaflet ({leaflet() %>% 
        merge.proj <- defaultData()
        pal <- colorpal()
        lab <- labels()
  addTiles() %>%
  addPolygons(data=merge.proj,
              fillColor = ~pal(Total_Score),
              weight = 1,                              
              opacity = 1,
              color = "white",
              dashArray = "3",
              fillOpacity = 0.7,
              highlight = highlightOptions(
                weight = 3,                              
                color = "#666",
                dashArray = "",
                fillOpacity = 0.7,
                bringToFront = TRUE),
              label = lab,
              labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto")) %>%
  addLegend(position = "bottomleft",pal = pal, opacity = 0.7, values = merge.proj$Total_Score, title = "<strong>Total Score</strong>")
})

# Update map to parcel score slider

# Subset data
  filteredData <- reactive({
    merge.proj <- defaultData()
merge.proj[merge.proj@data$Total_Score >= input$range[1] & merge.proj@data$Total_Score <= input$range[2],]
})


# New Palette
  colorpal2 <-  reactive({
    merge.proj <- filteredData()  
    colorNumeric(palette = "YlOrRd",
      domain = merge.proj$Total_Score)
  })

# Label Option
  labels2 <- reactive({  
    merge.proj <- filteredData()  
    sprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score: </strong>%g", merge.proj$PARCEL_ID, merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})

#Leaflet Proxy
  observe({
    merge.proj <- filteredData()
    pal2 <- colorpal2()
    lab2 <- labels2()

    leafletProxy("map", data = filteredData()) %>%
      clearShapes() %>%
      addPolygons(
        fillColor = ~pal2(Total_Score),
        weight = 1,                              
        opacity = 1,
        color = "white",
        dashArray = "3",
        fillOpacity = 0.7,
        highlight = highlightOptions(
          weight = 3,                             
          color = "#666",
          dashArray = "",
          fillOpacity = 0.7,
          bringToFront = TRUE),
        label = lab2,
        labelOptions = labelOptions(
          style = list("font-weight" = "normal", padding = "3px 8px"),
          textsize = "15px",
          direction = "auto"))
})

#Update Legend
observe({
    proxy <- leafletProxy("map", data = filteredData())

    pal2 <- colorpal2()
    proxy %>% clearControls()
    proxy %>% addLegend(position = "bottomleft",pal = pal2, opacity = 0.7, values = ~Total_Score, title = "<strong>Total Score</strong>")
})

# Export new shapefile
observeEvent(input$export, {
    merge.proj <- filteredData()
writeOGR(merge.proj, dsn = "Data", layer = "UNCWI_Output", driver = "ESRI Shapefile")
})
}

shinyApp(ui = ui, server = server)

【问题讨论】：

标签： r shiny dependencies leaflet reactive

【解决方案1】：

我通过将leaflet() %>% 移动到我在代码的renderLeaflet({}) 部分中定义变量的位置来使我的代码工作。见下文：

# Build UI
ui <- fluidPage(

titlePanel("UNCWI Score Evaluation"),

sidebarLayout(

sidebarPanel(
sliderInput(inputId = "weightir", label = "Weight for IR",
          value = 0.19, min = 0, max = 1),
sliderInput(inputId = "weightul", label = "Weight for Upland Protection",
          value = 0.31, min = 0, max = 1),
sliderInput(inputId = "weightva", label = "Weight for Vulnerable Areas",
          value = 0.21, min = 0, max = 1),
sliderInput(inputId = "weightwsc", label = "Weight for WSC",
          value = 0.29, min = 0, max = 1),
actionButton("run", "Run")
),

mainPanel(
leafletOutput("map"),
sliderInput("range", "Scores", min = 0.0, max= 10.0, value = as.numeric(c("0.0", "10.0")), step = 0.1),
actionButton("export", "Export Shapefile")
)
))

# Render Outputs
server <- function(input, output) {
defaultData <- eventReactive(input$run, {
# Multiply by Weights
merge.proj@data$IR_WtScore <- round(merge.proj@data$MEAN_IR_Sc*input$weightir, digits = 1)
merge.proj@data$UL_WtScore <- round(merge.proj@data$MEAN_UL_Sc*input$weightul, digits = 1)
merge.proj@data$VA_WtScore <- round(merge.proj@data$MEAN_VA_Sc*input$weightva, digits = 1)
merge.proj@data$WSC_WtScore <- round(merge.proj@data$MEAN_WSC_S*input$weightwsc, digits = 1)
# Find Total Score
merge.proj@data$Total_Score <- merge.proj@data$IR_WtScore + merge.proj@data$UL_WtScore + merge.proj@data$VA_WtScore + merge.proj@data$WSC_WtScore
})

# Plot with leaflet

# Palette for map
colorpal <-  reactive({
merge.proj <- defaultData()  
colorNumeric(palette = "YlOrRd",
domain = merge.proj$Total_Score)
})

# Label Option for map
labels <- reactive({  
merge.proj <- defaultData()  
lsprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score:</strong>%g", merge.proj$PARCEL_ID, merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})

# Render Default Map
output$map <- renderLeaflet ({
        merge.proj <- defaultData()
        pal <- colorpal()
        lab <- labels()
  leaflet() %>% 
  addTiles() %>%
  addPolygons(data=merge.proj,
              fillColor = ~pal(Total_Score),
              weight = 1,                              
              opacity = 1,
              color = "white",
              dashArray = "3",
              fillOpacity = 0.7,
              highlight = highlightOptions(
                weight = 3,                              
                color = "#666",
                dashArray = "",
                fillOpacity = 0.7,
                bringToFront = TRUE),
              label = lab,
              labelOptions = labelOptions(
                style = list("font-weight" = "normal", padding = "3px 8px"),
                textsize = "15px",
                direction = "auto")) %>%
  addLegend(position = "bottomleft",pal = pal, opacity = 0.7, values = merge.proj$Total_Score, title = "<strong>Total Score</strong>")
})

# Update map to parcel score slider

# Subset data
  filteredData <- reactive({
    merge.proj <- defaultData()
merge.proj[merge.proj@data$Total_Score >= input$range[1] & merge.proj@data$Total_Score <= input$range[2],]
})


# New Palette
  colorpal2 <-  reactive({
    merge.proj <- filteredData()  
    colorNumeric(palette = "YlOrRd",
      domain = merge.proj$Total_Score)
  })

# Label Option
  labels2 <- reactive({  
    merge.proj <- filteredData()  
    sprintf("<strong>Parcel ID: </strong>%s<br/><strong>Total Score: </strong>%g", merge.proj$PARCEL_ID, merge.proj$Total_Score) %>% lapply(htmltools::HTML)
})

#Leaflet Proxy
  observe({
    merge.proj <- filteredData()
    pal2 <- colorpal2()
    lab2 <- labels2()

    leafletProxy("map", data = filteredData()) %>%
      clearShapes() %>%
      addPolygons(
        fillColor = ~pal2(Total_Score),
        weight = 1,                              
        opacity = 1,
        color = "white",
        dashArray = "3",
        fillOpacity = 0.7,
        highlight = highlightOptions(
          weight = 3,                             
          color = "#666",
          dashArray = "",
          fillOpacity = 0.7,
          bringToFront = TRUE),
        label = lab2,
        labelOptions = labelOptions(
          style = list("font-weight" = "normal", padding = "3px 8px"),
          textsize = "15px",
          direction = "auto"))
})

#Update Legend
observe({
    proxy <- leafletProxy("map", data = filteredData())

    pal2 <- colorpal2()
    proxy %>% clearControls()
    proxy %>% addLegend(position = "bottomleft",pal = pal2, opacity = 0.7, values = ~Total_Score, title = "<strong>Total Score</strong>")
})

# Export new shapefile
observeEvent(input$export, {
    merge.proj <- filteredData()
writeOGR(merge.proj, dsn = "Data", layer = "UNCWI_Output", driver = "ESRI Shapefile")
})
}

shinyApp(ui = ui, server = server)

【讨论】：

【解决方案2】：

这是我以前见过的问题。基本上，最推荐的 Shiny 设计模式虽然简单易懂，但还是会导致这些死胡同。我更喜欢使用reactiveValues 来解决这个问题，因为这可以为您提供所需的灵活性。

我无法使用您的代码，因为它不是一个完整的示例（merge.proj 未在任何地方定义）。

但是我修改了你说你“密切关注”的例子以使用reactiveValues，这样你就可以明白我的意思了。

library(shiny)
library(leaflet)

r_colors <- rgb(t(col2rgb(colors()) / 255))
names(r_colors) <- colors()

ui <- fluidPage(
  leafletOutput("mymap"),
  p(),
  actionButton("recalc", "New points")
)

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

  # initialize our leaflet map into a reactive value
  rv <- reactiveValues(lmap=leaflet() %>% addProviderTiles(providers$Stamen.TonerLite,
                                          options = providerTileOptions(noWrap = TRUE))

  points <- eventReactive(input$recalc, {
     cbind(rnorm(40) * 2 + 13, rnorm(40) + 48)

     # now modify our leaflet map with our new points
     # note we could do anything with our map, we have access to all its columns
     rv$lmap <- addMarkers(rv$lmap,data=points())
  }, ignoreNULL = FALSE)

  output$mymap <- renderLeaflet({
     # reactively render the map when it changes
     rv$lmap
  })
}

shinyApp(ui, server)

逻辑比仅仅使用纯粹的反应值更复杂，但我发现它导致了更灵活的结构。

在您的情况下，您需要将 merge.proj 初始化到该 reactiveValues 列表中（我认为）。另请注意，您可以在该列表中包含多个元素，它们非常灵活。

【讨论】：

非常感谢您的回答！在我继续编写脚本时，我会牢记这一点。实际上，我通过将leaflet() %>% 移到我定义变量的位置下方来使我的代码工作。
如果您自己解决了这个问题，您可以发布一个解决方案来描述您所做的事情，并将其标记为正确（一段时间后）。这可以帮助将来遇到同样问题的人。只留下一个空的未回答的问题对任何人都没有帮助。
知道了！谢谢你的建议。这是我在 stackoverflow 上提出问题的第一个项目。