renderLeaflet: значения легенды не обновляются - PullRequest
Новая
       16

renderLeaflet: значения легенды не обновляются

0 голосов
/ 04 ноября 2018

У меня есть следующие R коды в блестящей основе. Все выглядит хорошо, но легенда ( Пожалуйста, смотрите этот скриншот ). Я хочу, чтобы легенда обновлялась на основе выбора пользователей по возрастной группе (60+, 65+, 85+), полу или году. Но это не так. То есть значения легенды остаются неизменными, независимо от того, что выбрано в левом меню ( Пожалуйста, смотрите этот скриншот ). Это делает карту бесполезной, если выбран 85+. Ниже приведены все мои коды.
Я ценю вашу помощь. Надер 

load("/Users/nadermehri/Desktop/map codes/nhmap.RData")

library(shiny)
library(leaflet)

ui <- fluidPage(
tabPanel(
  "Interactive Maps",

  tags$h5 (
  )),
  br(),

  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "Age_Group_map",
        label = "Select the Age Group:",
        selected = "60+",
        selectize = F,
        multiple = F,
        choices = sort(unique(nhmap$Age_Group))
      ),


      radioButtons(
        inputId = "sex_map",
        label = strong("Select Sex:"),
        selected = "Both Sexes",
        choices = sort(unique(nhmap$Sex))
      ),

      sliderInput(
        inputId = "Year_map",
        label = "Year",
        min = 2010,
        max = 2050,
        value = 2010,
        step = 10,
        sep = "",
        pre = "",
        animate = animationOptions(
          interval = 1000,
          loop = F,
          playButton = tags$button("Play", style =
                                     "background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
          pauseButton = tags$button("Pause", style =
                                      "background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
        ),
        round = T,
        width = "150%",
        ticks = T
      )),

mainPanel("Interactive", leafletOutput("int_map", height=500))))

server <- function(input, output) {


    mapdata_ <- reactive ({

      nhmap$Per <- round(nhmap$Per, 1) 

      out_map <- nhmap %>%
        filter (
          Age_Group %in% input$Age_Group_map,
          Sex %in% input$sex_map,
          Year %in% input$Year_map)


      return(out_map)
    })


    output$int_map <- renderLeaflet ({


      leaflet (mapdata_(),

               pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837") ,
               pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per), na.color = "#808080",  alpha = FALSE, reverse = F)) %>%



        addProviderTiles("CartoDB.Positron") %>% 
        clearControls() %>%
        clearShapes()%>%
        addPolygons(fillColor = ~pal(Per),
                    stroke=T,
                    weight=1,
                    smoothFactor=0.2,
                    fillOpacity = 1,
                    color="black",
                    popup=~paste(NAME,"<br>",input$sex_map,
                                 input$Age_Group_map,"=",Per,"%"),
                    highlightOptions = highlightOptions(color = "red",
                                                        weight = T,
                                                        bringToFront = T),

                    label=~NAME) %>%


        addTiles() %>%

        setView(-82.706838, 40.358615, zoom=7) %>%

        addLegend(position = "bottomright",
                  values = ~Per,
                  pal = pal,
                  title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
                  labFormat = labelFormat(
                  ))

    })
}

shinyApp(ui = ui, server = server)

Ответы [ 2 ]

0 голосов
/ 06 ноября 2018

Вот ответ. Как я уже упоминал в моем последнем комментарии, приятель должен реагировать: 

mapdata_ <- reactive ({



 nhmap$Per <- round(nhmap$Per, 1) 

 out_map <- nhmap %>%
   filter (
     Age_Group %in% input$Age_Group_map,
      Sex %in% input$sex_map,
     Year %in% input$Year_map)

 return(out_map)
 list(Per)



})

  mapdata_1 <- reactive ({



nhmap$Per <- round(nhmap$Per, 1) 

out_map_1 <- nhmap %>%
  filter (
    Age_Group %in% input$Age_Group_map
    )

return(out_map_1)
list(Per)



})



  output$int_map <- renderLeaflet ({

pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837") 
pal <- colorBin(palette = pal8, domain =NULL, bins=quantile(mapdata_1()$Per), na.color = "#808080",  alpha = FALSE, reverse = F)

 leaflet (mapdata_()) %>% 
                    addProviderTiles("CartoDB.Positron") %>% 
                 clearControls() %>%
                 clearShapes()%>%
                    addPolygons(fillColor = ~pal(Per),
                               stroke=T,
                               weight=1,
                               smoothFactor=0.2,
                               fillOpacity = 1,
                               color="black",
                               popup=~paste(NAME,"<br>",input$sex_map,
                                            input$Age_Group_map,"=",Per,"%"),
                                highlightOptions = highlightOptions(color = "red",
                                                                    weight = T,
                                                                    bringToFront = T),

                               label=~NAME) %>%


                               addTiles() %>%

  setView(-82.706838, 40.358615, zoom=7) %>%

                    addLegend(position = "bottomright",
                     values = ~Per,
                     pal = pal,
                     title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
                   labFormat = labelFormat(
                  ))

    })
