传单地图很慢

问：

我的传单地图渲染速度很慢。侧边栏会很快出现在屏幕上，但传单地图需要一些时间才能出现。我有一个指向以下链接的主要应用程序： https://iecprojects.shinyapps.io/IECProjectsMap 然后，我将主应用程序放在 iframe 中，以修复以下应用程序中任何机器的高度和宽度，如下所示： https://iecprojects.shinyapps.io/ProjectMap/

从此处查找 CSV 和 PNG 文件：https://github.com/akshaybholee/ProjectMapSupport

主应用脚本如下：

全球

library(shiny)
library(leaflet)
library(shinydashboard)
library(stringr)
library(sharepointr)
library(sqldf)
library(jsonlite)
library(dplyr)
library(tidyr)
library(mullenMisc)
library(htmltools)
library(plyr)
library(mapview)
library(leaflet.minicharts)
library(htmlwidgets)
library(rworldmap)
library(statnet.common)
library(leaflegend)
library(maptools)
library(spatialEco)


CountryInfo <-  read.csv("Country List.csv")

Region <-  read.csv("Regions.csv")

CountryInfo <- as.data.frame(CountryInfo)

jsfile <- "https://rawgit.com/rowanwins/leaflet-easyPrint/gh-pages/dist/bundle.js" 

elements <- read.csv("elements.csv")

names(elements) <- c("Ref No.", "Project Name","Country / Group of Countries", "Categorization for website")


