Question

我正在使用 leaflet-heat.js 插件进行传单。我能使它工作的唯一方法是通过rCharts库。 R shiny leaflet javascript addons - heatmap

热图正确显示，但我无法更改热图选项。此外，如果我取消注释代码的反应部分，应用程序崩溃。

似乎修改热图图层不透明度的唯一方法是通过CSS，但我无法弄清楚如何在这里实现它。 control the opacity of heatmap using leaflet heatmap

以下是有效代码的一部分，其中有违规行被注释掉。

library(shiny)
library(shinydashboard)
library(rCharts)

# Define UI for app

header1 <- dashboardHeader(
  title = "My Dashboard"
)

sidebar1 <- dashboardSidebar(
  sidebarMenu(
    fileInput("file0", "Choose CSV File",
              multiple = TRUE,
              accept = c("text/csv",
                         "text/comma-separated-values,text/plain",".csv")),
    sliderInput("opacity", "Opacity:",
                min = 0, max = 1,
                value = 0.5, step = 0.05),
    sliderInput("radius", "Radius:",
                min = 0, max = 50,
                value = 25),
    sliderInput("blur", "Blur:",
                min = 0, max = 1,
                value = 0.75, step = 0.05),
    sliderInput("maxvalue", "MaxValue:",
                min = 0, max = 1,
                value = 1, step = 0.05)
  ) #sidebarMenu
) #dashboardSidebar

body1 <- dashboardBody(
  fluidRow(
    box(
      title = "Box Title 1", width = 11, solidHeader = TRUE, status = "primary",
      chartOutput("baseMap", "leaflet"),
      tags$style('.leaflet {width: 600px; height: 400px;}'),
      tags$head(tags$script(src="http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js")),
      uiOutput('heatMap')
    ) #box
  ) #fluidRow
) #dashboardBody

ui <- dashboardPage(header1, sidebar1, body1)

# Define data
dat <- data.frame(latitude = c(14.61),
                  longitude = c(-90.54),
                  intensity = c(100))

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

  opacityoption <- reactive({
    paste("minOpacity = ",as.character(input$opacity))
  })

  radiusoption <- reactive({
    paste("radius = ",as.character(input$radius))
  })

  bluroption <- reactive({
    paste("blur = ",as.character(input$blur))
  })

  maxoption <- reactive({
    paste("max = ",as.character(input$maxvalue))
  })

  output$baseMap <- renderMap({
    baseMap <- Leaflet$new() 
    baseMap$setView(c(14.61,-90.54) ,12) 
    baseMap$tileLayer(provider="Esri.WorldTopoMap")
    baseMap
  })

  output$heatMap <- renderUI({

    j <- paste0("[",dat[,"latitude"], ",", dat[,"longitude"], ",", dat[,"intensity"], "]", collapse=",")
    j <- paste0("[",j,"]")
    j

    tags$body(tags$script(HTML(sprintf("
                                       var addressPoints = %s
                                       var heat = L.heatLayer(addressPoints).addTo(map)"
                                       , j)
    )))

    # THESE LINES DO NOT WORK - THE OBSERVE BLOCK CRASHES
    # tags$body(tags$script(HTML(sprintf("heat.setOptions(minOpacity = 0.5)"
    # )))) #tags$body

    # tags$body(tags$script(HTML(sprintf("heat.setOptions(radius = 50)"
    # )))) #tags$body

    # observe({
    #   tags$body(tags$script(HTML(sprintf(paste("heat.setOptions(",opacityoption,", ",radiusoption,", ",bluroption,", ",maxoption,")")
    #   )))) #tags$body
    # }) #observe

  }) #renderUI

} #server


# Run app
shinyApp(ui, server)

非常感谢您对此的帮助！：）

Answer 1

你正在寻找这样的东西吗？以下是addHeatmap的示例。只需移动sliderInput，您就会看到地图会相应更改。它似乎不适用于maxvalue，但更改了sliderInput中的数字，它会起作用。您可能还希望查看leafletProxy。

library(shiny)
library(shinydashboard)
library(leaflet)
library(leaflet.extras)

# Define UI for app

header1 <- dashboardHeader(
  title = "My Dashboard"
)

sidebar1 <- dashboardSidebar(
  sidebarMenu(
    fileInput("file0", "Choose CSV File",
              multiple = TRUE,
              accept = c("text/csv",
                         "text/comma-separated-values,text/plain",".csv")),
    sliderInput("opacity", "Opacity:",
                min = 0, max = 1,
                value = 0.5, step = 0.05),
    sliderInput("radius", "Radius:",
                min = 0, max = 50,
                value = 25),
    sliderInput("blur", "Blur:",
                min = 0, max = 30,
                value = 0.75, step = 2),
    sliderInput("maxvalue", "MaxValue:",
                min = 0, max = 1,
                value = 1, step = 0.05)
  ) #sidebarMenu
) #dashboardSidebar

body1 <- dashboardBody(
  fluidRow(
    box(
      title = "Box Title 1", width = 11, solidHeader = TRUE, status = "primary",
      leafletOutput("baseMap"),
      tags$style('.leaflet {width: 600px; height: 400px;}'),
      tags$head(tags$script(src="http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js"))
    ) #box
  ) #fluidRow
) #dashboardBody

ui <- dashboardPage(header1, sidebar1, body1)

# Define data
dat <- data.frame(latitude = c(14.61, 15),
                  longitude = c(-90.54, -90.65),
                  intensity = c(100, 125))

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

  output$baseMap <- renderLeaflet({
    leaflet(data = dat) %>% addProviderTiles(providers$Stamen.TonerLite,
                                   options = providerTileOptions(noWrap = TRUE)) %>% setView(-90.54, 14.61, zoom = 12) %>%
      addHeatmap(lng = ~longitude, lat = ~latitude, intensity = ~as.numeric(intensity), minOpacity= ~input$opacity, blur = ~input$blur, max = ~input$maxvalue, radius = ~input$radius)
  })


} #server


# Run app
shinyApp(ui, server)

改变传单中的传单热图选项

1 个答案: