0

I'm trying to produce a Shiny app with Leaflet that renders a choropleth map based on different input criteria. The map displays incidents of different types (input$type) and backgrounds (input$background). When additional types or backgrounds are specified, polygons are filled with updated incident data. It is working correctly with one snag. When I switch the date input from date range (input$dateInput) to presidential period (input$president), the choropleth for presidential period renders once, displaying polygons with no data, and then again with the polygons filled with the correct data for the pre-selected period ("President1"). How do I avoid the map rendering twice like this when the Presidency tab is pressed?

Question also listed here on RStudio Community.

The raw data and shapefile used can be accessed here: https://github.com/cjbarrie/shiny_egy.

Working example:

Name of raw data: wikiraw

Name of shapefile: shapefile

Global:

library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)

wikiraw <-read.csv("~/wikisample_SO.csv")
shapefile <- readOGR("~/EGY_adm2.shp")
shapefile<-spTransform(shapefile, CRS("+init=epsg:4326"))
## Simplify shapefile to speed up rendering
shapefile <- ms_simplify(shapefile, keep = 0.01, keep_shapes = TRUE)
wikbounds<-bbox(shapefile)
wikiraw$incident_date <- as.Date(wikiraw$incident_date,
                                 format = "%m/%d/%Y")
wikiraw$presidency <- rep(NA, nrow(wikiraw))
wikiraw$incident_date1 <- as.numeric(wikiraw$incident_date)
wikiraw$event <- rep(1,nrow(wikiraw))
## Generate presidency categorical var.
wikiraw$presidency <- cut(wikiraw$incident_date1, 
                          breaks = c(-Inf, 15016, 15521, 15889, 16229, Inf), 
                          labels = c("President1", "President2", "President3", "President4", "President5"), 
                          right = FALSE)

Snippet of data.frame wikiraw:

  ID_2 incident_date incident_background incident_type presidency event
1  168    2013-11-26            Cultural         Group President4     1
2  133    2013-11-29            Cultural         Group President4     1
3  137    2014-01-25            Cultural         Group President4     1
4  168    2011-01-28            Cultural    Collective President1     1
5  168    2016-04-25            Cultural         Group President5     1
6  163    2015-02-08           Political    Individual President5     1

UI:

ui <- dashboardPage(
                    dashboardHeader(title = "Map tool"),
                    dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
                                                 selectInput("input_type", "Date input type",
                                                             c("Date", "Presidency")),
                                                 uiOutput("dateSelect"),
                                                 uiOutput("typeSelect"),
                                                 uiOutput("backgroundSelect"),
                                                 uiOutput("presidentSelect"))),
                    dashboardBody(tabItems(
                      tabItem(tabName = "map",
                              leafletOutput("mymap", height=500)))))

Server:

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

  output$dateSelect <- renderUI({
    switch(input$input_type,
           "Date" = dateRangeInput("dateInput", "Dates:",
                                   min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
                                   start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
           "Presidency" = checkboxGroupInput("president", "Presidency", 
                                             choices = levels(wikiraw$presidency),
                                             selected = "President1"))
  })

  output$typeSelect <- renderUI({
    selectInput("type", "Incident type", 
                choices = unique(wikiraw$incident_type), multiple = TRUE, 
                selected = wikiraw$incident_type[1])})

  output$backgroundSelect <- renderUI({
    checkboxGroupInput("background", "Incident background", 
                       choices = unique(wikiraw$incident_background),
                       selected = wikiraw$incident_background[1])})


  selected <- reactive({
    wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
      summarize(sum_event = sum(event))
    if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
                                                   incident_date >= min(input$dateInput),
                                                   incident_date <= max(input$dateInput),
                                                   incident_type%in%input$type,
                                                   incident_background%in%input$background)}
    if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
                                                         incident_type%in%input$type,
                                                         incident_background%in%input$background,
                                                         presidency%in%input$president)}

    wikiagg <- wikiagg %>% group_by(ID_2) %>%
      summarize(sum_event = sum(sum_event))
    wikiagg
  })

  output$mymap <- renderLeaflet({

    leaflet() %>% 
      addTiles() %>% 
      setView(mean(wikbounds[1,]),
              mean(wikbounds[2,]),
              zoom=6
      )
  })

  observe({
    if(!is.null(input$dateInput)){
      shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")

      ##Define palette across range of data
      wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
        summarize(sum_event = sum(event))
      pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")


      leafletProxy("mymap", data = shapefile) %>%
        addTiles() %>% 
        clearShapes() %>% 
        addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 0.7, 
                    color = "white", weight = 2)
    }})
}
shinyApp(ui, server)

Gif of issue:

https://imgur.com/a/FnfOGKi

Any help would be hugely appreciated!

