Shiny Leaflet Slow with HTML Labels - r

Question

I'm building a shiny app with a leaflet map that updates based on user selection. When I got to working on the labels for shiny, I noticed my performance dropped upon hitting my action button to refresh the map. It takes about 10 seconds
Digging into it, it takes 10 seconds regardless of its rendering 1 point or 3000 points. I've strangely been able to troubleshoot and find that if I remove the HTML function (to render an unformatted label) it instantly renders any number of points upon refresh.
Any ideas why rendering HTML labels takes so much longer than unformatted labels, regardless of the number of points?
global.R
# Packages
library(shiny)
library(sf)
library(leaflet)
library(maps)
library(dplyr)
library(htmltools)
# Initialize Data
print('Read in Data')
df <- read.delim("inst/Sample Data.csv", na.strings="")%>%
mutate(SurfaceHoleLongitude=as.numeric(substr(SurfaceHoleLongitude,2,length(SurfaceHoleLongitude))))%>%
filter(is.na(SurfaceHoleLongitude)==FALSE & is.na(SurfaceHoleLatitude)==FALSE)%>%
filter(SurfaceHoleLongitude!='NA' & SurfaceHoleLatitude!='NA')%>%
as.data.frame()
print('Create Labels')
df <- df %>%
mutate(pointlabel=paste0(`Lease.Name`,
"<br>", County,", ",State,
"<br> Operator: ", Operator,
"<br> Customer Name: ", Customer.Name,
"<br> Reservoir: ", Reservoir#,
# "<br>BOKF Exposure", `BOKF.Exposure`,
# "<br>DROI", `CEResults.DROI`,
# "<br>Outstanding Percent", `Outstanding Percent`
))%>%
rowwise()%>%
mutate(pointlabel=HTML(pointlabel))
print('Finished Making Labels')
app.R
# Tabset of hideable filters
parameter_tabs <- tabsetPanel(
id = "filterTabset",
type = "hidden",
tabPanel("Operator",
selectInput(
selected = 'BCE Mach III LLC',
inputId='Filter1', multiple = TRUE, label='Operator',
choices=df%>%select(Operator)%>%unique()%>%pull())),
tabPanel("Customer Name",
selectInput(
inputId='Filter2', multiple = TRUE, label='Customer Name',
choices=df%>%select(Customer.Name)%>%unique()%>%pull())),
tabPanel("Region",
selectInput(
inputId='Filter3', multiple = TRUE, label='Region',
choices=df%>%select(Region)%>%unique()%>%pull())),
tabPanel("County",
selectInput(
inputId='Filter4', multiple = TRUE, label='County',
choices=df%>%select(County)%>%unique()%>%pull())),
tabPanel("State",
selectInput(
inputId='Filter5', multiple = TRUE, label='State',
choices=df%>%select(State)%>%unique()%>%pull())),
tabPanel("Reservoir",
selectInput(
inputId='Filter6', multiple = TRUE, label='Reservoir',
choices=df%>%select(Reservoir)%>%unique()%>%pull()))
)
# Define UI for app
ui <- fluidPage(
# App title ----
titlePanel("Engineering Toolkit"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input 1: selectInput to choose a filter to appear in 2nd selectInput ----
selectInput(
inputId='FilterFieldSelection',
label='Filter Field',
choices=c('Operator','Customer Name','Region','County','State','Reservoir'),
selected = 'Operator',
multiple = FALSE#,
# selectize = TRUE,
# width = NULL,
# size = NULL
),
# Input 2: Specific selectInput to actually filter data
parameter_tabs,
# Input 3: Action button to load map
actionButton('button','Load Map')
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Map ----
leafletOutput("WellMap")
)
)
)
# Define Server
server <- function(input, output) {
# Reactive (lazy) expression for getting the data subsetted to what the user selected
filteredData <- reactive({
df%>%
# Filtering only occurs if the there is a selection (length>0)
filter(case_when(length(input$Filter1)>0 ~ Operator %in% input$Filter1,TRUE~1==1))%>%
filter(case_when(length(input$Filter2)>0 ~ Customer.Name %in% input$Filter2,TRUE~1==1))%>%
filter(case_when(length(input$Filter3)>0 ~ Region %in% input$Filter3,TRUE~1==1))%>%
filter(case_when(length(input$Filter4)>0 ~ County %in% input$Filter4,TRUE~1==1))%>%
filter(case_when(length(input$Filter5)>0 ~ State %in% input$Filter5,TRUE~1==1))%>%
filter(case_when(length(input$Filter6)>0 ~ Reservoir %in% input$Filter6,TRUE~1==1))
})
# Fire this when 1st selectInput "FilterOfFilters" is changed,
observeEvent(input$FilterFieldSelection, {
# Update choices of 2nd selectInput "SpecificFilter"
updateTabsetPanel(inputId = "filterTabset", selected = input$FilterFieldSelection)
})
# Output to UI
output$WellMap <-
# Output Leaflet map
renderLeaflet({
# Draw Map layers (not points)
counties.sf <- st_as_sf(map("county", plot = FALSE, fill = TRUE))
counties.latlong<-st_transform(counties.sf,crs = "+init=epsg:4326")
leaflet() %>%
addTiles() %>%
addPolygons(weight=1,fill=FALSE,color='black',data=counties.latlong) %>%
addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,label= ~pointlabel,
group = 'pointLayer',data=df%>%filter(Operator=='BCE Mach III LLC'),
radius=0.5,color='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
})
# Perform this only on button press
observeEvent(input$button,{
# Clear points on map
leafletProxy("WellMap", data = filteredData())%>%
clearGroup('pointLayer')%>%
# Update map with Updated Data
addCircles(lat= ~SurfaceHoleLatitude,lng= ~SurfaceHoleLongitude,
group = 'pointLayer',radius=0.5,label= ~pointlabel,
color ='red',opacity=0.5,fill=FALSE,stroke = TRUE,weight=5)
})
}
# Run App
shinyApp(ui = ui, server = server)

Answer 1

I heard data.table was faster than data.frame from tidyverse and so I passed my filteredData %>% data.table() and now it loads instantly again. Interesting, as a huge tidyverse fan