Буклет R - Как ждать только `map_shape_click` - PullRequest
Новая
       7

Буклет R - Как ждать только `map_shape_click`

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

Использование leaflet mouse-events, щелчок по шейп-файлу, также вызывает щелчок на карте, поэтому зеленые линии в примере нарисованы немедленно.

Как мне ждать щелчка поодин из шейп-файлов, чтобы удалить нажатую линию и игнорировать щелчки карты для этого, но когда я нажимаю на карту (а не шейп-файл), появляются зеленые линии?

Или как я могу получитьinput$map_shape_click только? 

library(shiny)
library(leaflet)
library(sp)

## DATA
x <- c(1,5,4,8); y <- c(1,3,4,7)
data = sp::SpatialLines(list(
  sp::Lines(sp::Line(cbind(x,y)), ID="a"),
  sp::Lines(sp::Line(cbind(rev(x)*1.1,y)), ID="b")), 
  CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))

data = SpatialLinesDataFrame(data, data = data.frame(
  id = 1:length(data)), match.ID = F)
data1 = SpatialLinesDataFrame(data, data = data.frame(
  id = 1:length(data)), match.ID = F)

## UI
ui = fluidPage(
  leafletOutput("map")
)

## SERVER
server <- shinyServer(function(input, output, session) {

  output$map <- renderLeaflet({
    leaflet(options = leafletOptions(doubleClickZoom= FALSE)) %>% 
      addTiles() %>% 
      addPolylines(data = data, smoothFactor = 10, opacity = 1, color = "blue",
                   layerId = as.character(data$id),
                   highlightOptions = highlightOptions(color = "white",
                                                       weight = 5, bringToFront = F, opacity = 1)
      )
  })

  observeEvent(input$map_shape_click, {
    cat("Shape is Clicked \n")   
    proxy <- leafletProxy("map")
    proxy %>% removeShape("1")
  })

  observeEvent({ input$map_click }, {
    cat("Map Clicked \n")
    proxy <- leafletProxy("map")
    proxy %>%       addPolylines(data = data, smoothFactor = 10, opacity = 1, color = "green",
                                 layerId = as.character(data$id))

  })

})

shinyApp(ui, server)

1 Ответ

0 голосов
/ 23 июля 2018

Вы можете проверить координаты клика и запустить код в input$map_click обозревателе в зависимости от найденных совпадений.Код ниже: 

library(shiny)
library(leaflet)
library(sp)
library(rgeos)

## DATA
x <- c(1,5,4,8); y <- c(1,3,4,7)
data = sp::SpatialLines(list(
  sp::Lines(sp::Line(cbind(x,y)), ID="a"),
  sp::Lines(sp::Line(cbind(rev(x)*1.1,y)), ID="b")), 
  sp::CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))

data = sp::SpatialLinesDataFrame(data, data = data.frame(
  id = 1:length(data)), match.ID = F)
data1 = sp::SpatialLinesDataFrame(data, data = data.frame(
  id = 1:length(data)), match.ID = F)

## UI
ui = fluidPage(
  leafletOutput("map")
)

## SERVER
server <- shinyServer(function(input, output, session) {

  output$map <- renderLeaflet({
    leaflet(options = leafletOptions(doubleClickZoom= FALSE)) %>% 
      addTiles() %>% 
      addPolylines(data = data, smoothFactor = 10, opacity = 1, color = "blue",
                   layerId = as.character(data$id),
                   highlightOptions = highlightOptions(color = "white",
                                                       weight = 5, bringToFront = F, opacity = 1)
      )
  })

  observeEvent({ input$map_click }, {

    coords <- input$map_click
    clicked <- sp::SpatialPoints(
      matrix(
        c(coords$lng, coords$lat),
        nrow = 1
      )
    )
    sp::proj4string(clicked) <- sp::CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
    compare <- rgeos::gIntersects(
      # verify if width parameter works for you
      rgeos::gBuffer(clicked, width = 0.5), 
      data, 
      byid = TRUE
    )

    if(any(compare)){
      cat("Shape is Clicked \n")  
      proxy <- leafletProxy("map")

      if(compare[1] == TRUE){
        proxy %>% removeShape("1")
      }
      if(compare[2] == TRUE){
        proxy %>% removeShape("2")
      }

    }else{
      cat("Map Clicked \n")
      proxy <- leafletProxy("map")
      proxy %>%       addPolylines(data = data, smoothFactor = 10, opacity = 1, color = "green",
                                   layerId = as.character(data$id))
    }

  })

})

shinyApp(ui, server)
...