R闪亮的传单javascript插件 - 热图

Question

Trying to use one of the javascript addons for leaflet - specifically the heatmap functionality - https://github.com/Leaflet/Leaflet.heat Thing is - I want to incorporate this into Shiny, but leaflet for R doesn't seem to have this addon included by default, so I would have to somehow include this JS manually. The closest I got to figuring out how to do this is through a post on rCharts that showed this:

server.R.

 HeatMap$addAssets(jshead = c("http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js"))
 HeatMap$setTemplate(afterScript = sprintf("<script>
      var addressPoints = %s
      var heat = L.heatLayer(addressPoints).addTo(map)           
      </script>",
      rjson::toJSON(dt)))

(taken from: https://github.com/ramnathv/rCharts/issues/498 )

But being not too familiar with JS, and new to leaflet it's still not quite clear how it can be incorporated from beginning to end - ie taking this JS from github and ending up with a heatmap created using leaflet on the dataset 'quakes'.

My server side code is something like the following:

library(leaflet)
output$mymap <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("OpenMapSurfer.Roads",
                       options = providerTileOptions(noWrap = TRUE))
 %>% addMarkers(clusterOptions = markerClusterOptions(), data = quakes))

Where instead of clusterOptions I would like to add a heatmap of the magnitude of the earthquakes (the dataset 'quakes' is included in R so you can see it for yourself).

Any help on figuring this out would be very much appreciated! :)

Answer 1

The setTemplate(afterscript...) bit doesn't work in shiny. Instead you need to use tags$() and render the heatmap output separately to the map.

Here is a basic app that uses heatmaps ( inspired by this SO answer )

server.R

library(shiny)
library(rCharts)

dat <- data.frame(Offence =  c("Assault","Assault","Assault","Weapon","Assault","Burglary"),
                  Date = c("2015-10-02","2015-10-03","2015-10-04","2015-04-12","2015-06-30","2015-09-04"),
                  Longitude = c(-122.3809, -122.3269, -122.3342, -122.2984, -122.3044, -122.2754),
                  Latitude = c(47.66796,47.63436,47.57665,47.71930,47.60616,47.55392),
                  intensity = c(10,20,30,40,50,30000))


shinyServer(function(input, output, session) {

  output$baseMap <- renderMap({
    baseMap <- Leaflet$new() 
    baseMap$setView(c(47.5982623,-122.3415519) ,12) 
    baseMap$tileLayer(provider="Esri.WorldStreetMap")
    baseMap
  })

  output$heatMap <- renderUI({

    ## here I'm creating the JSON through 'paste0()'.
    ## you can also use jsonlite::toJSON or RJSONIO::toJSON

    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
    ))))
  })

})

ui.R

library(shiny)
library(rCharts)

shinyUI(fluidPage(

  mainPanel(
    headerPanel("title"),
    chartOutput("baseMap", "leaflet"),
    tags$style('.leaflet {height: 500px;}'),
    tags$head(tags$script(src="http://leaflet.github.io/Leaflet.heat/dist/leaflet-heat.js")),
    uiOutput('heatMap')
    )
  ))

---

Edit - Using Google Maps

There is also a way to do this in the development version of googleway . For this you'll need a valid Google API key, and currently it only works in a browser

## devtools::install_github("googleway")
library(googleway)
library(magrittr)
library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    actionButton(inputId = "traffic", label = "traffic"),
    box(width = 10,
        height = 600,
      google_mapOutput("myMap")
    )
  )
)


server <- function(input, output){

map_key <- "your_valid_api_key"
## https://developers.google.com/maps/documentation/javascript/get-api-key

## set up some data-------
pl <- "~s|dF}{~rZnNoExBq@|@SfAIjA@~Et@fBBp@Iv@QxCoArNqGfA_@dB]`KgAfVkC|Gu@rAYf@Q|@i@p@m@n@{@^u@`@kAR_ALiADuACiAIeAOy@_@qA{@uB{@sB]gAUmAOaB?oCTkKr@kZZiN?s@Cq@EQDOLILFn@A\\CpI_A|AQjB[BGPOX@LHz@CpAKT?v@KpHu@vD]LGt@Ix@I\\QBGLOVCPJd@Dj@GnFq@`PaBp@KfBQzA[zAq@nAaAx@aA~ByDp@yAXe@VSVO@EVWPCRDJLBF@Hd@TrDj@rK`ADEJGJ@JFBFrSxBJOPCNHHPdBLnCb@bBb@lAf@zA~@lAbApAzAt@nAxA|C~BhHrAxD~AtEb@|@xAtBpBlBzCbB`AZhIhBrFpA|AZl@HRDLENGXORe@DKJSf@wD`@cDt@}INq@ZuEt@mHfBsN~BkS`CmR\\eDnAiKzAcM`CePNmAhAsGXmArAgFtDsM|DaOh@sC^kCf@kDb@uDl@kI\\sHn@yM?gDEoAOsA[}BUiBUsC@qCNuBViBrCcPp@oGHW|@oPBuDI_DKqAy@wD{Ja^}@oFY_CWoDIqBGqEBsENqE`C{^JuA\\aDj@oDn@cDxAcFz@yBtC{Fp@eAn@_An@s@t@}@j@g@bCaBtCsA`GiAzBm@`C}@jBmA~CiC~DcDjCwAfAa@bBe@nBa@pCYlCArDBlCHhCGnC_@~A]vBk@hAa@lF_CnMaGbDeArD}@vB[zEe@jFS`GFfBFxBJzO\\zZfAfCJdEPbDNvDRnEHvD?tEE~BQhC[zAYnCu@bA]dBm@bIkDtBy@bAYhB[rDYxJ[nB@vAHfBLbCf@|C~@vAp@nCdB|A`A`CzApAr@|Al@rBl@bBZbUbCZBzBDvBEtAMnF_AvB[vBOlCAlBFnBXbDr@~Bv@z@`@bBfAdD~BtB`Bv@f@nAn@x@ZZJ~A\\dBTdADtBEbAGnEg@dFi@`DYdDQdF?|DNfCV`BTlCl@dNvD`HnBdLvClAZn@DzB^hCRd@?fA?|@Ih@O`@Ud@a@h@w@\\u@Pm@Lw@HoBq@qK]eLUcIE{DC{AD}Fn@eSLeCJs@RwFRkDf@sCj@aE`AsFhAuGh@gDt@wEp@}En@_FPeBRkDByBCgBEgAS}B{@oEsA}Dy@eCi@yBGq@?s@Ds@V}@Rg@r@u@ZOj@Ml@Az@PrA^fBb@j@HV@f@e@`B}AbB_B]Ie@KeASiO}CmH_B{L}Bk@QTqBTgCAm@g@kCSaAs@V{CdAmDrAuAh@{@Ra@H{@D{Af@wBt@gAb@]ReBl@"
df_line <- decode_pl(pl)
set.seed(123)
df_line$weight <- runif(nrow(df_line), min = 1, max = 100)

## ------------

## plot the map
output$myMap <- renderGoogle_map({

google_map(key = map_key, data = df_line, search_box = F) %>%
  add_heatmap(weight = "weight") %>%
    add_traffic()

  })

}

shinyApp(ui, server)