Получать layerID только от определенного слоя в интеграции Shiny's Leaflet - PullRequest
Новая
       16

Получать layerID только от определенного слоя в интеграции Shiny's Leaflet

0 голосов
/ 21 июня 2019

У меня проблема с shiny leaflet интеграцией. Я хочу сделать интерактивную листовку, в которой пользователь может щелкнуть элемент, а затем в нижней части появится всплывающая диаграмма, соответствующая этому элементу.

Вот структура приборной панели

Как правило, во время события щелчка Shiny пытается собрать идентификатор этой специфической функции, запросить внешний фрейм данных на основе идентификатора и затем сгенерировать график. До сих пор мне удалось заставить рабочий процесс работать.

Однако проблема возникает, когда я пытаюсь добавить еще один слой (с другим идентификатором) на карту. Предположим, что есть два слоя: дерево и железные дороги. Если я нажму на слой с деревом, появится график с изображением дерева. Но когда я нажимаю на дорогу, генератор графиков все еще работает, а затем обновляет график, возвращая ошибку из-за конфликтующих идентификаторов. Я не хочу этого Я хочу, чтобы график обновлялся ТОЛЬКО при нажатии на деревья, но не при нажатии на железные дороги.

Я заметил, что проблема возникает из-за того, что Shiny обрабатывает события Leaflet на основе категории объекта input$MAPID_OBJCATEGORY_EVENTNAME. В моем случае и деревья, и железные дороги классифицируются как фигуры, поэтому событие будет обновляться всякий раз, когда я нажимаю на любой из объектов. Мой обходной путь до сих пор состоит в том, чтобы добавить один слой как GeoJSON, чтобы Shiny мог различать разные слои. Но, конечно, это нецелесообразно, так как проблема возникнет снова, если я добавлю еще один слой.

Это код, который у меня есть: 

library(shiny)
library(shinydashboard)
library(leaflet)
library(magrittr)
library(raster)
library(rgdal)
library(sf)
library(RColorBrewer)
library(ggplot2)

rm(list = ls())

# Get the functions from functions.R
source("functions.R")

# Loading the data
# Shapes
spoor <- readOGR("./data/ScoredSpoor.geojson")
kroon <- readOGR("./data/RiskyTrees.json")
# spoor <- readLines("./data/ScoredSpoor.geojson") %>% paste(collapse = "\n")
# kroon <- readLines("./data/RiskyTrees.json") %>% paste(collapse = "\n")
# Indices
ndvi <- readRDS("./data/ndvi.rds")
evi <- readRDS("./data/evi.rds")
lai1 <- readRDS("./data/lai1.rds")
lai2 <- readRDS("./data/lai2.rds")
lai3 <- readRDS("./data/lai3.rds")
date <- readRDS("./data/date.rds")

# Color palettes for visualization
palTree <- colorBin("RdBu", domain = kroon$SCORE, bins = c(0:5), reverse = T)
# bins <-  c(0:5)
# pal <- colorBin("RdBu", domain = kroon$BOOMHOOGTE, bins = bins)
# palette_rev <- rev(brewer.pal(5, "RdBu"))

### APPLICATION ###

header <- dashboardHeader(title = "Bomen in Beeld+")

body <- dashboardBody(

  fluidRow(
    column(width = 8,
           box(title = "Map", width = NULL, height = 500, solidHeader = T,
               leafletOutput("basemap"))

    ),
    column(width = 4,
           box(title = "Track Info", width = NULL, height = 250, solidHeader = T,
               "Spoorlijn Utrecht - Baarn", textOutput("text")),
           box(title = "Tree Info", width = NULL, height = 250, solidHeader = T,
               "Tree information would appear here.")
    )
  ),

  fluidRow(
    box(title = "How 'green' is the tree?", width = 4, height = 300,
        plotOutput("graph")),
    box(width = 4, height = 300,
        selectInput("parameter", "Select a parameter to visualize:",
                    choices = c("NDVI" = "ndvi", 
                                "EVI" = "evi", 
                                "LAI/EVI - Alexander et al (2019)" = "lai1",
                                "LAI/EVI - Wang et al (2005)" = "lai2", 
                                "LAI/NDVI - Wang et al (2005)" = "lai3"))),
    box(title = "Credits", width = 4, height = 300,
        "(c) 2019 Tombayu Amadeo Hidayat", br(),
        img(src = "logo.png", height = 30))
  )
)

ui <- dashboardPage(header, dashboardSidebar(disable = T), body = body)

server <- function(input, output) {

  # Basemap
  output$basemap <- renderLeaflet({
    leaflet() %>% 
      addTiles() %>%
      setView(5.282715, 52.154510, 18) %>%
      addPolylines(data = spoor) %>%
      addPolygons(data = kroon, fillColor = ~palTree(SCORE), fillOpacity = 1, weight = 0.2,
                  highlight = highlightOptions(weight = 3, color = "black"),
                  layerId  = ~OBJECTID)
  })

  IDs <- list()

  # Retrieve ID of clicked polygon
  clickID <- eventReactive(input$basemap_shape_click, {
    return(input$basemap_shape_click$id)
  })

  # 'Greenness' graph
  output$graph <- renderPlot({
      createPlot(as.numeric(clickID()), as.character(input$parameter))
  })

  output$text <- renderText(getwd())
}

##### BUNDLE THE APP AND RUN #####

shinyApp(ui = ui, server = server)

И эта функция, которую я использую для создания графика: 

createPlot <- function(tree, var = "ndvi") {
  plot <- ggplot(data, aes_string("Date", var)) +
    geom_line(size = 1.5) +
    geom_point(shape = 21, size = 5, color = "black", fill = "white") +
    scale_x_date(date_labels = "%b-%Y", date_breaks = "3 month", date_minor_breaks = "1 month") +
    theme_light()
  return(plot)
}

Извините, я не могу предоставить вам какие-либо данные, поскольку они конфиденциальны. Но я надеюсь, что предоставлю вам достаточно информации.

Спасибо!

...