如何使Mapdeck中的色标静态

Question

我正在开发一个闪亮的应用程序，该应用程序按小时逐步显示时间，并在mapdeck地图上显示降水量。我读取了整天的天气数据，并使用反应性过滤了一个小时的数据，并使用mapdeck_update将其绘制为散点图以更新数据。每当地图根据该小时内的数据范围进行更新时，色标都会更改。我想要的是基于当天数据范围的静态色标。有可能吗？

我尝试使用手动颜色，但是由于某些原因它们不起作用

library(mapdeck)
ui <- fluidPage(
fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
fluidRow(mapdeckOutput(outputId = "wx"))
)

sr <- function(input, output, session) {
mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")
wx_map <- mapdeck(data=NULL,token = Sys.getenv("MAPBOX_API_TOKEN"),style = 'mapbox://styles/mapbox/dark-v9',zoom = 6, location = c(-97,24.5)) 
observe({
wx_dt <- mydata %>% dplyr::filter(hr == input$hr)


mapdeck_update(map_id = "wx") %>% 
  add_scatterplot(data=wx_dt,lon = "Center.Longitude",lat = "Center.Latitude",radius = 15000,fill_colour = "vil_int_36",legend = TRUE,layer_id = "wxlyr",update_view = FALSE,focus_layer=FALSE)
})
output$wx <- renderMapdeck(wx_map)
}

shinyApp(ui, sr)

请注意图例中色标范围的变化，但点的颜色几乎保持不变。我希望颜色代表整个数据集的最小值（最大值）（而不仅仅是小时），这样我就可以在逐步检查每个小时时看到强度的变化。谢谢。

Answer 1

好问题；是的，您需要创建一个手动图例，使其保持静态，否则每次绘图中的值更新时都会更新。

手动图例需要使用与地图相同的颜色。地图被library(colourvalues)上色。因此，您可以使用它在地图之外制作颜色，然后将结果用作手动图例

l <- colourvalues::colour_values(
  x = mydata$vil_int_36
  , n_summaries = 5
)

legend <- mapdeck::legend_element(
  variables = l$summary_values
  , colours = l$summary_colours
  , colour_type = "fill"
  , variable_type = "category"
)

js_legend <- mapdeck::mapdeck_legend(legend)

现在，此js_legend对象采用正确的JSON格式，地图可以将其呈现为图例

js_legend
# {"fill_colour":{"colour":["#440154FF","#3B528BFF","#21908CFF","#5DC963FF","#FDE725FF"],"variable":["20.00","23.50","27.00","30.50","34.00"],"colourType":["fill_colour"],"type":["category"],"title":[""],"css":[""]}}

这是在你闪亮的

library(mapdeck)
library(shiny)
ui <- fluidPage(
  fluidRow(sliderInput(inputId = "hr",label = "Hour",min = 1,max = 3,value = 1)),
  fluidRow(mapdeckOutput(outputId = "wx"))
)

sr <- function(input, output, session) {
  mydata <- read.table(header=TRUE, sep=",",text="
ROW,COL,Center Latitude,Center Longitude,vil_int_36,hr
28,439,23.669885449218786,-97.2498101160108,20,1
41,433,24.37845221074034,-97.59803936272704,21,1
59,441,25.35333762373948,-97.11966878019186,22,1
61,441,25.461905262766468,-97.11878391116397,23,1
62,443,25.515163854569053,-96.99946877404128,24,1
29,439,23.724265738052193,-97.24945283742396,25,2
43,433,24.48713046908765,-97.59764743717052,26,2
59,442,25.35284441116698,-97.06032252207848,27,2
61,442,25.46141127997772,-97.05937801465758,28,2
62,444,25.514605007836384,-96.94003374232112,29,2
29,440,23.723846594719276,-97.19096992696834,30,3
43,434,24.486897474919978,-97.53876699838483,31,3
60,443,25.406603480942334,-97.00047511628769,32,3
62,441,25.516184831702166,-97.11834002241596,33,3
62,449,25.511327212479294,-96.64286546489153,34,3
")

  ## create a manual legend
  l <- colourvalues::colour_values(
    x = mydata$vil_int_36
    , n_summaries = 5
  )

  legend <- mapdeck::legend_element(
    variables = l$summary_values
    , colours = l$summary_colours
    , colour_type = "fill"
    , variable_type = "category"
  )
  js_legend <- mapdeck::mapdeck_legend(legend)
  ### --------------------------------

  wx_map <- mapdeck(
    style = 'mapbox://styles/mapbox/dark-v9'
    , zoom = 6
    , location = c(-97,24.5)
    ) 
  observe({
    wx_dt <- mydata %>% dplyr::filter(hr == input$hr)
    mapdeck_update(map_id = "wx") %>% 
      add_scatterplot(
        data = wx_dt
        , lon = "Center.Longitude"
        , lat = "Center.Latitude"
        , radius = 15000
        , fill_colour = "vil_int_36"
        , legend = js_legend
        , layer_id = "wxlyr"
        , update_view = FALSE
        , focus_layer = FALSE
        )
  })
  output$wx <- renderMapdeck(wx_map)
}

shinyApp(ui, sr)