AddLegend based on reactive values in r leaflet

I want to be able to addlegend feature on my interactive map app based on user input such that when he selects a range of input the color mapping changes based on the conditions selected.You can interact with the apphere specifically with the interactive mapping tab.I want to be able to apply the concept from the color mapping tab. Here is a snip of the code:

ui<-fluidPage(
 tabItem(
        tabName = "map2",
        h3("INTERACTIVE MAP"),
        fluidPage(

          title = "MAP DISPLAY",status = "primary",solidHeader = TRUE,
          leafletOutput("leaf2",height = 500),





          #h2("USER EXPLORER",style="color:#3474A7"),
          fluidRow(
            column(6,
                   #slider input for population per km2  
                   sliderInput(inputId = "pop2",
                               label = "Population Per km2:",
                               min = min(mp@data$PpDnsty,na.rm =T),
                               max = max(mp@data$PpDnsty,na.rm =T),
                               value = c(min(mp@data$PpDnsty,na.rm =T),
                                         max(mp@data$PpDnsty,na.rm =T))
                   ),
                   #slider input for piped water on plot  
                   sliderInput(inputId = "pw2",
                               label = "Piped Water On Plot:",
                               min = min(mp@data$PpdWtrP,na.rm =T),
                               max = max(mp@data$PpdWtrP,na.rm =T),
                               value = c(min(mp@data$PpdWtrP,na.rm =T),
                                         max(mp@data$PpdWtrP,na.rm =T))
                   )),
            column(6,
                   #slider input for water source on plot  
                   sliderInput(inputId = "ws",
                               label = "Water Source On Plot:",
                               min = min(mp@data$WtrSrOP,na.rm =T),
                               max = max(mp@data$WtrSrOP,na.rm =T),
                               value = c(min(mp@data$WtrSrOP,na.rm =T),
                                         max(mp@data$WtrSrOP,na.rm =T))
                   ),

                   #slider input for flush toilets  
                   sliderInput(inputId = "ft",
                               label = "Flush Toilets:",
                               min = min(mp@data$FlshTlt,na.rm =T),
                               max = max(mp@data$FlshTlt,na.rm =T),
                               value = c(min(mp@data$FlshTlt,na.rm =T),
                                         max(mp@data$FlshTlt,na.rm =T))
                   ))),
          fluidRow(
            column(6,

                   #slider input for Other Improved
                   sliderInput(inputId = "om",
                               label = "Other Improved:",
                               min = min(mp@data$OthrImp,na.rm =T),
                               max = max(mp@data$OthrImp,na.rm =T),
                               value = c(min(mp@data$OthrImp,na.rm =T),
                                         max(mp@data$OthrImp,na.rm =T))
                   ),

                   #slider input for unimproved
                   sliderInput(inputId = "um",
                               label = "Unimproved:",
                               min = min(mp@data$Unmprvd,na.rm =T),
                               max = max(mp@data$Unmprvd,na.rm =T),
                               value = c(min(mp@data$Unmprvd,na.rm =T),
                                         max(mp@data$Unmprvd,na.rm =T))
                   )
            ),
            column(6,

                   #slider input for open defecation
                   sliderInput(inputId = "od",
                               label = "Open Defecation:",
                               min = min(mp@data$OpnDfct,na.rm =T),
                               max = max(mp@data$OpnDfct,na.rm =T),
                               value = c(min(mp@data$OpnDfct,na.rm =T),
                                         max(mp@data$OpnDfct,na.rm =T))
                   ),

                   #slider input for elevation
                   sliderInput(inputId = "el",
                               label = "Elevation:",
                               min = min(mp@data$elevation,na.rm =T),
                               max = max(mp@data$elevation,na.rm =T),
                               value = c(min(mp@data$elevation,na.rm =T),
                                         max(mp@data$elevation,na.rm =T))
                   )
            )

          )









        )
        )


      )