14
  • 1
    You should provide a reproducible example. Otherwise, we can't run your code.
    – MLavoie
    Apr 26, 2018 at 10:37
  • Thank you for taking the time to look at this. I have edited original post, adding link to github repo containing raw data and shapefile used.
    – cjb
    Apr 26, 2018 at 11:05
  • I can't load you shapefile...I think we also need the other files with the .shp file
    – MLavoie
    Apr 26, 2018 at 11:22
  • Github repo updated with supplementary shapefiles. Thanks again!
    – cjb
    Apr 26, 2018 at 11:29
  • That's odd--I don't get any such error. Also I just checked and ID_2 is integer class in both the shapefile and wikiraw. My sessionInfo if helpful: > sessionInfo() R version 3.4.3 (2017-11-30) Platform: x86_64-apple-darwin15.6.0 (64-bit) Running under: macOS High Sierra 10.13.3
    – cjb
    Apr 26, 2018 at 11:42

1 Answer 1

2

What if you change the reactive to a reactiveValue and assign the data in an observe? I don't know if it is working correctly as I dont know which shapes & colors to expect, but I am not seeing that double rendering anymore.

(Data & Preparation from question is used)

library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(rgdal)
library(rmapshaper)
library(sp)
library(dplyr)
library(lubridate)

ui <- dashboardPage(
  dashboardHeader(title = "Map tool"),
  dashboardSidebar(sidebarMenu(menuItem("Map", tabName = "map"),
                               selectInput("input_type", "Date input type",
                                           c("Date", "Presidency")),
                               uiOutput("dateSelect"),
                               uiOutput("typeSelect"),
                               uiOutput("backgroundSelect"),
                               uiOutput("presidentSelect"))),
  dashboardBody(tabItems(
    tabItem(tabName = "map",
            leafletOutput("mymap", height=500)))))



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

  output$dateSelect <- renderUI({
    switch(input$input_type,
           "Date" = dateRangeInput("dateInput", "Dates:",
                                   min=min(wikiraw$incident_date), max = max(wikiraw$incident_date),
                                   start = min(wikiraw$incident_date), end = max(wikiraw$incident_date)),
           "Presidency" = checkboxGroupInput("president", "Presidency", 
                                             choices = levels(wikiraw$presidency),
                                             selected = "President1"))
  })

  output$typeSelect <- renderUI({
    selectInput("type", "Incident type", 
                choices = unique(wikiraw$incident_type), multiple = TRUE, 
                selected = wikiraw$incident_type[1])})

  output$backgroundSelect <- renderUI({
    checkboxGroupInput("background", "Incident background", 
                       choices = unique(wikiraw$incident_background),
                       selected = wikiraw$incident_background[1])})

  sel_reactval = reactiveValues(s = NULL)

  # selected <- reactive({
  observe({
    wikiagg <- wikiraw %>% group_by(ID_2, incident_date, incident_type, incident_background, presidency) %>%
      summarize(sum_event = sum(event))

    if(input$input_type=="Date"){wikiagg <- filter(wikiagg,
                                                   incident_date >= min(input$dateInput),
                                                   incident_date <= max(input$dateInput),
                                                   incident_type%in%input$type,
                                                   incident_background%in%input$background)}
    if(input$input_type=="Presidency"){wikiagg <- filter(wikiagg,
                                                         incident_type%in%input$type,
                                                         incident_background%in%input$background,
                                                         presidency%in%input$president)}

    wikiagg <- wikiagg %>% group_by(ID_2) %>%
      summarize(sum_event = sum(sum_event))

    sel_reactval$s = wikiagg
    # wikiagg
  })

  output$mymap <- renderLeaflet({

    leaflet() %>% 
      addTiles() %>% 
      setView(mean(wikbounds[1,]),
              mean(wikbounds[2,]),
              zoom=6
      )
  })

  observe({

    req(!is.null(input$dateInput))
    req(nrow(as.data.frame(sel_reactval$s))!=0)

    # if(!is.null(input$dateInput)){
      # shapefile@data <- left_join(shapefile@data, selected(), by="ID_2")
      shapefile@data <- left_join(shapefile@data, sel_reactval$s, by="ID_2")

      ##Define palette across range of data
      wikiaggpal <- wikiraw %>% group_by(ID_2) %>%
        summarize(sum_event = sum(event))
      pal <- colorBin("YlOrRd", wikiaggpal$sum_event, bins=5, na.color = "#bdbdbd")


      leafletProxy("mymap") %>%
        addTiles() %>%
        clearShapes() %>%
        addPolygons(data = shapefile, fillColor = ~pal(sum_event), fillOpacity = 1, 
                    color = "white", weight = 2)
    # }
    })
}
shinyApp(ui, server)
1
  • 1
    I think this has fixed it! I'll need to play around with it a bit more to make sure but it seems to be rendering correctly now. Thanks so much (and apologies for only just getting round to looking at this). I shall be raising a glass to you this evening!
    – cjb
    Jun 29, 2018 at 10:33

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.