Issue involving map generation in shiny

问题

Friends could help me resolve the following issue:

I am inserting three executable codes below, the first generates a map using sftnetworks package, showing the route between two locations. In this case, the two locations to generate the map were defined: from = c(df_spec_clust[1, c("Longitude")], df_spec_clust[1, c("Latitude")]) and to = c (df_spec_prop [4, c ("Longitude")], df_spec_prop [4, c ("Latitude")])]. In the second, I would like to generate the map in Shiny format, but without defining the locations exactly as I did in the first code. I would like them to be selected from the filters I created (Filter 1 and Filter 2). However, I am unable to generate the map. Could you help me ? To show you I managed to generate the map correctly in the third code for the problem in question but using another package (leaflet). However, I still couldn't think of a way to make it work using the sfnetworks package. Any help is appreciated.

Thank you!

First code

library(sf)
library(sfnetworks)
library(tmap)
library(rdist)
library(geosphere)

#for the roads file
download.file("https://github.com/JovaniSouza/JovaniSouza5/raw/master/Test.zip", "Test.zip")
unzip("Test.zip")

#database df
df <- structure(
  list(Property = c(1,2,3,4,5,6,7), Latitude = c(-24.779225, -24.789635, -24.763461, -24.794394, -24.747102,-24.781307,-24.761081),
    Longitude = c(-49.934816, -49.922324, -49.911616, -49.906262, -49.890796,-49.8875254,-49.8875254), 
    Waste = c(526, 350, 526, 469, 285, 433, 456)),class = "data.frame", row.names = c(NA, -7L))

#clusters
coordinates<-df[c("Latitude","Longitude")]
d<-as.dist(distm(coordinates[,2:1]))
fit.average<-hclust(d,method="average") 
k=3
clusters<-cutree(fit.average, k) 
nclusters<-matrix(table(clusters))  
df$cluster <- clusters 