0 голосов
/ 06 ноября 2018

Вы должны определить ячейки в colorBin, для которых вы хотите вырезать данные в различных цветовых сечениях. Что-то вроде: 

pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
                na.color = "#808080",  alpha = FALSE, reverse = F)

И вы также должны удалить bins= 4 из вызова addLegend, так как он будет получать информацию из цветовой палитры.

Я создал несколько случайных данных для nhmap, и он работает для меня с этим кодом: 

library(shiny)
library(leaflet)
library(sf)
library(sp)

## Random Data #############
data(meuse, package = "sp")
nhmap <- st_as_sf(meuse, coords = c("x", "y"))
st_crs(nhmap) <- "+init=epsg:28992"
nhmap <- st_buffer(nhmap, 100)

n = length(nhmap$cadmium)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Sex <- sample(c("m","f"), size = n, T)
nhmap$Per <- runif(n, 1, 150)
nhmap$NAME <- sample(c("a","b","c"), size = n, T)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Year <- sample(c(2010,2020,2030, 2040, 2050), size = n, T)
nhmap <- st_transform(nhmap, 4326)


## UI ###########
ui <- {fluidPage(
  tabPanel(
    "Interactive Maps",
    tags$h5 ()),
  br(),

  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "Age_Group_map",
        label = "Select the Age Group:",
        # selected = "60+",
        selectize = F,
        multiple = F,
        choices = sort(unique(nhmap$Age_Group))
      ),


      radioButtons(
        inputId = "sex_map",
        label = strong("Select Sex:"),
        # selected = "Both Sexes",
        choices = sort(unique(nhmap$Sex))
      ),

      sliderInput(
        inputId = "Year_map",
        label = "Year",
        min = 2010,
        max = 2050,
        value = 2010,
        step = 10,
        sep = "",
        pre = "",
        animate = animationOptions(
          interval = 1000,
          loop = F,
          playButton = tags$button("Play", style =
                                     "background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
          pauseButton = tags$button("Pause", style =
                                      "background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
        ),
        round = T,
        width = "150%",
        ticks = T
      )),

    mainPanel("Interactive", leafletOutput("int_map", height=500)))
)}

## SERVER ###########
server <- function(input, output) {

  mapdata_ <- reactive ({
    nhmap$Per <- round(nhmap$Per, 1)
    # nhmap
    nhmap %>%
      filter (
        Age_Group %in% input$Age_Group_map,
        Sex %in% input$sex_map,
        Year %in% input$Year_map)
  })

  output$int_map <- renderLeaflet ({
    req(mapdata_())
    pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
    # pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per), 
    pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per), 
                    na.color = "#808080",  alpha = FALSE, reverse = F)


    leaflet(data = mapdata_()) %>%
      # leaflet(data = nhmap) %>% 
      clearControls() %>%
      clearShapes()%>%
      addProviderTiles("CartoDB.Positron") %>% 
      addTiles() %>%
      addPolygons(fillColor = ~pal(Per),
                  stroke=T,
                  weight=1,
                  smoothFactor=0.2,
                  fillOpacity = 1,
                  color="black",
                  label=~NAME,
                  popup=~paste(NAME,"<br>",input$sex_map,
                               input$Age_Group_map,"=",Per,"%"),
                  highlightOptions = highlightOptions(color = "red",
                                                      weight = T,
                                                      bringToFront = T)) %>%

      # setView(-82.706838, 40.358615, zoom=7) %>%

      addLegend(position = "bottomright",
                values = ~Per,
                title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)),
                pal = pal
      )
  })
}

shinyApp(ui = ui, server = server)
...