基于用户输入的彩色小叶多边形(使用预定义的基于分类的调色板)

Question

我正在构建一个基于选举结果的应用程序，我想用每个选民的当选政党的颜色给传单地图上的多边形上色。用户可以选择要查看结果的年份:在位党(当前)、2013年等。

我在这里读了很多关于基于用户输入的动态调色板和反应式调色板，但它们都不适用于我的预定义调色板，它根据政党颜色为每个政党设置特定的颜色。

我不确定我遗漏了什么或做错了什么，但我将非常感谢您的帮助。

您可以在此处下载shp文件，我使用的是Queensland 2018发行版：https://www.aec.gov.au/electorates/gis/

下面是我在Elect_div字段中与shape文件合并的当选政党数据：

PartyAb<-c(ALP,"LNP","LNP", "LNP","LNP","LNP","LNP","LNP","LNP","LNP","LNP",    "LNP","ALP","LNP","ALP","LNP","KAP","LNP","ALP","ALP","LNP","LNP","LNP","ALP",  "ALP","LNP","ALP","LNP","LNP","LNP")
Elected_Party_2013<-c("ALP","LNP","LNP","LNP","LNP","LNP","LNP","LNP","PUP",    "LNP","LNP","LNP","ALP","LNP","LNP","LNP","KAP","LNP","ALP","LNP","LNP","LNP",  "LNP",  "ALP",  "ALP",  "LNP",  "ALP",  "LNP","LNP","LNP")
 Elect_div<-c("Blair","Bonner","Bowman","Brisbane", 
                          "Capricornia","Dawson","Dickson","Fadden",
                          "Fairfax","Fisher","Flynn","Forde",
                          "Griffith","Groom","Herbert","Hinkler",
                          "Kennedy","Leichhardt","Lilley",
                          "Longman","Maranoa","McPherson",
                          "Moncrieff","Moreton","Oxley",
                          "Petrie","Rankin","Ryan",
                          "Wide Bay","Wright")

 df.party <- data.frame c(PartyAb, Elected_Party_2013, Elect_div)

#read in the shape files and filter to only have qld elects
qld<-readOGR(dsn=path.expand("./data/shape_files"), layer="E_AUGEC_region")
qld<-qld[qld$Elect_div %in% c("Blair","Bonner","Bowman","Brisbane", 
                          "Capricornia","Dawson","Dickson","Fadden",
                          "Fairfax","Fisher","Flynn","Forde",
                          "Griffith","Groom","Herbert","Hinkler",
                          "Kennedy","Leichhardt","Lilley",
                          "Longman","Maranoa","McPherson",
                          "Moncrieff","Moreton","Oxley",
                          "Petrie","Rankin","Ryan",
                          "Wide Bay","Wright"),]
#merge the csv to the shape file based on elect_div
qld.stats <- merge(qld, df, by = "Elect_div")


ui<- fluidPage(selectInput("stats", "",label="Select a statistic to display spatially on the map.",
                             choices= list("Sitting Party"="PartyAb",
                                           "2013 results"="Elected_Party_2013" ))
)

#colour palette based on party colours

party_cols<-c("LNP"="#021893","ALP" = "#C12525","IND" = "grey", "KAP" = "#33165F",
          "PUA"="orange", "ON"="orange", "GRN"="#339966", "LNQ"="#0066FF",
          "LP"="#0033CC", "NP"="#009999", "Electorate not established in 2007"="black", "Electorate not established in 2004"="black")