server<-function(input,output){

#sliderinput reactive function for all numeric input options
  sld<-reactive({
    subset(mp,mp@data$PpDnsty>=input$pop2[1]&
             mp@data$PpDnsty<=input$pop2[2]&
             mp@data$PpdWtrP>=input$pw2[1]&
             mp@data$PpdWtrP<=input$pw2[2]&
             mp@data$WtrSrOP>=input$ws[1]&
             mp@data$WtrSrOP<=input$ws[2]& 
             mp@data$FlshTlt>=input$ft[1]&
             mp@data$FlshTlt<=input$ft[2]&
             mp@data$OthrImp>=input$om[1]&
             mp@data$OthrImp<=input$om[2]&
             mp@data$Unmprvd>=input$um[1]&
             mp@data$Unmprvd<=input$um[2]&
             mp@data$OpnDfct>=input$od[1]&
             mp@data$OpnDfct<=input$od[2]&
             mp@data$elevation>=input$el[1]&
             mp@data$elevation<=input$el[2]

    )

  })
#Base map(default)

  output$leaf2<-renderLeaflet({



    leaflet(mp) %>%

      #Initializing the map
      # setView(lng=36.092245, lat=-00.292115,zoom=15)%>%

      #default map
      #Add default OpenStreetMap map tiles
      addTiles()%>%

      # addProviderTiles("Esri.NatGeoWorldMap",group = "default")%>%  
      #addProviderTiles("CartoDB.Positron",group = "custom")%>%

      #nakuru lias polygons
      addPolygons(
        data = mp,
        fillColor = "blue",
        weight = 1, smoothFactor = 0.5,
        opacity = 1.0, fillOpacity = 1.0,
        highlightOptions = highlightOptions(
          weight = 2,
          color = "red",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label =~LIA,
        popup = ~paste("<strong>Area Type:</strong>",AreaTyp,
                       "<br>",
                       "<strong>Piped Water On Plot:</strong>",PpdWtrP,"%",
                       "<br>",
                       "<strong>Water Source On Plot:</strong>",WtrSrOP,"%",
                       "<br>",
                       "<strong>Flash Toilets:</strong>",FlshTlt,"%",
                       "<br>",
                       "<strong>Other Improved:</strong>",OthrImp,"%",
                       "<br>",
                       "<strong>Unimproved:</strong>",Unmprvd,"%",
                       "<br>",
                       "<strong>Open Defecation:</strong>",OpnDfct,"%",
                       "<br>",
                       "<strong>Population Per km2:</strong>",PpDnsty,
                       "<br>",
                       "<strong>Elevation:</strong>",elevation,"m"
        )

      ) 




  })
#observe function for slider input numeric options
  observe({

    #color mapping function
    #pal1<-colorNumeric(palette = "magma",mp$PpDnsty)
    #pal1 <- colorBin("plasma",lias$PpDnsty, 15, pretty = TRUE)
    #pal1<- colorBin("Blues", lias$PpDnsty, 2, pretty = FALSE)


    leafletProxy("leaf2",data=sld()) %>%

      #Initializing the map
      #setView(lng=36.092245    , lat=-00.292115,zoom=10)%>%
      # clearMarkers() %>%
      clearControls() %>%
      clearShapes()%>%
      addPolygons(
        weight = 1, smoothFactor = 0.5,
        opacity = 1.0, fillOpacity = 1.0,
        highlightOptions = highlightOptions(
          weight = 2,
          color = "red",
          fillOpacity = 0.7,
          bringToFront = TRUE
        ),
        label =~LIA,
        popup = ~paste("<strong>Area Type:</strong>",AreaTyp,
                       "<br>",
                       "<strong>Piped Water On Plot:</strong>",PpdWtrP,"%",
                       "<br>",
                       "<strong>WaterSource On Plot:</strong>",WtrSrOP,"%",
                       "<br>",
                       "<strong>Flash Toilets:</strong>",FlshTlt,"%",
                       "<br>",
                       "<strong>Other Improved:</strong>",OthrImp,"%",
                       "<br>",
                       "<strong>Unimproved:</strong>",Unmprvd,"%",
                       "<br>",
                       "<strong>Open Defecation:</strong>",OpnDfct,"%",
                       "<br>",
                       "<strong>Population Per km2:</strong>",PpDnsty,
                       "<br>",
                       "<strong>Elevation:</strong>",elevation,"m"

        )

      )
  })

}

shinyApp(ui,server)

In case you're not familiar, you can use Leaflet's color functions to map values to colors and apply them to choropleths. https://rstudio.github.io/leaflet/colors.html The legends are designed to work with these color functions. https://rstudio.github.io/leaflet/legends.html

You just need to make sure that you invoke the color function (which creates the palette object, which you then pass values to and get colors returned) inside of your renderLeaflet or observeEvent (in this case the latter).

Another note is that there should be no need to call addPolygons inside of renderPlot if you're doing that same exact code in the observer right below. The latter is going to happen anyway, so the former is wasted code and work.

Hope that helps...

4 Likes