Change leaflet heatmap options in shiny

Question

I am using leaflet-heat.js plugin for leaflet. The only way that I could make it work, was through the rCharts library. R shiny leaflet javascript addons - heatmap

The heatmap displays correctly, but I cannot change the heatmap options. In addition, if I uncomment the reactive part of the code, the app crashes.

It seems that the only way to modify the heatmap layer opacity is through CSS, but I cannot figure out how to implement it here. control the opacity of heatmap using leaflet heatmap

Here is the part of the code that works, with the offending lines commented out.

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)

Your help on this will be greatly appreciated! :)

Answer 1

Are you looking for something like this? Here is an example with addHeatmap. Just move your sliderInput and you will see the map will change accordingly. It seems to be not working for the maxvalue, but change the numbers in your sliderInput and it will work. You may want to look also in 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)