Блестящая карта - sliderInput, которая отображает только выбранные пользователем из pickerInput - PullRequest
Новая
       48

Блестящая карта - sliderInput, которая отображает только выбранные пользователем из pickerInput

2 голосов
/ 07 октября 2019

Обновление2 Ответ, предоставленный Беном, решил проблему - Спасибо!

Обновление: Благодаря предложенному ниже предложению Бена решение состоит в том, чтобы объединить фильтрацию данныхгод и вид. Это вызвало новую проблему, однако. Теперь, когда вид выбран, а ползунок года помещен в диапазон, в котором нет записей для вида, приложение вылетает.

Так что теперь я ищу условный оператор, который позволяет приложению продолжать работу, но не отображает точек, если в данном диапазоне нет записей видов (диапазон ввода ползунка).

Обновлен код для отражения решения Бена 

library(shiny)
library(leaflet)
library(leaflet.providers)
library(RColorBrewer)
library(shinyWidgets)
library(dplyr)

binomial = c("Mya arenaria", "Laternula gracilis", "Carcinus maenas", "Polydora cornuta", "Sphaeroma quoianum", "Mya arenaria", 
             "Monocorophium acherusicum", "Barentsia benedeni","Monocorophium insidiosum","Sargassum muticum")
year = c(1999, 2000, 1995, 1975, 2002, 2002, 1965, 2018, 2018, 1999)
latitude = c(40.64150, 40.69515, 40.72200, 40.72000, 41.76798, 40.74250, 40.72325, 40.69515, 40.72937, 40.73250)
longitude = c(-124.3123, -124.2494, -124.2362, -124.2269, -124.2269, -124.2218, -124.2199, -124.2198, -124.2095, -124.2083)
misp = data.frame(binomial,year,latitude,longitude)
misp$binomial = as.character(misp$binomial)
color = grDevices::colors()[grep('gr(a|e)y', grDevices::colors(), invert = T)]
pal <- colorFactor(
  palette = color,
  domain = misp$binomial)


ui <- bootstrapPage(
            tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
                    leafletOutput("map", width = "100%", height = "100%"),

                    absolutePanel(top = 10, right = 10,
                      sliderInput("range","Year", min(misp$year),max(misp$year),
                                  value = range(misp$year), step=1, sep = ""),
                      pickerInput("select","Species", choices = unique(sort(misp$binomial)), options = list(`actions-box` = TRUE),
                                  multiple = T, selected = unique(sort(misp$binomial)))

  )
)

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

  filteredData <- reactive({
     misp[misp$year >= input$range[1] & misp$year <= input$range[2] & misp$binomial %in% input$select,]})

  filteredDataYr <- reactive({
    misp[misp$year >= input$range[1] & misp$year <= input$range[2],]})

  output$map <- renderLeaflet({
    leaflet(misp) %>% addProviderTiles(providers$CartoDB.Positron) %>%
      fitBounds(min(misp$longitude), min(misp$latitude), max(misp$longitude), max(misp$latitude))})

  observeEvent(input$range,{
    updatePickerInput(session=session, inputId="select", choices = unique(sort(filteredDataYr()$binomial)), selected = filteredData()$binomial)
        leafletProxy("map", data = filteredData()) %>%
          clearMarkers() %>%
          addCircleMarkers(popup = ~as.character(binomial),
                       label = ~as.character(binomial), radius = 5,
                       stroke = FALSE, fillOpacity = 2, color = ~pal(binomial))
 })

  observe(
    if (nrow(filteredData()) == 0) {leafletProxy("map") %>% clearMarkers()}
    else
      leafletProxy("map", data = filteredData()) %>%
      clearMarkers() %>%
      addCircleMarkers(popup = ~as.character(binomial),
                       label = ~as.character(binomial), radius = 5,
                       stroke = FALSE, fillOpacity = 2,color = ~pal(binomial))

   )
}

shinyApp(ui, server)

Я создаю блестящее приложение, которое отображает точки широты и долготы для списка видов. Один sliderInput позволяет пользователю сузить набор данных по годам, а один pickerInput позволяет пользователю выбирать только определенные виды. По умолчанию для pickerInput не выбрано ничего - если вы выберете все и переместите ползунок года, на карте отобразятся все виды в пределах диапазона года из sliderInput.

Проблема: В настоящее время приложение не позволяет пользователю прокручивать годы только для того, что выбрано в pickerInput (разновидности). Я хочу иметь возможность выбрать количество видов из pickerInput, используйте sliderInput, чтобы просмотреть записи моего выбора по годам. В настоящее время, когда выбор делается в pickerInput, а sliderInput перемещается, точки по умолчанию возвращаются к отображению всех записей вместо только того, что выбрано.

