R shiny javascript addons flyers - heatmap

Question

Trying to use one of the javascript add-ons for flyers - in particular, the heatmap functionality - https://github.com/Leaflet/Leaflet.heat The fact is that I want to include this in Shiny, but in the worksheet for R it doesn't seem like this addon is enabled by default, so I would have to somehow enable this JS manually. Closest to me I figured out how to do this - through a post on rCharts that showed this:

server.R. HeatMap$addAssets(jshead = c("http://leaflet.imtqy.com/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 the new ones in the leaflet, it is still not entirely clear how this can be included from beginning to end - i.e., taking this JS from github and getting a heat map created using leaflets on earth ball.

My server side code looks something like this:

 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 heat map of the magnitude of the earthquakes (the earthquake dataset is included in R so you can see it for yourself).

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

Answer 1

The setTemplate(afterscript...) bit setTemplate(afterscript...) does not work brilliant. Instead, you need to use tags$() and display the output of the heat map separately on the map.

Here is a basic application 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.imtqy.com/Leaflet.heat/dist/leaflet-heat.js")), uiOutput('heatMap') ) )) 

---

Edit - Using Google Maps

There is also a way to do this in the googleway development googleway . To do this, you will 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)