elements <- elements %>% mutate(`Country / Group of Countries` = gsub('.*\\(',"",`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub(")","",`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('"',"",`Country / Group of Countries`))

elements <- elements %>% mutate(`Categorization for website` = gsub('.*\\(',"",`Categorization for website`))
elements <- elements %>% mutate(`Categorization for website` = gsub(")","",`Categorization for website`))
elements <- elements %>% mutate(`Categorization for website` = gsub('"',"",`Categorization for website`))


# Replace group of country with countries

elements <- elements %>% mutate(`Country / Group of Countries` = gsub('AfCFTA',Region$Countries[1],`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('EU27',Region$Countries[2],`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('PIFS',Region$Countries[3],`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('ASEAN',Region$Countries[4],`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('SADC',Region$Countries[5],`Country / Group of Countries`))
elements <- elements %>% mutate(`Country / Group of Countries` = gsub('COMESA',Region$Countries[6],`Country / Group of Countries`))


elements <- elements %>% 
  mutate(`Country / Group of Countries` = strsplit(as.character(`Country / Group of Countries`), ",")) %>% 
  unnest(`Country / Group of Countries`)

elements <- elements %>% mutate(`Country / Group of Countries` = trimws(`Country / Group of Countries`))

elements <- elements %>% 
  mutate(CountryName = as.character(`Country / Group of Countries`))

elements <- elements %>% 
  mutate(Category = as.character(`Categorization for website`))

elements <- as.data.frame(elements)



elements <- merge(x = elements, y = CountryInfo, by.x = "CountryName",by.y="Country", all.x = TRUE)


elements <- elements %>% 
  mutate(Category = strsplit(as.character(Category), ",")) %>% 
  unnest(Category)

elements <- elements %>% mutate(Category = trimws(Category))

elements <- elements %>% mutate(latitude = as.numeric(latitude)) %>% mutate(longitude = as.numeric(longitude))


elements <- elements[order(elements$CountryName, elements$Category),]


elements4 <- elements %>% select(`Ref No.`, Category)
elements4 <- unique(elements4)
elements4 <- elements4[order(elements4$`Ref No.`, elements4$Category),]
elements4 <- ddply(elements4, .(`Ref No.`), summarize,
                   Category=paste(Category,collapse=", "))



elements <- elements %>% filter(Category != "NA") #%>% filter(Project_Link !="NA")

CountryList <- as.data.frame(elements$CountryName)
names(CountryList) <- c('CountryName')


CountryList <- CountryList[order(CountryList$CountryName),]
CountryList <- as.data.frame(CountryList)


ProjectList <- as.data.frame(elements$`Project Name`)
names(ProjectList) <- c('ProjectName')


ProjectList <- ProjectList[order(ProjectList$ProjectName),]
ProjectList <- as.data.frame(ProjectList)

用户界面

ui <- dashboardPage(
  dashboardHeader(disable = TRUE
  ),
  dashboardSidebar(
    width = 275,
    tags$script(JS("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';")),
    sidebarMenu(
      checkboxGroupInput("catInput", tags$div(
        HTML('<font size="4.5"><b>Project Categories</b></font>')
      ), 
      choiceNames = list(HTML('<font size="3">International Business Strategy</font>'),
                         HTML('<font size="3">E-Commerce and Digital Trade</font>'),
                         HTML('<font size="3">Impact Assessment</font>'),
                         HTML('<font size="3">Policy and Negotiations</font>'),
                         HTML('<font size="3">COVID-19 Recovery</font>')), 
      choiceValues =
        list('International Business Strategy','E-Commerce and Digital Trade','Impact Assessment','Policy and Negotiations',
             'COVID-19 Recovery'),
      selected = NULL
      # list('International Business Strategy','E-Commerce and Digital Trade','Impact Assessment','Policy and Negotiations','COVID-19 Recovery')
      ),
      tags$div(
        HTML("<br/>")
      ),
      selectInput("Country", tags$div(
        HTML('<font size="4.5"><b>Country</b></font>')
      ),multiple = TRUE,
      choices = NULL),
      tags$div(
        HTML("<br/>")
      ),
      selectInput("Project", tags$div(
        HTML('<font size="4.5"><b>Project Titles</b></font>')
      ),multiple = TRUE,
      choices = NULL),
      checkboxGroupInput("PrintInput", "", 
                         choiceNames = 'Set Background to print', 
                         choiceValues ='Print'
      )
    ),
    tags$div(style="margin:10px;",HTML('<font size="4.5"><b>NOTE:</b></font><br/><font size="3">Hover on the shaded regions to see the number of projects implemented in the countries.</font>'))),
  
  dashboardBody(
    tags$script('window.onload = function() {
      function fixBodyHeight() {
        var el = $(document.getElementsByClassName("content-wrapper")[0]);
        var h = el.height();
        el.css("min-height", h + 50 + "px");
      };
      window.addEventListener("resize", fixBodyHeight);
      fixBodyHeight();
    };'),
    tags$head(tags$style(HTML('
                              .skin-blue .main-header .logo {
                              background-color: #3c8dbc;
                              }
                              .skin-blue .main-header .logo:hover {
                              background-color: #3c8dbc;
                              }
                             ')),
              tags$style("
        #Project ~ .selectize-control .option:nth-child(odd) {
          background-color: #3c8dbc;
          color: white;
        }
        "
              ),
              tags$style("
        #Project ~ .selectize-control .option:nth-child(even) {
          background-color: #79c3f4;
          color: black;
        }
        "
              ),
              tags$style(HTML("
      .shiny-output-error-validation {
        color: blue;
        font-size: 24px ;
        font-weight: bold;
      }
      
      label#Country-label.control-label {
      font-size: 18px;
      font-weight: bold;
      }
      
      label#Project-label.control-label {
      font-size: 18px;
      font-weight: bold;
      }
    "))),
    fillPage(
      tags$style(type = "text/css", "#map {height: calc(100vh - 30px) !important;}"),
      tags$head(tags$script(src = jsfile)),
      leafletOutput("map", width = "100%",height = "100%")
    )
    
  )
  
)

服务器

server <- function(input, output, session){
  
  
  map <- reactiveValues(dat = 0)
  map2 <- reactiveValues(dat = 0)
  
  
  updateSelectInput(session, "Country",
                    label = 'Country'
                    ,
                    choices = CountryList$CountryList
  )
  
  
  
  
  updateSelectInput(session, "Project",
                    label ='Project Titles'
                    ,
                    choices =ProjectList$ProjectList
  )
  
  
  
  elements1 <- reactive({ 
    print(input$catInput)
    elements <- elements %>% filter(Category %in% NVL(input$catInput,elements$Category) ,
                                    CountryName %in% NVL(input$Country,elements$CountryName) ,
                                    `Project Name` %in% NVL(input$Project,elements$`Project Name`)
    )
    
    
    
  })
  
  
  
  Polygon <- reactive({
    Polygon1 <- elements1() %>% select(latitude,longitude,Category,CountryName,ISO3,`Ref No.`)
    Polygon1 <- unique(Polygon1)
  })
  
  
  maprender <- reactive({
    filtered <- elements1()
    
    
    filteredPolygon <- Polygon() %>% select(latitude,longitude,CountryName,ISO3,`Ref No.`)
    filteredPolygon <- unique(filteredPolygon)
    
    
    
    
    logo <- makeIcon(iconUrl =  "https://raw.githubusercontent.com/akshaybholee/IECProjectsMap/master/FinalLogo.png", iconWidth = 300, iconHeight = 84)
    title <- makeIcon(iconUrl =  "https://raw.githubusercontent.com/akshaybholee/IECProjectsMap/master/Title.png", iconWidth = 500, iconHeight = 50)
    legend <- makeIcon(iconUrl =  "https://raw.githubusercontent.com/akshaybholee/IECProjectsMap/master/LegendGradient.PNG",iconWidth = 140, iconHeight = 57)
    
    
    filteredPolygon <- unique(filteredPolygon)
    el <- count(filteredPolygon, c("ISO3","CountryName"))
    
    
    el$labels <-
      with(
        el,
        paste("<strong>Country:</strong>", CountryName, "</br>", "<strong>Number of Projects:</strong>",freq) %>% lapply(htmltools::HTML)
      )
    

    sPDF <- joinCountryData2Map(el
                                ,joinCode = "ISO3"
                                ,nameJoinColumn = "ISO3") 
    
    sPDF <-
      sp.na.omit(sPDF, "CountryName", margin = 1)
    
    
    
    counting <- sqldf("select ISO3,count(`Ref No.`) numproj from filteredPolygon group by ISO3 ")
    print(length(unique(filteredPolygon$`Ref No.`)))
    
    if(max(counting$numproj) <= 8)
    {
      bin <- c(0,2,4,6,8)
    }
    else
    {
      bin = c(0,2,4,6,8,max(counting$numproj))
    }
    
    palette <- colorBin(c('#b1deff',
                          '#8ebcff',
                          '#6b9bdd',
                          '#477bba',
                          '#1c5d99'), 
                        bins = c(0,2,4,6,8,max(counting$numproj)))
    
    pal <-  colorNumeric(
      c('#b1deff', '#1c5d99'),
      domain = counting$numproj)
    
    factop <- function(x) {
      ifelse(is.na(x), 0, 1)
    }
    
    
    shiny::validate(
      if (nrow(filteredPolygon) == 0) {'There are no data for the selected filters.'}
      else NULL
    )
    
    
    
    
    map <- sPDF %>% leaflet( options = leafletOptions(attributionControl = FALSE,minZoom = 2)
    ) %>%
      addTiles(urlTemplate = "https://api.mapbox.com/styles/v1/bholee/ck7kcxtlh0ncj1inzq6mg1gh8/tiles/{z}/{x}/{y}@2x?access_token=pk.eyJ1IjoiYmhvbGVlIiwiYSI6ImNrN2tibG9pNzAwajMzbWw4ZnlpcDNqY2wifQ.o-qJAmRdkh-McoubI4E2DA") %>%
      setView(lng = 10,lat = 10, zoom = 2) %>%
      addPolygons( weight = ~factop(freq), fillColor = ~palette(freq),color="black", fillOpacity = ~factop(freq), highlight = highlightOptions(
        fillColor = '#1c5d99'),label= ~ labels,
        labelOptions = labelOptions(
          style = list("font-weight" = "normal", padding = "3px 8px"),
          textsize = "15px",
          direction = "auto"
        )) %>%
      addLegendNumeric(
        pal = pal,
        values = counting$numproj,
        position = 'bottomleft',
        title = 'Number of projects',
        orientation = 'horizontal',
        shape = 'rect',
        decreasing = FALSE,
        height = 10,
        width = 125
      )
    
    
    if (!is.null(input$PrintInput)) {map <- map %>%
      setView(lng = 0,lat = 70, zoom = 2.2) %>%
      setMaxBounds(lng1 = -60.0
                   , lat1 = -90.0
                   , lng2 = 90.0
                   , lat2 = 95.0) %>%
      addMarkers(lng = 132, lat = -51.5, icon = logo ) %>%
      addMarkers(lng = 102, lat = 82.5, icon = title ) %>%
      addMarkers(lng = -132, lat = -51.5, icon = legend ) %>%
      onRender( "function(el, x) {
            L.easyPrint({
              sizeModes: ['Current', 'A4Landscape', 'A4Portrait'],
              filename: 'ipcmap',
              exportOnly: true,
              hideControlContainer: true
            }).addTo(this);
            }"
      )} else {map}
  })
  
  
  output$map <- renderLeaflet({
    maprender()
  })
  
  
}

运行应用

shinyApp(ui, server)

我尝试使用 profvis 来查看应用程序在哪里运行缓慢，但我找不到任何东西。 请问，谁能帮我优化这个应用程序？

我正在使用免费版 shinyappsio 服务器。这是因为地图渲染速度变慢了吗？