如何在闪亮的应用程序中更新 selectModUI 中的传单地图？
How to update the leaflet map in the selectModUI in a Shiny app?
我想在使用 Shiny 时为不同的 leaflet 地图更新 mapedit 包中的 selectModUI。下面是一个工作示例。
library(tidyverse)
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
ui <- fluidPage(
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Create selectMod
sel <- callModule(selectMod, "Sel_Map", sid74_map)
# Reactive values
rv <- reactiveValues(
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
slice(0)
)
# Subset the table based on the selection
observe({
# the select module returns a reactive
gs <- sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
if (!is.null(rv$selectnum)){
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
slice(rv$selectnum)
}
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
想法是创建地图，用户可以select或取消select地图上的多边形。根据用户的 selection，数据 table 输出将动态显示哪些县 selected 并呈现数据，如屏幕截图所示。
现在我想添加一个 select 输入，以便用户可以决定他们想要使用应用程序可视化的参数。我觉得我可以创建某种反应性或反应性值来存储地图，然后更新下面是我创建的示例。请注意，与示例 1 相比，我在示例 2 中创建了一个名为 sid79_map 的新传单地图，并添加了一个 select 输入，以便人们可以 select。但是，此策略不起作用。如果有人能指出前进的方向就太好了。
library(tidyverse)
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
sid79_pal <- colorBin(palette = viridis(10), domain = nc$SID79, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
sid79_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid79_pal(SID79),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid79_pal,
values = nc$SID79,
title = "SID79") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
ui <- fluidPage(
# Select input
selectInput(inputId = "Selection", label = "Select Counties", choices = c("SID74", "SID79"), selected = "SID74"),
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Try to create reactivity based on the select input type, not working
sel_type <- reactive({
input$Selection
})
leafmap <- reactive({
if(sel_type() == "SID74"){
sid74_map
} else if (sel_type() == "SID79"){
sid79_map
}
})
# Create selectMod
sel <- callModule(selectMod, "Sel_Map", leafmap())
# Reactive values
rv <- reactiveValues(
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
slice(0)
)
# Subset the table based on the selection
observe({
# the select module returns a reactive
gs <- sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
if (!is.null(rv$selectnum)){
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
slice(rv$selectnum)
}
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
主要问题是您的 callModule() 需要在反应上下文中。
我使用 observeEvent().
稍微修改了您的示例以修复该问题
见下文（我导入了 dplyr::slice 因为我想避免加载完整的 tidyverse）。
编辑： 我做了一些进一步的清理并添加了自定义版本的 selectMod 来解决 OP 的评论。
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
sid79_pal <- colorBin(palette = viridis(10), domain = nc$SID79, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
sid79_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid79_pal(SID79),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid79_pal,
values = nc$SID79,
title = "SID79") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
selectMod <- function(input, output, session, leafmap,
styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4),
styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7))
{
print("*** custom selectMod")
output$map <- leaflet::renderLeaflet({
mapedit:::add_select_script(leafmap, styleFalse = styleFalse, styleTrue = styleTrue,
ns = session$ns(NULL))
})
id <- "mapedit"
select_evt <- paste0(id, "_selected")
df <- data.frame()
selections <- reactive({
id <- as.character(input[[select_evt]]$id)
if (length(df) == 0) {
# Initial case, first time module is called.
# Switching map, i.e. subsequent calls to the module.
# Note that input[[select_evt]] will always keep the last selection event,
# regardless of this module being called again.
df <<- data.frame(id = character(0), selected = logical(0),
stringsAsFactors = FALSE)
} else {
loc <- which(df$id == id)
if (length(loc) > 0) {
df[loc, "selected"] <<- input[[select_evt]]$selected
} else {
df[nrow(df) + 1, ] <<- c(id, input[[select_evt]]$selected)
}
}
return(df)
})
return(selections)
}
ui <- fluidPage(
# Select input
selectInput(inputId = "Selection", label = "Select Counties", choices = c("SID74", "SID79"), selected = "SID74"),
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Reactivity based on the select input type
leafmap <- reactive({
my_sel <- input$Selection
if (my_sel == "SID74") {
sid74_map
} else if (my_sel == "SID79") {
sid79_map
}
})
# Reactive values
rv <- reactiveValues(
sel = reactive({}),
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
dplyr::slice(0)
)
# Create selectMod
observeEvent(leafmap(),
rv$sel <- callModule(selectMod, "Sel_Map", leafmap())
)
# Subset the table based on the selection
observeEvent(rv$sel(), {
# The select module returns a reactive
gs <- rv$sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
dplyr::slice(rv$selectnum)
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
我想在使用 Shiny 时为不同的 leaflet 地图更新 mapedit 包中的 selectModUI。下面是一个工作示例。
library(tidyverse)
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
ui <- fluidPage(
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Create selectMod
sel <- callModule(selectMod, "Sel_Map", sid74_map)
# Reactive values
rv <- reactiveValues(
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
slice(0)
)
# Subset the table based on the selection
observe({
# the select module returns a reactive
gs <- sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
if (!is.null(rv$selectnum)){
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
slice(rv$selectnum)
}
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
想法是创建地图，用户可以select或取消select地图上的多边形。根据用户的 selection，数据 table 输出将动态显示哪些县 selected 并呈现数据，如屏幕截图所示。
现在我想添加一个 select 输入，以便用户可以决定他们想要使用应用程序可视化的参数。我觉得我可以创建某种反应性或反应性值来存储地图，然后更新下面是我创建的示例。请注意，与示例 1 相比，我在示例 2 中创建了一个名为 sid79_map 的新传单地图，并添加了一个 select 输入，以便人们可以 select。但是，此策略不起作用。如果有人能指出前进的方向就太好了。
library(tidyverse)
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
sid79_pal <- colorBin(palette = viridis(10), domain = nc$SID79, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
sid79_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid79_pal(SID79),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid79_pal,
values = nc$SID79,
title = "SID79") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
ui <- fluidPage(
# Select input
selectInput(inputId = "Selection", label = "Select Counties", choices = c("SID74", "SID79"), selected = "SID74"),
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Try to create reactivity based on the select input type, not working
sel_type <- reactive({
input$Selection
})
leafmap <- reactive({
if(sel_type() == "SID74"){
sid74_map
} else if (sel_type() == "SID79"){
sid79_map
}
})
# Create selectMod
sel <- callModule(selectMod, "Sel_Map", leafmap())
# Reactive values
rv <- reactiveValues(
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
slice(0)
)
# Subset the table based on the selection
observe({
# the select module returns a reactive
gs <- sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
if (!is.null(rv$selectnum)){
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
slice(rv$selectnum)
}
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)
主要问题是您的 callModule() 需要在反应上下文中。
我使用 observeEvent().
见下文（我导入了 dplyr::slice 因为我想避免加载完整的 tidyverse）。
编辑： 我做了一些进一步的清理并添加了自定义版本的 selectMod 来解决 OP 的评论。
library(shiny)
library(sf)
library(leaflet)
library(mapview)
library(mapedit)
library(DT)
library(viridis)
# Load the sf object
nc <- st_read(system.file("shape/nc.shp", package = "sf"))
# Project transformation
nc <- st_transform(nc, crs = 4326)
# Create a color function for the leaflet map
sid74_pal <- colorBin(palette = viridis(10), domain = nc$SID74, bins = 4)
sid79_pal <- colorBin(palette = viridis(10), domain = nc$SID79, bins = 4)
# Create a leaflet map
sid74_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid74_pal(SID74),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid74_pal,
values = nc$SID74,
title = "SID74") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
sid79_map <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("CartoDB", group = "CartoDB") %>%
addProviderTiles("Esri.WorldImagery", group = "Esri.WorldImagery") %>%
addFeatures(nc,
color = ~sid79_pal(SID79),
label = ~htmltools::htmlEscape(NAME),
layerId = ~seq_len(length(st_geometry(nc)))) %>%
addLegend(position = "bottomright", pal = sid79_pal,
values = nc$SID79,
title = "SID79") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Esri.WorldImagery"))
selectMod <- function(input, output, session, leafmap,
styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4),
styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7))
{
print("*** custom selectMod")
output$map <- leaflet::renderLeaflet({
mapedit:::add_select_script(leafmap, styleFalse = styleFalse, styleTrue = styleTrue,
ns = session$ns(NULL))
})
id <- "mapedit"
select_evt <- paste0(id, "_selected")
df <- data.frame()
selections <- reactive({
id <- as.character(input[[select_evt]]$id)
if (length(df) == 0) {
# Initial case, first time module is called.
# Switching map, i.e. subsequent calls to the module.
# Note that input[[select_evt]] will always keep the last selection event,
# regardless of this module being called again.
df <<- data.frame(id = character(0), selected = logical(0),
stringsAsFactors = FALSE)
} else {
loc <- which(df$id == id)
if (length(loc) > 0) {
df[loc, "selected"] <<- input[[select_evt]]$selected
} else {
df[nrow(df) + 1, ] <<- c(id, input[[select_evt]]$selected)
}
}
return(df)
})
return(selections)
}
ui <- fluidPage(
# Select input
selectInput(inputId = "Selection", label = "Select Counties", choices = c("SID74", "SID79"), selected = "SID74"),
# Select Module Output
h3("Map"),
selectModUI(id = "Sel_Map"),
# Datatable Output
h3("Table"),
dataTableOutput(outputId = "Table")
)
server <- function(input, output) {
# Reactivity based on the select input type
leafmap <- reactive({
my_sel <- input$Selection
if (my_sel == "SID74") {
sid74_map
} else if (my_sel == "SID79") {
sid79_map
}
})
# Reactive values
rv <- reactiveValues(
sel = reactive({}),
selectnum = NULL,
sub_table = nc %>%
st_set_geometry(NULL) %>%
dplyr::slice(0)
)
# Create selectMod
observeEvent(leafmap(),
rv$sel <- callModule(selectMod, "Sel_Map", leafmap())
)
# Subset the table based on the selection
observeEvent(rv$sel(), {
# The select module returns a reactive
gs <- rv$sel()
# Filter for the county data
rv$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])
rv$sub_table <- nc %>%
st_set_geometry(NULL) %>%
dplyr::slice(rv$selectnum)
})
# Create a datatable
output$Table <- renderDataTable({
datatable(rv$sub_table, options = list(scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)