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

Question

尝试使用其中一个javascript插件进行传单 - 特别是热图功能 - https://github.com/Leaflet/Leaflet.heat 事情是 - 我想把它融入Shiny,但R的传单似乎没有这个插件默认包含在内,所以我不得不以某种方式手动包含这个JS.最接近我弄清楚如何做到这一点是通过rCharts上的帖子显示:

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

(摘自:https://github.com/ramnathv/rCharts/issues/498)

但是对于JS不太熟悉,以及传单的新功能仍然不太清楚它是如何从头到尾合并的 - 即从github获取这个JS并最终使用在数据集'quakes'上使用传单创建的热图.

我的服务器端代码如下所示:

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

而不是clusterOptions我想添加一个地震震级的热图(数据集'quakes'包含在R中,所以你可以自己看到它).

任何有关解决这个问题的帮助将非常感谢!:)

Answer 1

该setTemplate(afterscript...)钻头在闪亮状态下不起作用。相反，您需要tags$()单独使用热图输出并将其渲染到地图。

这是一个使用热图的基本应用程序（受到这个SO答案的启发）

服务器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')
    )
  ))

编辑 - 使用 Google 地图

在开发版本中也有一种方法可以做到这一点googleway。为此，您需要一个有效的 Google API 密钥，目前它仅适用于浏览器

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