#Create database df1
center<-matrix(nrow=k,ncol=2)
for(i in 1:k){
  center[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
                     weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
coordinates$cluster<-clusters 
center<-cbind(center,matrix(c(1:k),ncol=1)) 
df1<-as.data.frame(center)
colnames(df1) <-c("Latitude", "Longitude", "cluster")

#specific cluster and specific property
df_spec_clust <- df1[df1$cluster,]
df_spec_prop<-df[df$Property,]

#create map
roads = st_read("Test/regionbrazil.shp", quiet = TRUE) %>% 
  st_cast("LINESTRING")

# build sfnetwork
net = as_sfnetwork(roads, directed = FALSE) %>%
  activate("edges") %>%
  dplyr::mutate(weight = edge_length())

# routing
from = c(df_spec_clust[1, c("Longitude")], df_spec_clust[1, c("Latitude")])
to = c(df_spec_prop[4, c("Longitude")], df_spec_prop[4, c("Latitude")])
p1 = st_as_sf(data.frame(x = from[1], y = from[2]), coords = c("x", "y"), crs = st_crs(net))
p2 = st_as_sf(data.frame(x = to[1], y = to[2]), coords = c("x", "y"), crs = st_crs(net))
r = tidygraph::convert(net, to_spatial_shortest_paths, p1, p2)

# Extract the bbox for r 
bbox_r = st_as_sfc(r %>% activate(edges) %>% st_bbox())


# filter the net
small_net = st_filter(net, bbox_r)

# plot
plot1<-tm_shape(small_net %>% activate(edges) %>% st_as_sf()) +
  tm_lines() + 
  tm_shape(rbind(p1, p2)) + 
  tm_dots(col = "red", size = 0.5) + 
  tm_shape(r %>% activate(edges) %>% st_as_sf()) + 
  tm_lines(col = "red", lwd = 3)
plot1

Map generated by the code above

Second code

library(shiny)
library(rdist)
library(geosphere)
library(shinythemes)
library(sf)
library(tidygraph)
library(sfnetworks)
library(tmap)

#for the roads file
 download.file("https://github.com/JovaniSouza/JovaniSouza5/raw/master/Test.zip", "Test.zip")
 unzip("Test.zip")

function.cl<-function(df,k,Filter1,Filter2){
  
  #database df
  df <- structure(
    list(Property = c(1,2,3,4,5,6,7), Latitude = c(-24.779225, -24.789635, -24.763461, -24.794394, -24.747102,-24.781307,-24.761081),
         Longitude = c(-49.934816, -49.922324, -49.911616, -49.906262, -49.890796,-49.8875254,-49.8875254), 
         Waste = c(526, 350, 526, 469, 285, 433, 456)),class = "data.frame", row.names = c(NA, -7L))
  
  #clusters
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average") 
  clusters<-cutree(fit.average, k) 
  nclusters<-matrix(table(clusters))  
  df$cluster <- clusters 
  
  #Create database df1
  center<-matrix(nrow=k,ncol=2)
  for(i in 1:k){
    center[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
                  weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
  coordinates$cluster<-clusters 
  center<-cbind(center,matrix(c(1:k),ncol=1)) 
  df1<-as.data.frame(center)
  colnames(df1) <-c("Latitude", "Longitude", "cluster")
 
  # specific cluster and specific property
  df_spec_clust <- df1[df1$cluster==Filter1,]
  df_spec_prop<-df[df$Property==Filter2,]
  
 
  #create map
 
  roads = st_read("Test/regionbrazil.shp", quiet = TRUE) %>% 
    st_cast("LINESTRING")
  
  # build sfnetwork
  net = as_sfnetwork(roads, directed = FALSE) %>%
    activate("edges") %>%
    dplyr::mutate(weight = edge_length())
  
  # routing
  from = c(df_spec_clust[1, c("Longitude")], df_spec_clust[1, c("Latitude")])
  to = c(df_spec_prop[4, c("Longitude")], df_spec_prop[4, c("Latitude")])
  p1 = st_as_sf(data.frame(x = from[1], y = from[2]), coords = c("x", "y"), crs = st_crs(net))
  p2 = st_as_sf(data.frame(x = to[1], y = to[2]), coords = c("x", "y"), crs = st_crs(net))
  r = tidygraph::convert(net, to_spatial_shortest_paths, p1, p2)
  
  # Extract the bbox for r 
  bbox_r = st_as_sfc(r %>% activate(edges) %>% st_bbox())
  
  
  # filter the net
  small_net = st_filter(net, bbox_r)
  
  # plot
  plot1<-tm_shape(small_net %>% activate(edges) %>% st_as_sf()) +
    tm_lines() + 
    tm_shape(rbind(p1, p2)) + 
    tm_dots(col = "red", size = 0.5) + 
    tm_shape(r %>% activate(edges) %>% st_as_sf()) + 
    tm_lines(col = "red", lwd = 3)

  return(list(
    "Plot1" = plot1,
    "Data" =  df
  ))
}

ui <- bootstrapPage(
  navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
             "Cl", 
          tabPanel("",
           sidebarLayout(
             sidebarPanel(
               sliderInput("Slider", h5(""),
                           min = 2, max = 4, value = 3),
               selectInput("Filter1", label = h4("Select just one cluster"),""),
               selectInput("Filter2",label=h4("Select the cluster property"),""),
             ),
             mainPanel(
               tabsetPanel(
                 tabPanel("Map", plotOutput("Map1"))))
           ))))

server <- function(input, output, session) {
  
  Modelcl<-reactive({
    function.cl(df,input$Slider,input$Filter1,input$Filter2)
  })
  

  output$Map1 <- renderPlot({
    Modelcl()[[1]]
  })
  
  observeEvent(input$Slider, {
    abc <- req(Modelcl()$Data)
    updateSelectInput(session,'Filter1',
                      choices=sort(unique(abc$cluster)))
  }) 
  
  observeEvent(input$Filter1,{
    abc <- req(Modelcl()$Data) %>% filter(cluster == as.numeric(input$Filter1))
    updateSelectInput(session,'Filter2',
                      choices=sort(unique(abc$Property)))
  }) 
  
  
}

shinyApp(ui = ui, server = server)

Map generated but using leaflet package (It works)

library(shiny)
library(rdist)
library(geosphere)
library(shinythemes)
library(leaflet)
library(tidygraph)

function.cl<-function(df,k,Filter1,Filter2){
  
  #database df
  df <- structure(
    list(Property = c(1,2,3,4,5,6,7), Latitude = c(-24.779225, -24.789635, -24.763461, -24.794394, -24.747102,-24.781307,-24.761081),
         Longitude = c(-49.934816, -49.922324, -49.911616, -49.906262, -49.890796,-49.8875254,-49.8875254), 
         Waste = c(526, 350, 526, 469, 285, 433, 456)),class = "data.frame", row.names = c(NA, -7L))
  
  #clusters
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average") 
  clusters<-cutree(fit.average, k) 
  nclusters<-matrix(table(clusters))  
  df$cluster <- clusters 
  
  #Create database df1
  center<-matrix(nrow=k,ncol=2)
  for(i in 1:k){
    center[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
                  weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
  coordinates$cluster<-clusters 
  center<-cbind(center,matrix(c(1:k),ncol=1)) 
  df1<-as.data.frame(center)
  colnames(df1) <-c("Latitude", "Longitude", "cluster")
  
  #specify cluster and specific cluster and specific propertie
  df_spec_clust <- df1[df1$cluster==Filter1,]
  df_spec_prop<-df[df$Property==Filter2,]
  
  
  #color for map
  ai_colors <-c("red","gray","blue","orange","green","beige","darkgreen","lightgreen", "lightred", "darkblue","lightblue",
                "purple","darkpurple","pink", "cadetblue","white","darkred", "lightgray","black")
  clust_colors <- ai_colors[df$cluster]
  icons <- awesomeIcons(
    icon = 'ios-close',
    iconColor = 'black',
    library = 'ion',
    markerColor =  clust_colors)
  
  # create icon for map
  leafIcons <- icons(
    iconUrl = ifelse(df1$cluster,
                     
                     "https://image.flaticon.com/icons/svg/542/542461.svg"
    ),
    iconWidth = 30, iconHeight = 40,
    iconAnchorX = 25, iconAnchorY = 12)
  
  html_legend <- "<img src='https://image.flaticon.com/icons/svg/542/542461.svg'>"
  
# create map
  if(nrow(df_spec_clust)>0){
    clust_colors <- ai_colors[df_spec_clust$cluster]
    icons <- awesomeIcons(
      icon = 'ios-close',
      iconColor = 'black',
      library = 'ion',
      markerColor =  clust_colors)
    
  m1<-leaflet(df_spec_clust) %>% addTiles() %>% 
    addMarkers(~Longitude, ~Latitude, icon = leafIcons) %>%
    addAwesomeMarkers(leaflet(df_spec_prop) %>% addTiles(), lat=~df_spec_prop$Latitude, lng = ~df_spec_prop$Longitude, icon= icons,label=~cluster)

  for(i in 1:nrow(df_spec_clust)){
    df_line <- rbind(df_spec_prop[,c("Latitude","Longitude")],
                     df_spec_clust[i,c("Latitude","Longitude")])
    m1 <- m1 %>%
      addPolylines(data = df_line,
                   lat=~Latitude,
                   lng = ~Longitude,
                   color="red")
  }
  plot1<-m1} else plot1 <- NULL

  return(list(
    "Plot1" = plot1,
    "Data"= df
  ))
}

ui <- bootstrapPage(
  navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
             "Cl", 
             tabPanel("",
                      sidebarLayout(
                        sidebarPanel(
                          sliderInput("Slider", h5(""),
                                      min = 2, max = 4, value = 3),
                          selectInput("Filter1", label = h4("Select just one cluster"),""),
                          selectInput("Filter2",label=h4("Select the cluster property"),""),
                        ),
                        mainPanel(
                          tabsetPanel(
                            tabPanel("Map", uiOutput("Map1"))))
                      ))))

server <- function(input, output, session) {
  
  Modelcl<-reactive({
    function.cl(df,input$Slider,input$Filter1,input$Filter2)
  })
  
  output$Map1 <- renderUI({ 
    if(input$Filter1!="") 
      leafletOutput("Leaf1",width = "95%", height = "600") })

  output$Leaf1 <- renderLeaflet({
    req(Modelcl())[[1]]
  })
  
  
  observeEvent(input$Slider, {
    abc <- req(Modelcl()$Data)
    updateSelectInput(session,'Filter1',
                      choices=sort(unique(abc$cluster)))
  }) 
  
  observeEvent(input$Filter1,{
    abc <- req(Modelcl()$Data) %>% filter(cluster == as.numeric(input$Filter1))
    updateSelectInput(session,'Filter2',
                      choices=sort(unique(abc$Property)))
  }) 
  
  
}

shinyApp(ui = ui, server = server)

回答1:

You had a problem in selectInput. You were calling a function to get the Filter1 and Filter2, but the function needs Filter1 and Filter2 to execute. The following code executes, but it is slow in showing the map. Updating Filter1 and Filter2 gives an updated map, but it takes a few seconds. A more robust way to define it would be to define the dataframe in a separate function. That will help us define Filter1 and Filter2, and then we can pass on this information to the plot function. This will eliminate the chances of passing non-existing combinations which has been a problem sometimes.

library(shiny)
library(rdist)
library(geosphere)
library(shinythemes)
library(sf)
library(tidygraph)
library(sfnetworks)
library(tmap)

###for the roads file
download.file("https://github.com/JovaniSouza/JovaniSouza5/raw/master/Test.zip", "Test.zip")
unzip("Test.zip")

#database df
df <- structure(
  list(Property = c(1,2,3,4,5,6,7), Latitude = c(-24.779225, -24.789635, -24.763461, -24.794394, -24.747102,-24.781307,-24.761081),
       Longitude = c(-49.934816, -49.922324, -49.911616, -49.906262, -49.890796,-49.8875254,-49.8875254),
       Waste = c(526, 350, 526, 469, 285, 433, 456)),class = "data.frame", row.names = c(NA, -7L))

fun.clusters <- function(df,k){
  ## clusters
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average")
  clusters<-cutree(fit.average, k)
  nclusters<-matrix(table(clusters))
  df$cluster <- clusters
  return(df)
}

function.cl<-function(df,k,Filter1,Filter2){
  ## clusters
  coordinates<-df[c("Latitude","Longitude")]
  d<-as.dist(distm(coordinates[,2:1]))
  fit.average<-hclust(d,method="average")
  clusters<-cutree(fit.average, k)
  nclusters<-matrix(table(clusters))
  df$cluster <- clusters
  ##  Create database df1
  center<-matrix(nrow=k,ncol=2)
  for(i in 1:k){
    center[i,]<-c(weighted.mean(subset(df,cluster==i)$Latitude,subset(df,cluster==i)$Waste),
                  weighted.mean(subset(df,cluster==i)$Longitude,subset(df,cluster==i)$Waste))}
  coordinates$cluster<-clusters
  center<-cbind(center,matrix(c(1:k),ncol=1))
  df1<-as.data.frame(center)
  colnames(df1) <-c("Latitude", "Longitude", "cluster")

  # specific cluster and specific property
  if (is.null(Filter1)) {
    df_spec_clust <- unique(df1$cluster)
  }else { df_spec_clust <- df1[df1$cluster==Filter1,]}
  if (is.null(Filter1)) {
    df_spec_prop <- unique(df$Property)
  }else {df_spec_prop<-df[df$Property==Filter2,] }


  #create map

  roads = st_read("Test/regionbrazil.shp", quiet = TRUE) %>%
    st_cast("LINESTRING")

  # build sfnetwork
  net = as_sfnetwork(roads, directed = FALSE) %>%
    activate("edges") %>%
    dplyr::mutate(weight = edge_length())

  # routing
  from = c(df_spec_clust[1, c("Longitude")], df_spec_clust[1, c("Latitude")])
  to = c(df_spec_prop[1, c("Longitude")], df_spec_prop[1, c("Latitude")])
  p1 = st_as_sf(data.frame(x = from[1], y = from[2]), coords = c("x", "y"), crs = st_crs(net))
  p2 = st_as_sf(data.frame(x = to[1], y = to[2]), coords = c("x", "y"), crs = st_crs(net))
  r = tidygraph::convert(net, to_spatial_shortest_paths, p1, p2)

  # Extract the bbox for r
  bbox_r = st_as_sfc(r %>% activate(edges) %>% st_bbox())


  # filter the net
  small_net = st_filter(net, bbox_r)

  # plot
  plot1<-tm_shape(small_net %>% activate(edges) %>% st_as_sf()) +
    tm_lines() +
    tm_shape(rbind(p1, p2)) +
    tm_dots(col = "red", size = 0.5) +
    tm_shape(r %>% activate(edges) %>% st_as_sf()) +
    tm_lines(col = "red", lwd = 3)

  return(list(
    "Plot1" = plot1,
    "Data" =  df
  ))
}

ui <- bootstrapPage(
  navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
             "Cl",
             tabPanel("",
                      sidebarLayout(
                        sidebarPanel(
                          sliderInput("Slider", h5(""),
                                      min = 2, max = 4, value = 2),
                          selectInput("Filter1", label = h4("Select just one cluster"),
                                      choices=c(), selected=NULL),
                                      #choices=unique(df$cluster), selected=1),
                          selectInput("Filter2",label=h4("Select the cluster property"),
                                      choices=c(), selected=NULL)
                                      #choices=df$Property, selected=1)
                          
                        ),
                        mainPanel(
                          tabsetPanel(
                            tabPanel("Map", plotOutput("Map1"))
                            )
                        )
                      )

             )
  ))

server <- function(input, output, session) {
  
  dfa <- reactive({
    req(input$Slider)
    fun.clusters(df,input$Slider)
  })
  observeEvent(input$Slider, {

    #abc <- Modelcl()[[2]]
    abc <- dfa()
    updateSelectInput(session,'Filter1',
                      choices=sort(unique(abc$cluster)))
  })
  
  observeEvent(input$Filter1,{
    
    #abcd <- Modelcl()[[2]] %>% filter(cluster == as.numeric(input$Filter1))
    abcd <- dfa() %>% filter(cluster == as.numeric(input$Filter1))
    updateSelectInput(session,'Filter2',
                      choices=sort(unique(abcd$Property)))
  })

  Modelcl<-reactive({
    req(input$Slider,input$Filter1,input$Filter2)
    function.cl(df,input$Slider,input$Filter1,input$Filter2)
  })

  output$Map1 <- renderPlot({
    Modelcl()[[1]]
  })

}

shinyApp(ui = ui, server = server)

Output:

来源：https://stackoverflow.com/questions/63092033/issue-involving-map-generation-in-shiny