Карта Shiny Leaflet отрисовывается дважды при переключении входа - PullRequest
Новая
       18

Карта Shiny Leaflet отрисовывается дважды при переключении входа

0 голосов
/ 25 апреля 2018

Я пытаюсь создать приложение Shiny с Leaflet, которое отображает карту хороплета на основе различных критериев ввода.На карте отображаются инциденты разных типов (input$type) и фонов (input$background).Если указаны дополнительные типы или фоны, полигоны заполняются обновленными данными об инцидентах.Он работает правильно с одним препятствием.Когда я переключаю ввод даты с диапазона дат (input$dateInput) на президентский период (input$president), однократное отображение для президентского периода отображается один раз, отображая многоугольники без данных, а затем снова с многоугольниками, заполненными правильными данными дляпредварительно выбранный период («Президент1»).Как избежать двойного рендеринга карты при нажатии на вкладку «Президентство»?

Также указан вопрос здесь в RStudio Community.

Использовать необработанные данные и шейп-файл можнобыть доступным здесь: https://github.com/cjbarrie/shiny_egy.

Рабочий пример:

Имя необработанных данных: wikiraw

Имя шейп-файла: 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)

Фрагмент 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 <- 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 вопроса:

https://imgur.com/a/FnfOGKi

Любая помощь будет принята с благодарностью!

1 Ответ

0 голосов
/ 24 июня 2018

Что если вы измените reactive на reactiveValue и назначите данные в observe? Я не знаю, работает ли он правильно, поскольку я не знаю, какие формы и цвета ожидать, но я больше не вижу этого двойного рендеринга.

( Используются данные и подготовка к вопросу ) 

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)
...