#attempt to create a reactive colour palette using the party_cols colour palette based on user input but it doesnt work  
 observe({
if (input$stats == "PartyAb") {
  pal <- colorFactor(c("LNP"="#021893","ALP" = "#C12525","IND" = "grey", "KAP" = "#33165F",
                         "PUA"="orange", "ON"="orange", "GRN"="#339966", "LNQ"="#0066FF",
                         "LP"="#0033CC", "NP"="#009999", "Electorate not established in 2007"="black", "Electorate not established in 2004"="black"), domain= qld.stats[[input$stats]])
} else {
  pal <- colorNumeric(c("red", "green"), domain = qld.stats[[input$stats]], reverse = FALSE)
}
  # the second part of the colour palette above is related to the fact that I have other options from the dropdown menu that display numeric stats like unemployment and participation rate

#this colour palette works but it is a total fluke and won't work for 
    this years data as there are green and yellow colours required so I need something like this but that uses the party_cols colour palette

colorpal <- reactive({
colorFactor(colorRamp(c("red", "blue")), domain = qld.stats[[input$stats]], reverse = FALSE) 


   })

    #create the base map that will be displayed regardless of selected input

output$map<-renderLeaflet({
    leaflet(qld.stats) %>%
  addProviderTiles(providers$OpenStreetMap.BlackAndWhite) %>% #(providers$OpenStreetMap.BlackAndWhite)%>% 
  # Centre the map in the middle of our co-ordinates
  fitBounds(min(137.99),max(-29.18),min(153.55),max(-9.12))

  }) 


 leafletProxy("map", data = qld.stats) %>%
  clearShapes() %>%
  addPolygons(
    layerId = qld.stats$Elect_div,
    fillColor = ~pal(qld.stats[[input$stats]]),
    fillOpacity = 0.4,
    weight = 0.6,
    opacity = 1,
    color = "#444444",
    dashArray = "5",
    label = labels,
    highlight = highlightOptions(
      weight = 4,
      color = "#FFFFFF",
      dashArray = "",
      fillOpacity = 0.9,
      bringToFront = TRUE),
    labelOptions = labelOptions(
      style = list("font-weight" = "normal", padding = "3px 5px"),
      textsize = "13px",
      direction = "auto")
  )
#we are adding a legend to display the raw data that aligns with the spatially depicted stat from the stats drop-down
#this information is also displayed in the pop-ups for each clickable electorate
varname<-switch(input$stats,
                "PartyAb"="Sitting Party",                                                                                                                                                                                             "Electorate Population"="CED_pop_total",
  'CED_participation_rate_2018'="Work-force participation rate %",
  'Unemployment_rate_2018'="Unemployment rate %")


 leafletProxy("map", data = qld.stats) %>% clearControls() %>%
  addLegend(pal = pal, opacity = 0.9,  title = varname,
            values = ~qld.stats[[input$stats]],labels = c(min(input$stats), max(input$stats)),
            position = "topleft")
   })

 #we want to create a reactivity so users can either select the division 
  #from the drop down menu or by clicking on the map

      observe({
     event <- input$map_shape_click
    if (is.null(event))
     return()
     updateSelectInput(session, "division", selected = event$id)
         })
         #we want to create reactivity so that the map to zooms in on and focus on the selected electorate
   observe({
   selectedPolygon <- subset(qld.stats, qld.stats$Elect_div == input$division)
   leafletProxy("map", data = qld.stats) %>%
    removeShape("highlightedPolygon") %>%
     fitBounds(selectedPolygon@bbox[1,1],
            selectedPolygon@bbox[2,1],
            selectedPolygon@bbox[1,2],
            selectedPolygon@bbox[2,2]) %>%
     addPolylines(weight = 4, color = "white",
               data = selectedPolygon, layerId = "highlightedPolygon")
    })


}


shinyApp(ui, server)

Answer 1

因此，我想出了一个解决方法来解决我遇到的问题，即需要一个预定义的配色方案(政党颜色)来根据用户从下拉菜单输入的内容来填充传单地图上的多边形。

我的解决方案并不完全是我想要的，但它肯定是有效的，我对它很满意。

#we need to set up 3 separate colour schemes for the different options from the spatial stats drop down menu
#one for current party using factor levels to match the party colours
#one for the previous election results using same rationale
#one for the numeric based stats for unemployment rate and participation rate

  observe({
if (input$stats == "PartyNm") {
  pal <- colorFactor(c("#C12525","#6600CC","#021893"), domain= qld.stats[[input$stats]])
} else if (input$stats == "Elected_Party_2013") {
  pal <- colorFactor(c("#C12525","##6600CC","#021893", "yellow"), domain= qld.stats[[input$stats]])
} else {
  pal <- colorNumeric(c("#C12525", "#33ffff"), domain = qld.stats[[input$stats]], reverse = FALSE)
}

 #creating a proxy map that displays the various stats from the stats drp down 
leafletProxy("map", data = qld.stats) %>%
  clearShapes() %>%
  addPolygons(
    layerId = qld.stats$Elect_div,
    fillColor = ~pal(qld.stats[[input$stats]]),
    fillOpacity = 0.6,
    weight = 0.6,
    opacity = 1,
    color = "#444444",
    dashArray = "5",
    label = labels,
    highlight = highlightOptions(
      weight = 4,
      color = "#FFFFFF",
      dashArray = "",
      fillOpacity = 0.9,
      bringToFront = TRUE),
    labelOptions = labelOptions(
      style = list("font-weight" = "normal", padding = "3px 5px"),
      textsize = "13px",
      direction = "auto")
  )