Чтобы просмотреть проблему, запустите код и настройте ползунок для отображения только самого старого года. Это даст один доступный вид для выбора на входе сборщика. Выберите этот вид и затем переместите ползунок, чтобы отобразить больший диапазон лет. Точки начнут появляться от видов, отличных от выбранного.

Код, включая набор фиктивных данных: 

library(shiny)
library(leaflet)
library(leaflet.providers)
library(RColorBrewer)
library(shinyWidgets)
library(dplyr)

binomial = c("Mya arenaria", "Laternula gracilis", "Carcinus maenas", "Polydora cornuta", "Sphaeroma quoianum", "Mya arenaria", 
             "Monocorophium acherusicum", "Barentsia benedeni","Monocorophium insidiosum","Sargassum muticum")
year = c(1999, 2000, 1995, 1975, 2002, 2002, 1965, 2018, 2018, 1999)
latitude = c(40.64150, 40.69515, 40.72200, 40.72000, 41.76798, 40.74250, 40.72325, 40.69515, 40.72937, 40.73250)
longitude = c(-124.3123, -124.2494, -124.2362, -124.2269, -124.2269, -124.2218, -124.2199, -124.2198, -124.2095, -124.2083)
misp = data.frame(binomial,year,latitude,longitude)
misp$binomial = as.character(misp$binomial)

color = grDevices::colors()[grep('gr(a|e)y', grDevices::colors(), invert = T)]
pal <- colorFactor(
  palette = color,
  domain = misp$binomial)


ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
  leafletOutput("map", width = "100%", height = "100%"),

  absolutePanel(top = 10, right = 10,
                sliderInput("range","Year", min(misp$year),max(misp$year),
                            value = range(misp$year), step=1, sep = ""),
                pickerInput("select","Species", choices = unique(sort(misp$binomial)), options = list(`actions-box` = TRUE),
                            multiple = T, selected = NULL)
  )
)

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

  filteredData <- reactive({
    misp[misp$year >= input$range[1] & misp$year <= input$range[2],]})

  filteredData2 <- reactive({
    misp[misp$binomial %in% input$select,]})

  output$map <- renderLeaflet({
    leaflet(misp) %>% addProviderTiles(providers$CartoDB.Positron) %>%
      fitBounds(min(misp$longitude), min(misp$latitude), max(misp$longitude), max(misp$latitude))})

  observeEvent(input$range,{
    updatePickerInput(session=session, inputId="select", choices = unique(sort(filteredData()$binomial)), selected =filteredData2()$binomial)
    leafletProxy("map", data = filteredData()) %>%
      clearMarkers() %>%
      addCircleMarkers(popup = ~as.character(binomial),
                       label = ~as.character(binomial), radius = 5,
                       stroke = FALSE, fillOpacity = 2, color = ~pal(binomial))
  })

  observe(
    if (nrow(filteredData2()) == 0) {leafletProxy("map") %>% clearMarkers()}
    else
      leafletProxy("map", data = filteredData2()) %>%
      clearMarkers() %>%
      addCircleMarkers(popup = ~as.character(binomial),
                       label = ~as.character(binomial), radius = 5,
                       stroke = FALSE, fillOpacity = 2,color = ~pal(binomial))

  )
}

shinyApp(ui, server)

1 Ответ

0 голосов
/ 07 октября 2019

Dr. Sans - дайте мне знать, если это ближе к тому, что вы имели в виду.

Я думаю, вы хотите, чтобы ваша функция filteredData() фильтровала по диапазону года и input$select, чтобы предоставить подмножество данных, которые могут быть показанына карте.

Кроме того, я не думаю, что вам нужны observeEvent и observe для рисования маркеров. Просто observe обновит маркеры с изменениями при любом вводе через реактивный filteredData(). 

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

  filteredData <- reactive({
    misp %>%
      filter(year >= input$range[1] & year <= input$range[2]) %>%
      filter(binomial %in% input$select)
  })

  filteredChoices <- reactive({
    misp %>%
      filter(year >= input$range[1] & year <= input$range[2])
  })

  output$map <- renderLeaflet({
    leaflet(misp) %>% addProviderTiles(providers$CartoDB.Positron) %>%
      fitBounds(min(misp$longitude), min(misp$latitude), max(misp$longitude), max(misp$latitude))})

  observeEvent(input$range, {
    updatePickerInput(session=session, inputId="select", choices = unique(sort(filteredChoices()$binomial)), selected = filteredData()$binomial)
  })

  observe(
    if (nrow(filteredData()) == 0) {
      leafletProxy("map") %>%
        clearMarkers()
    }
    else {
      leafletProxy("map", data = filteredData()) %>%
      clearMarkers() %>%
      addCircleMarkers(popup = ~as.character(binomial),
                       label = ~as.character(binomial), radius = 5,
                       stroke = FALSE, fillOpacity = 2,color = ~pal(binomial))
    }
  )
}
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...