Wastewater Surveillance Dashboard Tutorial Using R and R Shiny
Dustin T. Hill, Chris Dunham, David A. Larsen, and Mary B. Collins
2023-03-06
Guide
Introduction
Overview
This tutorial provides the source code for the New York State Wastewater Surveillance Network’s SARS-CoV-2 data dashboard. The tutorial goes through the major code chunks for processing the wastewater data, case data, and spatial data used in the R shiny application. Further, the tutorial discusses some of the techniques used to provide automatic data updates to the dashboard, how each figure was created, and how interactivity was coded into the dashboard. Portions of the source code are provided in this document. The source code is also available in an unabridged version at this GitHub page (insert link maybe). This tutorial represents the state of the dashboard on the date of publication and may not reflect the most up-to-date version of the code or dashboard. For the most up-to-date version, the authors direct you to the Git Hub page referenced above.
Please reference the following paper when using this resource:
Hill, D.T., Dunham, C., Larsen, D.A., and Collins, M.B. (2023). Operationalizing an open-source dashboard for communicating results of wastewater-based epidemiology. EarthArXiv. https://doi.org/10.31223/X57H3W
Outline
This tutorial has been divided into the following major sections:
Data and preprocessing - explanation of all data sources and storage methods, data manipulation and calculations.
User Interface - the source code (with annotations) for the user interface designed for the dashboard
Leaflet - the source code for the Leaflet map and Leaflet proxy used to display the spatial data
Trend graphs - the functions used to create the wastewater and case trend data
Interactivity between Leaflet and plots - a section with code and examples one how the interactivity was coded for between the map and trend plots
References and Resources - a list of references and useful resources that guided the creation of our dashboard.
R packages
To run the shiny app, the packages listed in Table 1 need to be installed and loaded. The shiny, shiny dashboard, and shiny dashboard plus packages are all required for creating the layout and basic interactive features. The data processing packages like dplyr and tidyr are necessary for data preprocessing when the app launches and the Leaflet packages
| Group | Package | How package is used |
|---|---|---|
| Shiny app support packages | shiny | Package for building the interactive web components for the shiny app. |
| shiny dashboard (Chang & Borges Ribeiro, 2021) | Provides layout for the application with a sidebar, title space, as well as making it easy to layout content in the body of the application with default features. | |
| shinydashboardPlus (Granjon, 2021) | Adds functions to enhance the shiny dashboard package. | |
| shinyBS (Bailey, 2022) | Adds mouse-over tooltips to figures, buttons, and features in the application. | |
| shinyjs (Attali, 2021) | Allows the app to read and use JavaScript applications including the use of toggle buttons and hiding content until a button is activated. | |
| shinyalert (Attali & Edwards, 2021) | Assists with html code within the application. | |
| shinycssloaders (Sail & Attali, 2020) | Adds loading icons for map and plots while the app is loading in the web browser and when generating new plots. | |
| htmltools (Cheng et al., 2021) | Use html code within the application. Used in creation of text sections and loading images. | |
| Data processing (spatial and nonspatial) | sf (Pebesma, 2018) | Load and manipulate spatial data. |
| aws.s3 (Leeper, 2020) | Read in data from Amazon Web Services S3 bucket. | |
| dplyr (Wickham et al., 2022) | Manipulate dataframes. | |
| tidyr (Wickham & Girlich, 2022) | Wrangling data into correct formats for the application. | |
| magrittr (Bache & Wickham, 2022) | Improves readability of code. | |
| purrr (Henry & Wickham, 2020) | Functions used to calculate rolling averages for case data. | |
| stringr (Wickham, 2019) | Edit and manipulate strings in the data. | |
| lubridate (Grolemund & Wickham, 2011) | Edit and manipulate dates to various formats. | |
| Leaflet packages | Leaflet (Cheng et al., 2022) | Creation of the interactive map on the main page. |
| Leaflet.extras (Karambelkar & Schloerke, 2018) | Enables Leaflet to work with plug-ins. | |
| Figure and table creation | ggplot2 | Creation of trend plots for wastewater and case data plots. |
| plotly (Sievert, 2020) | Wrapper functions turn ggplots into interactive features in the dashboard. | |
| gt (Iannone et al., 2022) | Creation of tables within the application. |
Data and Preprocessing
Wastewater data
The detection levels and two-week trend is assigned to the data as part of the preprocessing step. The methods used by the New York labs allows for classification of wastewater surveillance data for SARS-CoV-2 into three primary categories: Low, Moderate, and Substantial to High. These levels correspond to transmission levels previously described (Larsen et al. 2022). Two-week trends are calculated for each wastewater treatment plant using the following code:
# empty list to populate regression results within for loop
datalist2 <- list()
# loop through all current testing sites to get 2 week trends
for (i in base::unique(wastewater$SW_ID)) {
# select sewershed
df_reg <- wastewater %>%
filter(SW_ID == i)
### two week regression
# linear model comparing the trend value over time (intensity or raw gene
# copies)
model_2weeks <- lm((trend_value) ~ lubridate::as_date(Date_collected), data = df_reg) #
# pull out coefficients as indicators of rising or falling trend
df_reg$TwoWeekBet <- model_2weeks$coefficients[2]
# pull out R2 for confidence metric
df_reg$TwoWeekR2 <- summary(model_2weeks)$r.squared
df_reg$slope <- model_2weeks$coefficients[1]
# add the df to the list object
datalist2[[i]] <- df_reg
}
# convert the list to a df
wastewater.df.sewersheds <- do.call(rbind, datalist2)
# calculate genesee, allegany, and suffolk data separately
wastewater.df.sewersheds$TwoWeekBet <- wastewater.df.sewersheds$TwoWeekBet * 14 # 14 day changeAutomatic data updates
Data are stored on an Amazon Web Services (AWS) bucket. Data are loaded directly into the app from the bucket, and we added a function that has the app scan the AWS bucket for updates. When an update is pushed to the bucket, the app then reloads the data updating all the figures and maps.
The data are read into the app using the following code:
check_for_new_wws_data(key = aws_key, secret = aws_key)
wastewater <- readRDS("nys.wastewater.rds")The check for updates function is coded in as follows:
Sys.getenv('aws_bucket')
Sys.getenv('aws_key')
Sys.getenv('aws_secret')
check_for_new_wws_data = function(key, secret) {
bucket_contents =
get_bucket('nystatewws',
key = key,
secret = secret)
wws.data.rds = bucket_contents[lapply(bucket_contents,
function(x) x$Key == 'nys.wastewater.rds') %>%
unlist()
]
last_update = wws.data.rds$Contents$LastModified %>%
lubridate::as_datetime() %>%
lubridate::with_tz(tzone = 'America/New_York')
download_new_file = function() {
wws.data =
aws.s3::s3readRDS(object = 'nys.wastewater.rds',
bucket = 'nystatewws',
key = key,
secret = secret)
saveRDS(wws.data, file = 'nys.wastewater.rds')
}
if(!file.exists('nys.wastewater.rds')) {download_new_file()}
if(file.exists('nys.wastewater.rds') &
last_update > lubridate::as_datetime(file.info('nys.wastewater.rds')$mtime) %>%
lubridate::with_tz(tzone = 'America/New_York')
) {
download_new_file()
}
}The check for updates function is saved as a separate R file and stored in a folder named “R” that is put in the main Git Hub repository. See Figure 1 for a screenshot of the repository layout.
Git Hub main layout. The R folder contains the check for updates script.
NOTE: When setting up your dashboard, you will have to provide your own AWS key and secret in the appropriate code sections. You will want to store them in your environment.
Case data
Case data for New York state are downloaded through API from the state website at (DOH 2022). Three transformations are done to integrate the case data for the dashboard. First, test positivity is calculated by dividing the total number of positive tests by the total number of tests given on that day. Second, active cases are estimated by taking a rolling sum over 6 days. Third, the 7-day rolling average of active cases is calculated from the active case value. The dashboard provides users with 1) new case counts, 2) test positivity, and 3) 7-day rolling average of active cases.
# CASE DATA LOAD AND PREPROCESSING #
link <- paste("https://health.data.ny.gov/api/views/xdss-u53e/rows.csv?accessType=DOWNLOAD&bom=true&format=true&delimiter=%3B")
# case data from nys website
all.cases <- read.csv(link, header = TRUE, sep = ";")
colnames(all.cases)[1] <- "test_DATE"
# data prep (date variable change and make case data numeric)
all.cases$Date <- mdy(all.cases$test_DATE)
all.cases$Cases <- as.numeric(gsub(",", "", all.cases$New.Positives))
# add test positivity
all.cases$tests <- as.numeric(gsub(",", "", all.cases$Total.Number.of.Tests.Performed))
all.cases$Test_positivity <- all.cases$Cases/all.cases$tests
# add active cases
all.cases <- all.cases %>%
group_by(County) %>%
mutate(active.cases = purrr::map_dbl(Date, ~sum(Cases[between(Date, . - 6, .)])))
all.cases <- all.cases %>%
group_by(County) %>%
mutate(avg_active.cases = purrr::map_dbl(Date, ~mean(active.cases[between(Date,
. - 7, .)], na.rm = TRUE))) # 7 day average of active cases
# change st lawrence spelling
all.cases$County[all.cases$County == "St. Lawrence"] <- "St Lawrence"Spatial data
Spatial data including the sewersheds, NY county borders, and wastewater treatment plant point locations are loaded into the global environment. Copies of each file are stored in the Git Hub repository folder called “data” (see Figure 1).
##### ##### ##### ##### ##### Spatial data load ##### ##### ##### #####
# sewershed shapefile load
catchment <- st_read("Dashboard_Data/New York State sewersheds with saratoga.shp")
# change binghamton johnson city to influent for the dash to work
catchment$Method[catchment$SW_ID == "36007NY0024414C002"] <- "Influent"
catchment$Method[catchment$SW_ID == "36007NY0024414C003"] <- "Influent"
# identifying information for sewersheds (flat file of meta data)
sewer.id <- read.csv("Dashboard_Data/Sewer.IDs.csv", stringsAsFactors = FALSE)
# change binghamton johnson city for sewersheds
sewer.id$Method[sewer.id$SW_ID == "36007NY0024414C002"] <- "Influent"
sewer.id$Method[sewer.id$SW_ID == "36007NY0024414C003"] <- "Influent"
# load wwtp locations
wwtps <- read.csv("Dashboard_Data/NY_WWTP_DEC_List.csv", stringsAsFactors = FALSE)
wwtps <- wwtps %>%
filter(Plant.Type == "Municipal")
wwtps <- wwtps %>%
filter(SPDES.Perm %in% sewer.id$WWTP_ID)
wwtps$WWTP_ID <- wwtps$SPDES.Perm
# jitter the points
wwtps$Latitude <- jitter(wwtps$Latitude, factor = 1)
wwtps$Longitude <- jitter(wwtps$Longitude, factor = 1)
# ny county boundary shapefile
ny_counties <- st_read("Dashboard_Data/Counties_Shoreline.shp")User Interface
Shiny has two primary functions: the user interface or UI and the server. The UI is where all the buttons, plots, and other features that users interact with are placed and the server is where each of these items is generated and programmed. For more information on the basics of shiny and other resources, please see the References and Resources section for helpful links.
The shiny dashboard package comes standard with built-in features for a title bar, sidebar, and main body layout. Figure 2 shows the main layout for the NY SARS-2 dashboard.
Main dashboard page created by shinydashboard.
Generating the main dashboard page can be created using the code chunk below. Note that the content contains placeholders for you to fill in whatever is relevant for your dashboard. All of the explanatory text and supporting material must be added in the UI usually with HTML code.
# Define UI
ui <-
function(req){
dashboardPage(
dashboardHeader(
title = "Title", # title in the box at top of the page
titleWidth = 450), # this titlewidth is linked to the sidebar
# SIDEBAR CONTENT #
dashboardSidebar( width = 225,
# SIDEBAR MENU #
sidebarMenu(id = "sidebarid",
# STYLE ARGUMENT USES CSS CODE
style = "position:fixed; width:auto; overflow-x: clip;",
# keeps the sidebar content from scrolling
# MENU ITEMS THAT ARE TABS ON THE SIDEBAR
menuItem("State Dashboard", tabName = "dashboard",
icon = icon("dashboard")),
menuItem("Information", icon = icon("info"),
tabName = "Information"),
### CONDITIONAL PANEL FOR SIDEBAR BUTTONS ON MAINPAGE ###
conditionalPanel(
condition = 'input.sidebarid == "dashboard"'
) # close conditional panel
) # close sidebar menu
), # close dashboard sidebar argument
dashboardBody(
# specify new color theme
use_theme(mytheme),
useShinyjs(), #for shinyjs code to work
useShinyalert(), # Set up shinyalert
# CSS style arguments (e.g., font size)
# increase size of acutal map display based on window
tags$style(type = "text/css", "#NYBetaMap {height: calc(100vh - 80px) !important;}"),
tags$head(tags$style('.selectize-dropdown {z-index: 10000}')),
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(12,
p("Optional introduction text"),
)# end column argument
), # end fluid row opening paragraph
# VALUE BOXES WITH STATE SUMMARIES #
fluidRow(column(width = 12, h2(HTML(paste("Header", "<sup>", "1", "</sup>"))))),
fluidRow(
# number of counties actively reporting
valueBox( value = "value_here",
subtitle = "Participating counties",
color = "light-blue",
icon = icon("map")
),
# number of treatment plants reporting
valueBox( value = "value_here",
#subtitle = "Participating WWTPs",
subtitle = "Participating WWTPs",
color = "aqua",
icon = icon("water")
),
# population covered
valueBox( value = formatC(1000000),
subtitle = "Population covered",
color = "blue",
icon = icon("users"))
), # end fluid row summary boxes
), # end tab item
# another tab page
tabItem(tabName = "resources",
fluidRow(
column(12,
h3("Wastewater surveillance toolkit"),
br(),
p("Maybe we can provide resources here?")
)
)
),
)# end tab items plural
) # end dashboard body
)# end dashboardPage
} # close function for uiCustomizing Shiny Dashboard colors
The shiny dashboard package provides a default color scheme, but you can modify this using the package fresh. This package lets you modify the colors for the sidebar, title panel, and other features.
# define new dashboard theme
library(fresh)
# NEW DASHBOARD COLOR THEME #
# We can specify the colors here for the dashboard content theme
mytheme <- create_theme(
adminlte_color(
light_blue = "#698b69" # title bar color
),
adminlte_sidebar(
width = "225px",
dark_bg = "#68838b", # sidebar background color
dark_hover_bg = "#81A1C1", # selected page button color and hover button color
dark_color = "#2E3440" # unselected button text color,
),
adminlte_global(
content_bg = "#EEEE0", # main background color of dashboard body
box_bg = "#f0ffff", # dashboard boxes color
info_box_bg = "#D8DEE9" # info boxes color
)
)
# call the theme in the dashboard body function in the UI
dashboardBody(
# specify new color theme
use_theme(mytheme)
)Value boxes
Shiny dashboard allows developers many different ways to customize the look of their dashboard. One feature that is particularly nice for providing quick summaries are value boxes. These can contain static values showing a number with an associated icon or reactive values that are generated in the global environment or the server. Icons that are compatible with Shiny dashboard value boxes can be found from Glyphicon or Font Awesome.
valueBox(value = value_object, subtitle = "subtitle", color = "light-blue", icon = icon("map"))Drop-down menu (select input)
Shiny contains many interactive features. One that we use in our dashboard is “select input” that allows users to select an option from a drop-down to inititiate some reaction. In the SARS-2 dashboard, users can change the colors and legend on the map between two different options.
Select input options in the SARS-2 dashboard.
Like other Shiny content, the drop-down is created in the UI and the interactive output is programmed in the server portion of the code.
ui <- function(req) {
selectInput(inputId = "state_map_toggle", label = "Wastewater Metric", choices = c(`SARS-CoV-2 detection level` = "Alert_factor",
`Two week trend` = "Trend_factor"), selected = "SARS-CoV-2 detection level")
}
server <- function(input, output, session) {
# color palettes and levels for categorical variables create color level
# and value vectors for each factor variable
trend_colors <- c("blue", "dodgerblue3", "cornflowerblue", "lightskyblue", "papayawhip",
"khaki2", "orange", "orangered", "orangered4")
trend_levels <- c("< -75%", "-50% to -75%", "-25% to -50%", "-10% to -25%", "-10% to 10%",
" 10% to 25%", " 25% to 50%", " 50% to 75%", "> 75%")
alert_colors <- c("plum3", "darkorange2", "red")
alert_levels <- c("Low", "Moderate", "Substantial to High")
# change the color palette according to the select input choices
if (input$state_map_toggle == "Alert_factor") {
wastewater_pal <- colorFactor(alert_colors, levels = alert_levels, ordered = TRUE)
} else if (input$state_map_toggle == "Trend_factor") {
wastewater_pal <- colorFactor(trend_colors, levels = trend_levels, ordered = TRUE)
}
}
# Run the application
shinyApp(ui = ui, server = server)Leaflet
The NY SARS-2 dashboard has most of its functionality linked to the Leaflet map where users can focus on geographies or communities of interest to them. For example, users can click on sampling locations that represent a community of interest, or a county of interest to see trends and recent results for SARS-CoV-2 levels. Interaction with the Leaflet map displays information in popups and then when users scroll down the page (Figure 3), they can see trend graphs that are linked to the location that was selected.
Leaflet map with example popup text.
The Leaflet map is created with the following code chunk:
###### LEAFLET MAP OF NEW YORK #######
# create map for renders
nybetamap_preset <- leaflet(data = ny_counties, options = leafletOptions(
zoomControl = TRUE, maxZoom = 13, minZoom = 6,
dragging = TRUE)
) %>%
addMapPane("nymap", zIndex = 420) %>%
addMapPane("tiles", zIndex = 400) %>%
addMapPane("catchment", zIndex = 422) %>%
addMapPane("wwtps", zIndex = 435) %>%
addPolygons(data = ny_counties,
smoothFactor = 0.2, fillOpacity = 0.7,
fillColor = ~fact_pal(Participating),
stroke = TRUE,
color = "black",
weight = 1,
layerId = ny_counties$County,
options = pathOptions(pane = "nymap", clickable = TRUE),
label = ny_counties$County,
group = "County status",
highlightOptions = highlightOptions(color = "white", weight = 2,
bringToFront = TRUE)) %>%
addLegend(position = c("topright"), pal = fact_pal,
values = ~Participating, #
opacity = 0.7, #na.label = "NA",
title = "Surveillance status",
group = "County status",
layerId = "legend_participating") %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Base map",
options = c(pathOptions(pane = "tiles"))) %>%
addProviderTiles(providers$Stamen.TonerLines, group = "Base map",
options = c(providerTileOptions(opacity = 0.35),
pathOptions(pane = "tiles")))%>%
addProviderTiles(providers$Stamen.TonerLabels,group = "Base map",
options = pathOptions(pane = "tiles")) %>%
# counties appear through zoom levels 3 to 10 then become transparent
groupOptions("County status", zoomLevels = 3:10) %>%
# add counties to appear transparent at lower zoom
addMapPane("county_transparent", zIndex = 421) %>%
addPolygons(data = ny_counties,
smoothFactor = 0.2, #fillOpacity = 0.7,
fillColor = "transparent",
stroke = TRUE,
color = "black",
weight = 3,
layerId = ny_counties$FIPS_CODE,
group = "County transparent",
options = pathOptions(pane = "county_transparent",
clickable = FALSE) # cannot click counties
) %>%
# transparent counties appear at zoom levels 11 to 15
groupOptions("County transparent", zoomLevels = 11:15)Leaflet interactivity
The leaflet map can be manipulated using the mouse to “zoom” in to see smaller geographies. In addition, polygons and markers can be clicked to display more information.
Zooming in reveals more information about sampling locations including sewershed boundaries showing what communities are covered by surveillance.
Leaflet proxy
Layers on the Leaflet map for the wastewater treatment plants and sewersheds change color with the drop-down menu. This updates the map using Leaflet proxy.
# palette for county participation
fact_pal <- colorFactor(c("cyan4", "light blue", "black"),
levels = c("Currently reporting data",
"No current surveillance reported",
"Not currently participating"))
#### SHOW/HIDE ALERT LEVELS IF SELECT INPUT IS ON COMMUNITY TRANSMISSION ####
observe({
##### TWO COLOR FACTOR SETS BASED ON USER INPUT FOR WHAT PATTERN TO DISPLAY ####
if (input$state_map_toggle == "Alert_factor") {
wastewater_pal <- colorFactor(alert_colors,
levels = alert_levels, ordered = TRUE)
} else if (input$state_map_toggle == "Trend_factor") {
wastewater_pal <- colorFactor(trend_colors,
levels = trend_levels,
ordered = TRUE) }
proxy_map <- leafletProxy("NYBetaMap") %>%
# add new markers with the trend level
addCircleMarkers(data = wwtps_active , ~Longitude, ~Latitude,
fillColor =~wastewater_pal(eval(as.symbol(input$state_map_toggle))),
fillOpacity = 0.9,
color = "black", #
opacity = 0.5,
popup = paste("Facility:", (as.character(wwtps_active$Facility.N)), "<br>",
"Estimated population served:",
formatC(wwtps_active$pop_served_2, format = "d",
big.mark = ","),
"<br>",
"SARS-CoV-2 detection level: ",
wwtps_active$Alert_factor, "<br>",
"Current trend:",
ifelse(wwtps_active$TwoWeekBet > 0, "Increasing", "Decreasing"),
"<br>",
round(abs((wwtps_active$TwoWeekBet) ) * 100, 0), "percent",
ifelse(wwtps_active$TwoWeekBet > 0,
"increase", "decrease"), "in ",
ifelse(wwtps_active$trend_measure == "raw gene copies",
"natural logof raw gene copies",
"intensity") ," over two weeks", "<br>",
"Last sample",
lubridate::as_date(wwtps_active$Date_collected) %>%
format('%b %d, %Y')
),
label = ~paste(as.character(Facility.N)),
layerId = wwtps_active$WWTP_ID,
options = pathOptions(pane = "wwtps"),
group = "WWTPs"
) %>%
groupOptions("Catchments", zoomLevels = 11:15) %>%
addLegend(data = wwtps_active, position = c("topright"),
pal = wastewater_pal,
values = ~eval(as.symbol(input$state_map_toggle)),
opacity = 0.7,
title = ifelse(input$state_map_toggle == "Alert_factor",
"SARS-CoV-2 detection level",
"Two week trend"),
group = "WWTP",
layerId = "legend_wastewater"
)
})Trend graphs and tables
Most wastewater results that are relevant to users are presented in the Leaflet map, however trends and historical data can help interpret recent results. Trends are presented in two plots (raw gene copies and fecal-normalized wastewater intensity) in the graphs below the Leaflet map. These can be switched using a toggle on the left of the dashboard in the sidebar.
Trend graph and selection buttons.
Wastewater trends
Each graph is generated by a function that runs each time a location is clicked on the Leaflet map. Clicked location IDs are then used to filter dataframes to only have data for the clicked location and these dataframes are used to generate ggplots that are made interactive using Plotly.
###### WW PLOT OF INTENSITY FOR RECENT DATA #####
sewershed_ww_plot_function_log_recent <- function(plot_dataframe){
sewershed_sars_plot <- ggplot(plot_dataframe, aes (x = lubridate::as_date(Date),
y = IntensityDNA, group = 1,
text = paste0(
"Date: ", lubridate::as_date(Date) %>%
format('%b %d, %Y'), "<br>",
"Intensity ", round(IntensityDNA, 3),
"<br>",
"Fecal indicator: ", lab_method
)# end paste0 call
)# end aes call
) +
geom_rect(data = plot_dataframe %>%
filter(lubridate::as_date(Date) %in%
lubridate::as_date(wastewater.df.sewersheds$Date)),
aes(fill = factor(Trend_factor),
ymin = 0, ymax = max(plot_dataframe$IntensityDNA),
xmin = min(plot_dataframe$maxdate) - days(15),
xmax = max(plot_dataframe$maxdate)
),
color = "black",
alpha = 0.1)+
# points
geom_point(color="black") +
# smoothed line
geom_smooth(color="#69b3a2", se = TRUE,
span = ifelse(
length(plot_dataframe$Date) >4 & length(plot_dataframe$Date) <= 25, 0.75,
0.25),
method = ifelse(length(plot_dataframe$Date) <=4, "lm", "loess")) +
geom_point(data = plot_dataframe %>%
filter(lubridate::as_date(Date) %in%
lubridate::as_date(wastewater.df.sewersheds$Date)),
aes(x = lubridate::as_date(Date),
y = IntensityDNA), color = "black")+
ggplot2::geom_smooth(data = plot_dataframe %>%
filter(Date >= maxdate-days(15)),
aes(x = lubridate::as_date(Date),
y = IntensityDNA, color = factor(Trend_factor)),
method = "lm", se = FALSE)+
scale_color_manual(values = c("< -75%" = "blue", "-50% to -75%" = "dodgerblue3",
"-25% to -50%" = "cornflowerblue", "-10% to -25%"
= "lightskyblue", "-10% to 10%" = "papayawhip",
" 10% to 25%" = "khaki2", " 25% to 50%" = "orange",
" 50% to 75%" = "orangered", "> 75%" ="orangered4"))+
ylab("Intensity of SARS-CoV-2")+
xlab("")+
theme_minimal()+
theme(legend.position = "none")+
scale_y_continuous(#limits = c(0, NA),
expand = expansion(mult = c( 0, 1 ))) +
xlim(min(lubridate::as_date(plot_dataframe$Date)),
max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y'))
) +
scale_fill_manual(values = c("< -75%" = "blue", "-50% to -75%" = "dodgerblue3",
"-25% to -50%" = "cornflowerblue", "-10% to -25%"
= "lightskyblue", "-10% to 10%" = "papayawhip",
" 10% to 25%" = "khaki2", " 25% to 50%" = "orange",
" 50% to 75%" = "orangered", ">75%"="orangered4") ) +
annotate(geom = "text",
label = "Two week trend",
x = min(plot_dataframe$maxdate - days(7)),
y = median(plot_dataframe$IntensityDNA) + 0.1,
expand = c(1,1))
# change to plotly
sewershed_plotly_default <- ggplotly(sewershed_sars_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",plot_dataframe$County,
"County", "SARS-CoV-2 RNA intensity detection trend",sep = " "),
'<br>',
'<sup>',
paste("WWTP:", plot_dataframe$WWTP, ",",
ifelse(length(unique(plot_dataframe$Sewershed))==1,
plot_dataframe$Sewershed, "" ),
"sewershed", sep = " "),'</sup>','<br>'
)
)
)
sewershed_plotly_default <- sewershed_plotly_default %>%
style(hoverinfo = "skip", traces = 1) %>%
style(hoverinfo = "skip", traces = 2) %>%
style(hoverinfo = "skip", traces = 5) %>%
style(hoverinfo = "skip", traces = 6)%>%
style(hoverinfo = "skip", traces = 8)
return(sewershed_plotly_default)
}
default_ww_plot_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
output$sewershed_plotly_default_log <- renderPlotly(default_ww_plot_log)Case trends
Case data graphs are generated using a similar function.
# new cases
case_plot_function <- function(case_dataframe) {
case_county_plot <- ggplot(case_dataframe, aes(x = lubridate::as_date(Date),
y = Cases, group = 1, text = paste0("Date: ", lubridate::as_date(Date) %>%
format("%b %d, %Y"), "<br>", "New cases ", Cases) # end paste0 call
)) +
geom_bar(position = "dodge", stat = "identity") + theme(plot.background = element_blank()) +
theme(panel.background = element_blank()) + theme(panel.grid.major.y = element_line(color = "grey")) +
xlab("") + ylab("New cases (total)") + labs(caption = "") + theme(axis.text.x = element_text(hjust = 1),
text = element_text(size = 12)) + theme_minimal() + xlim(min(lubridate::as_date(case_dataframe$Date)),
max(lubridate::today(tzone = "America/New_York") %>%
format("%b %d, %Y")))
case_county_plot
case_plotly_default <- ggplotly(case_county_plot, tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>", case_dataframe$County, "County reported new cases (lab-confirmed)",
sep = " "), "<br>", "</sup>", "<br>")))
return(case_plotly_default)
}Summary tables
In addition to maps and graphs, we also include several tables in the dashboard for users to see summary information. These tables are created with the “gt” package that uses html code to produce output that can be customized.
Example table showing alert level summary information.
These tables can be created and stored as images that the Shiny app will render.
ui <- function(req) {
gt_output("alert_table") # generate the table in the UI
}
server <- function(input, output, session) {
# create and store table
table_alert <- percent_change_transmission %>%
gt() %>%
data_color(columns = "Detection level category", colors = scales::col_factor(alert_colors,
levels = alert_levels, ordered = TRUE)) %>%
tab_source_note(paste("Total sites with current data:", sum(percent_change_transmission$`Number of sites`))) %>%
tab_source_note(paste("Total number of wastewater sampling sites:", length(unique(ww_transmission$SW_ID)))) %>%
tab_style(style = cell_text(weight = "bold"), locations = list(cells_column_labels(gt::everything()))) %>%
# change font size
tab_options(table.font.size = 14)
# render table
output$alert_table <- render_gt(table_alert)
}
# Run the application
shinyApp(ui = ui, server = server)Interactivity between Leaflet and plots
Clicking the markers on the Leaflet map will update the trend graphs lower down on the dashboard page.
Leaflet and trend graph interaction.
Clicking on the Leaflet map is linked to other Shiny operations including updating the trend graphs to show data for the selected location. Each layer in the leaflet map has an ID “layerid”) that can be called using the function mapname_shape_click or mapname_marker_click. This will capture the ID of the layer and that can be used to filter dataframes or other functions.
observeEvent(input$NYBetaMap_shape_click, {
# capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
sewershed_plot <- wastewater.historic %>%
filter(County == click$id)
# stop if empty df
req(!is.na(sewershed_plot$trend_value))
# grab county data
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County) %>%
filter(Date >= min(sewershed_plot$Date))
case_plotly <- case_plot_function(case_dataframe = county.case)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
# return case plotly
if (!is.null(click$id)) {
output$county_case_plotly <- renderPlotly(case_plotly)
}
# return active plotly
if (!is.null(click$id)) {
output$county_active_plotly <- renderPlotly(active_plotly)
}
# return positivity plotly
if (!is.null(click$id)) {
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
}
})Closing thoughts
This tutorial provides the basic information on how the NY SARS-2 dashboard was designed using R Shiny and Leaflet for R. This tutorial is not exhaustive nor is it meant to replace existing courses or learning materials. It is meant to explain and outline the choices we made when developing our dashboard. Elements, function, and design choices can be adapted by readers for their own dashboards. Further, we recommend the reader review the reference and resource list. There are several helpful package documentations cited including for R Shiny Dashboard and NY SARS-2 Dashboard. We hope this tutorial will help others in their efforts to build and deploy dashboards for public health and other purposes. Full dashboard code is available at the following webpage: ___ and the live dashboard can be reached by visiting: NY SARS-2 Dashboard.
Full dashboard code
###################################
# NYS COVID WASTEWATER APP - 2022 #
###################################
###### BETA 5.0 NYC ######
#Version 5.2.1 - fix pop total
#### PACKAGE GROUPS ####
# shiny app support packages
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyBS)
library(shinyjs)
library(shinyalert)
library(shinycssloaders)
library(htmltools) # check this one
# data processing (spatial and nonspatial)
library(sf)
library(aws.s3)
library(dplyr)
library(tidyr)
library(magrittr)
library(purrr)
library(stringr)
library(lubridate)
# leaflet packages
library(leaflet)
library(leaflet.extras)
# figure and table creation
library(ggplot2)
library(plotly)
library(gt)
#------------------------------------------------------------------------------------------------------------------------------------------------------
########################
# LOAD WASTEWATER DATA #
########################
check_for_new_wws_data(key = aws_key, secret = aws_secret)
wastewater <- readRDS('nys.wastewater.rds')
##### ##### ##### ##### #####
# Spatial data load
##### ##### ##### ##### #####
# sewershed shapefile load
catchment <- st_read("Dashboard_Data/New York State sewersheds with saratoga.shp")
# change binghamton johnson city to influent for the dash to work
catchment$Method[catchment$SW_ID == "36007NY0024414C002"] <- "Influent"
catchment$Method[catchment$SW_ID == "36007NY0024414C003"] <- "Influent"
# identifying information for sewersheds (flat file of meta data)
sewer.id <- read.csv("Dashboard_Data/Sewer.IDs.csv",
stringsAsFactors = FALSE)
# change binghamton johnson city for sewersheds
sewer.id$Method[sewer.id$SW_ID == "36007NY0024414C002"] <- "Influent"
sewer.id$Method[sewer.id$SW_ID == "36007NY0024414C003"] <- "Influent"
# load wwtp locations
wwtps <- read.csv("Dashboard_Data/NY_WWTP_DEC_List.csv", stringsAsFactors = FALSE)
wwtps <- wwtps %>% filter(Plant.Type == "Municipal")
wwtps <- wwtps %>% filter(SPDES.Perm %in% sewer.id$WWTP_ID)
wwtps$WWTP_ID <- wwtps$SPDES.Perm
# jitter the points
wwtps$Latitude <- jitter(wwtps$Latitude, factor = 1)
wwtps$Longitude <- jitter(wwtps$Longitude, factor = 1)
# ny county boundary shapefile
ny_counties <- st_read("Dashboard_Data/Counties_Shoreline.shp")
#----------------------------------------------------------------------------------------------------------------------------------------------------
##### Data processing
# change to match CDC data labels
# column name fixes
wastewater$County <- wastewater$county
wastewater$SW_ID <- wastewater$sw_id
wastewater$Date_collected <- wastewater$sample_collect_date
# missing institution_type
wastewater$institution_type[wastewater$institution_type == ""] <- "community"
# County names need to match because the app is looking for the county name match
# fix st lawrence county
wastewater$County[wastewater$County == "St. Lawrence"] <- "St Lawrence"
# clean up some columns of data
# 1 remove word county in county column
wastewater$County <- str_remove(wastewater$County, " County")
# set county for village of clinton to Oneida
#wastewater$County[wastewater$County == "Village of Clinton"] <- "Oneida"
# drop village of clinton for now
wastewater <- wastewater %>% filter(SW_ID != "36065NY0021385001")
######## DUPLICATE DATA SITES BOTH IN CDC AND STATE PROGRAM, USE CDC DATA FOR NOW ####
# display quadrant Auburn (cayuga) data for now, they are also a CDC plant with methods comparison
wastewater_cayuga <- wastewater %>%
filter(County == "Cayuga" & lab_id == "Quadrant")
wastewater_n_cayuga <- wastewater %>%
filter(County != "Cayuga")
wastewater <- rbind(wastewater_cayuga, wastewater_n_cayuga)
# remove niagara luminultra data
wastewater_niagara <- wastewater %>%
filter(County == "Niagara" & lab_id == "UB-SUNY")
wastewater_n_niagara <- wastewater %>%
filter(County != "Niagara")
wastewater <- rbind(wastewater_niagara, wastewater_n_niagara)
##### ##### ##### ##### #####
# working with the date
##### ##### ##### ##### #####
df_Last_sample <- max(wastewater$Date_collected, na.rm = TRUE) #date of most recent sample, helps prevent losing too much old data
# Creating the maximum date by each sewershed ID #
wastewater <- wastewater %>%
dplyr::group_by(SW_ID) %>%
mutate(maxdate = max(Date_collected))
# rename date column
wastewater$Date <- wastewater$Date_collected
## GENERATING COPIES OF SARS 2 RNA IN WASTEWATER
# If SARS2 RNA was not detected, using a value of 1
# If SARS2 RNA was detected but not quantifiable, using a value of 3.5
# Calculating copies of SARS2 RNA #
wastewater$copies <- 3.5
wastewater$copies <- ifelse(!is.na(wastewater$pcr_target_avg_conc), as.numeric(as.character(wastewater$pcr_target_avg_conc)), wastewater$copies)
wastewater$copies <- ifelse(wastewater$sars_pos==0, 1, wastewater$copies)
wastewater$copies <- ifelse(is.na(wastewater$copies), as.numeric(as.character(wastewater$pcr_target_avg_conc)), wastewater$copies)
wastewater$copies <- ifelse(is.na(wastewater$copies), 1, wastewater$copies)
wastewater$copies[wastewater$pcr_target_avg_conc == 0] <- 1
wastewater$copies <- ifelse(wastewater$copies == 0, 1, wastewater$copies)
wastewater$copies[wastewater$copies < 1] <- 1
### STANDARDIZING COPIES OF SARS2 RNA IN WASTEWATER TO CRASSPHAGE ###
### IF MISSING INTENSITY, USE GENE COPIES FOR THE TREND ####
# crAssphage DNA
wastewater$IntensityDNA <- log(wastewater$copies)/log(wastewater$hum_frac_mic_conc)
# add allegany separately for now
allegany <- wastewater %>% filter(County == "Allegany")
allegany$trend_value <- log(allegany$copies)
allegany$trend_measure <- "raw gene copies"
# add genesee and orleans separately for now because they are adding pmmov later
go_health <- wastewater %>% filter(County == "Genesee" | County == "Orleans")
go_health$trend_value <- log(go_health$copies)
go_health$trend_measure <- "raw gene copies"
wastewater <- wastewater %>% filter(!County == "Genesee" & !County == "Orleans")
# add suffolk bergen point separately for now to prepare for gene copy change
suffolk <- wastewater %>% filter(County == "Suffolk")
suffolk$trend_value <- log(suffolk$copies)
suffolk$trend_measure <- "raw gene copies"
wastewater <- wastewater %>% filter(!County == "Suffolk")
# drop UB data that is missing intensity
wastewater_ub <- wastewater %>%
filter(lab_id == "UB-SUNY" & !is.na(IntensityDNA) & !County == "Allegany")
wastewater_n_ub <- wastewater %>%
filter(lab_id != "UB-SUNY"|is.na(lab_id))
# bind the ub data
wastewater <- rbind(wastewater_ub, wastewater_n_ub)
# add indicator variable for trend
wastewater$trend_value <- ifelse(is.na(wastewater$IntensityDNA), log(wastewater$copies), wastewater$IntensityDNA)
wastewater$trend_measure <- ifelse(is.na(wastewater$IntensityDNA), "raw gene copies", "intensity")
# nyc trend value and trend measure
nyc <- c("New York", "Bronx", "Queens", "Kings", "Richmond")
city <- wastewater %>% filter(county %in% nyc)
city$trend_value <- log(city$pcr_target_avg_conc)
city$trend_measure <- "raw gene copies"
wastewater <- wastewater %>% filter(!County %in% nyc)
# add allegany separately for now
wastewater <- rbind(wastewater, allegany, go_health, suffolk, city)
##### ADDITIONAL MINOR FIXES TO DATA #####
# add number of days since most recent sample to each sample
wastewater$days <- as.numeric(lubridate::as_date(wastewater$maxdate) - lubridate::as_date(wastewater$Date_collected))
# add fecal indicator for each lab
wastewater$lab_method <- ""
wastewater$lab_method[wastewater$lab_id == "Quadrant"] <- "crAssphage"
wastewater$lab_method[wastewater$lab_id == "A"] <- "PMMoV" # cdc luminultra
wastewater$lab_method[wastewater$lab_id == "B"] <- "PMMoV" # cdc luminultra for Niagara only
wastewater$lab_method[wastewater$lab_id == "UB-SUNY"] <- "PMMoV"
### FILTER DATA FOR COUNTIES TO EITHER DISPLAY OR NOT BASED ON STATUS ###
# remove hamilton for now since using grabs until we know more about their data
wastewater <- wastewater %>% filter(County != "Hamilton")
# mark all data for historical display
wastewater.historic <- wastewater
#----------------------------------------------------------------------------------------------------------------------------------------------------
### REMOVE HISTORIC DATA FOR SELECT SITES ###
# NOTE if adding the plotly data, see if can put these data back in here, or permanently remove from dashboard data
# remove historic data for erie county, display recent data from UB and provide link to county dash
ww.historic1 <- wastewater.historic %>% filter(County != "Erie")
ww.historic2 <- wastewater.historic %>% filter(County == "Erie")
ww.historic2 <- ww.historic2 %>% filter(Date > "2022-03-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove pre april steuben data
ww.historic1 <- wastewater.historic %>% filter(County != "Steuben")
ww.historic2 <- wastewater.historic %>% filter(County == "Steuben")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-04-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old oswego data
ww.historic1 <- wastewater.historic %>% filter(County != "Oswego")
ww.historic2 <- wastewater.historic %>% filter(County == "Oswego")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-12-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove pre state funding onondaga data
ww.historic1 <- wastewater.historic %>% filter(County != "Onondaga")
ww.historic2 <- wastewater.historic %>% filter(County == "Onondaga")
ww.historic2 <- ww.historic2 %>% filter(Date > "2022-01-15")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old orange county data
ww.historic1 <- wastewater.historic %>% filter(County != "Orange")
ww.historic2 <- wastewater.historic %>% filter(County == "Orange")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-04-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old madison data for now
ww.historic1 <- wastewater.historic %>% filter(County != "Madison")
ww.historic2 <- wastewater.historic %>% filter(County == "Madison")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-09-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove auburn upstream data
# sampling plan changes so, remove upstream samples
auburn_upstream <- c("36011NY0021903CCWW2", "36011NY0021903CCWW4", "36011NY0021903CCWW3")
ww.historic <- wastewater.historic %>% filter(!SW_ID %in% auburn_upstream)
# remove old cauyga data for now
ww.historic1 <- wastewater.historic %>% filter(County != "Cayuga")
ww.historic2 <- wastewater.historic %>% filter(County == "Cayuga")
ww.historic2 <- ww.historic2 %>% filter(Date > "2022-01-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old saratoga data
ww.historic1 <- wastewater.historic %>% filter(County != "Saratoga")
ww.historic2 <- wastewater.historic %>% filter(County == "Saratoga")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-04-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old monroe data
ww.historic1 <- wastewater.historic %>% filter(County != "Monroe")
ww.historic2 <- wastewater.historic %>% filter(County == "Monroe")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-12-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old albany data
ww.historic1 <- wastewater.historic %>% filter(County != "Albany")
ww.historic2 <- wastewater.historic %>% filter(County == "Albany")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-12-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old cortland data
ww.historic1 <- wastewater.historic %>% filter(County != "Cortland")
ww.historic2 <- wastewater.historic %>% filter(County == "Cortland")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-12-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old tompkins data
ww.historic1 <- wastewater.historic %>% filter(County != "Tompkins")
ww.historic2 <- wastewater.historic %>% filter(County == "Tompkins")
ww.historic2 <- ww.historic2 %>% filter(Date > "2021-12-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
# remove old warren data
ww.historic1 <- wastewater.historic %>% filter(County != "Warren")
ww.historic2 <- wastewater.historic %>% filter(County == "Warren")
ww.historic2 <- ww.historic2 %>% filter(Date > "2022-01-01")
wastewater.historic <- rbind(ww.historic1, ww.historic2)
#----------------------------------------------------------------------------------------------------------------------------------------------------
##########################
# SEWERSHED LEVEL TRENDS #
##########################
# Keeping all sewersheds with data within 15 days of its most recent sample for trend analysis
# they need two points within those days for analysis
wastewater <- wastewater.historic %>%
ungroup() %>%
filter(!is.na(SW_ID)) %>%
group_by(SW_ID) %>%
#set to last sample date per site
filter(Date_collected >= (maxdate - days(15))) %>%
#drop anyone that has less than 2 observations
filter(n() > 1) %>%
#drop the universities, apartments, and schools
filter(!institution_type == "university" | !institution_type == "Apartments" | !institution_type == "School"|
!institution_type == "other worksite"| !institution_type == "k12"| !institution_type == "higher ed dorm"|
!institution_type == "higher ed other" | is.na(institution_type)
) %>%
ungroup()
# make days column numeric
wastewater$days <- as.numeric(wastewater$days)
# remove sewersheds with no sw_id
wastewater <- wastewater %>% filter(!is.na(SW_ID))
# recent wastewater data object
wastewater_recent <- wastewater %>% filter(maxdate >= today()- days(15))
# add wwtp_id
wwtp_id_df <- sewer.id %>% dplyr::select(SW_ID, WWTP_ID)
wastewater_recent <- left_join(wastewater_recent, wwtp_id_df, by = c("SW_ID"))
# empty list to populate regression results within for loop
datalist2 <- list()
# loop through all current testing sites to get 2 week trends
for(i in base::unique(wastewater$SW_ID)){
# select sewershed
df_reg <- wastewater %>%
filter(SW_ID == i)
###
# two week regression
###
# linear model comparing the trend value over time (intensity or raw gene copies)
model_2weeks <- lm((trend_value) ~ lubridate::as_date(Date_collected), data = df_reg) #
# pull out coefficients as indicators of rising or falling trend
df_reg$TwoWeekBet <- model_2weeks$coefficients[2]
# pull out R2 for confidence metric
df_reg$TwoWeekR2 <- summary(model_2weeks)$r.squared
# add the df to the list object
datalist2[[i]] <- df_reg
}
# convert the list to a df
wastewater.df.sewersheds <- do.call(rbind, datalist2)
# calculate genesee, allegany, and suffolk data separately
wastewater.df.sewersheds$TwoWeekBet <- ifelse(wastewater.df.sewersheds$lab_id == "GO Health" | wastewater.df.sewersheds$County == "Allegany" | wastewater.df.sewersheds$County == "Suffolk",
wastewater.df.sewersheds$TwoWeekBet, wastewater.df.sewersheds$TwoWeekBet * 14) # 14 day change; beta is average change per day
# factor for trend instead of value - use for colors
wastewater.df.sewersheds$Trend_factor <- ""
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet < -0.75] <- "< -75%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet < -0.5 & wastewater.df.sewersheds$TwoWeekBet >= -0.75] <- "-50% to -75%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet < -0.25 & wastewater.df.sewersheds$TwoWeekBet >= -0.5] <- "-25% to -50%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet < -0.1 & wastewater.df.sewersheds$TwoWeekBet >= -0.25] <- "-10% to -25%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet <= 0.1 & wastewater.df.sewersheds$TwoWeekBet >= -0.1] <- "-10% to 10%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet <= 0.25 & wastewater.df.sewersheds$TwoWeekBet > 0.1] <- " 10% to 25%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet > 0.25 & wastewater.df.sewersheds$TwoWeekBet <= 0.50] <- " 25% to 50%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet > 0.5 & wastewater.df.sewersheds$TwoWeekBet <= 0.75] <- " 50% to 75%"
wastewater.df.sewersheds$Trend_factor[ wastewater.df.sewersheds$TwoWeekBet > 0.75] <- "> 75%"
# assign NA for trend if max date is over two weeks old
wastewater.df.sewersheds$Trend_factor <- ifelse(wastewater.df.sewersheds$maxdate < today() - days(15), NA, wastewater.df.sewersheds$Trend_factor)
# change to a factor
wastewater.df.sewersheds$Trend_factor <- factor(as.character(wastewater.df.sewersheds$Trend_factor), levels =
c("< -75%", "-50% to -75%", "-25% to -50%","-10% to -25%",
"-10% to 10%", " 10% to 25%", " 25% to 50%", " 50% to 75%", "> 75%"))
# drop county field from df_sewersheds
wastewater.df.sewersheds <- as.data.frame(wastewater.df.sewersheds) %>%
dplyr::select(-County)
# add ID information to wastewater.df.sewersheds*
sewer_id_recent <- sewer.id %>% dplyr::select(SW_ID, WWTP_ID)
# add date to the dataframe for recent data
wastewater.df.sewersheds$Date <- wastewater.df.sewersheds$Date_collected
wastewater.df.sewersheds <- left_join(wastewater.df.sewersheds, sewer_id_recent, by = c("SW_ID"))
# add trends to the historic data
wastewater_trends_only <- wastewater.df.sewersheds %>% filter(!duplicated(SW_ID)) %>%
dplyr::select(SW_ID, Trend_factor)
wastewater.historic <- left_join(wastewater.historic, wastewater_trends_only, by = "SW_ID")
# add identifying information for sewershed
wastewater.sewersheds <- left_join(wastewater.df.sewersheds, sewer.id, by = c("SW_ID"))
wastewater.sewersheds$Date <- wastewater.sewersheds$Date_collected
# drop city, state from wwtps
wwtps <- wwtps %>% dplyr::select(-City, -State)
# merge treatment plant stats to wwtp geolocations
wwtps <- left_join(wwtps, catchment, by = "WWTP_ID")
# merge trend information to identify active counties
ny_counties$County <- ny_counties$NAME
ww_county <- wastewater.sewersheds %>%
ungroup() %>%
group_by(County)%>%
arrange(desc(Date_collected)) %>%
#filter(!duplicated(CountyID))
slice(1) %>%
ungroup()
ny_counties <- left_join(ny_counties, ww_county, by = c("County"))
# add date
ny_counties$Date <- ny_counties$Date_collected
#----------------------------------------------------------------------------------------------------------------------------------------------------
########################################
# SEWERSHED MAP OBJECT FOR COUNTY MAPS #
########################################
# merge trend data to catchment
catchment.wwtp <- merge(catchment, wastewater.df.sewersheds, by = c("SW_ID"))
# subset for only the treatment plants, no upstream in this file
wwtp.map <- catchment.wwtp %>%
filter(Method == "Influent")%>%#missed some...go back and add when redo buffalo i think
filter(Date_collected == maxdate)
wwtp.map <- bind_rows(wwtp.map, catchment)
wwtp.map <- wwtp.map %>%
filter(Method == "Influent") %>%
filter(!duplicated(SW_ID))
# remove catchments that never collected data and are not currently
wwtp.map <- wwtp.map %>% filter(SW_ID %in% wastewater.historic$SW_ID)
# filter for only the columns we need: ID and beta from regression
wwtps_beta <- wwtp.map %>% dplyr::select(SW_ID, TwoWeekBet, Trend_factor, trend_measure, maxdate)
# add hamilton speculator plant to wwtps_beta list
wwtps_beta <- wwtps_beta %>% add_row(SW_ID = "36041NY0026484HCWWA", TwoWeekBet = NA, Trend_factor = NA)
# merge to get list of active plants and filter to remove missing data
wwtps_active <- left_join(wwtps_beta, wwtps, by = c("SW_ID")) %>%
# new population values to add up upstream locations
group_by(WWTP_ID) %>%
mutate(pop_served_2 = sum(POP2020, na.rm = TRUE))%>%
ungroup() %>%
filter(Method == "Influent") %>%
filter(!duplicated(SW_ID)) %>%
filter(!duplicated(Facility.N))
# active plants assign na to two week bet if na trend factor
wwtps_active$TwoWeekBet <- ifelse(is.na(wwtps_active$Trend_factor), NA, wwtps_active$TwoWeekBet)
# add beta to wwtps list to allow historic data to plot
wwtps <- left_join(wwtps, wwtps_beta, by = c("SW_ID"))
# ad date
wwtp.map$Date <- wwtp.map$Date_collected
#### COUNTY SHAPEFILE ADD PARTICIPATION STATUS ####
ny_counties$Participating <- ""
ny_counties$Participating <- ifelse(!ny_counties$NAME %in% wwtps_active$County, "Not currently participating", "Currently reporting data")
ny_counties$Participating[ny_counties$maxdate < today() - days(30)] <- "No current surveillance reported"
#ny_counties$Participating[ny_counties$County %in% wastewater.historic$County & is.na(ny_counties$TwoWeekBet)] <- "No current surveillance reported"
# add Hamilton county as participating
ny_counties$Participating[ny_counties$NAME == "Hamilton"] <- "Currently reporting data"
# add Chemung county as participating
#ny_counties$Participating[ny_counties$NAME == "Chemung"] <- "Currently reporting data"
# add westchester, genesee, orleans as participating
#ny_counties$Participating[ny_counties$NAME == "Westchester"] <- "No current surveillance reported"
# ny_counties$Participating[ny_counties$NAME == "Genesee"] <- "No current surveillance reported"
# ny_counties$Participating[ny_counties$NAME == "Orleans"] <- "No current surveillance reported"
#
# add row of each value
ny_counties <- ny_counties %>% add_row(Participating = "No current surveillance reported")
ny_counties$Participating <- factor(ny_counties$Participating, levels = c("Currently reporting data", "No current surveillance reported", "Not currently participating"))
# sewersheds within wwtp
metro.map <- catchment.wwtp %>%
filter(County == "Onondaga" & Method == "Manhole") %>%
filter(Date_collected == maxdate)
# shorten names
colnames(metro.map)[22] <- "Date"
colnames(metro.map)[41] <- "WeightRat"
#----------------------------------------------------------------------------------------------------------------------------------------------------
## TRANSFORM ALL SPATIAL DATA TO SAME COORDINATE SYSTEM ##
ny_counties_2 <- ny_counties %>%
dplyr::select(County, TwoWeekBet)
ny_counties <- st_transform(
ny_counties,
crs = st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
)
wwtp.map <- st_transform(
wwtp.map,
crs = st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")
)
# merge historic data with sw id info
wastewater.historic <- left_join(wastewater.historic, sewer.id, by = c("SW_ID", "County"))
#----------------------------------------------------------------------------------------------------------------------------------------------------
##### ADD DETECTION LEVEL MAGNITUDE ####
# remove wwtps that never collected data
wwtps <- wwtps %>% filter(WWTP_ID %in% wastewater.historic$WWTP_ID)
# add factor variable for detection of gene copies by group, this we can add for color coding later if we choose
wastewater.historic$copies_factor <- "No data"
wastewater.historic$copies_factor[wastewater.historic$copies <= 3.5] <- "Detected, <LOQ"
wastewater.historic$copies_factor[wastewater.historic$copies == 1] <- "Not detected"
wastewater.historic$copies_factor[wastewater.historic$copies > 3.5] <- "Quantifiable detection"
# assign gene copy factor levels to UB data
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc <=1 & wastewater.historic$lab_id == "UB-SUNY"] <- "Detected, <LOQ"
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc == 0 & wastewater.historic$lab_id == "UB-SUNY"] <- "Not detected"
# assign gene copy factor levels to Genesee data
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc <=4 & wastewater.historic$lab_id == "GO Health"] <- "Detected, <LOQ"
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc == 0 & wastewater.historic$lab_id == "GO Health"] <- "Not detected"
# assign gene copy factor levels to nyc data
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc <=0.59 & wastewater.historic$lab_id == "NYC"] <- "Detected, <LOQ"
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc <= 0.18 & wastewater.historic$lab_id == "NYC"] <- "Not detected"
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc > 0.59 & wastewater.historic$lab_id == "NYC"] <- "Quantifiable detection"
# turn into a factor variable
wastewater.historic$copies_factor <- factor(as.character(wastewater.historic$copies_factor), levels = c("No data", "Not detected", "Detected, <LOQ",
"Quantifiable detection"))
#### TRANSMISSION LEVEL ESTIMATE BASED ON LAST THREE DATA POINTS ####
# sort by date to select most recent 3 samples
ww_transmission <- wastewater.historic %>%
filter(Date_collected >= (df_Last_sample - days(25))) %>%
ungroup() %>%
group_by(SW_ID) %>%
arrange(desc(Date_collected)) %>%
slice(1:3) %>%
ungroup()
# add factor variable from copies_factor for basic CDC transmission level using highest measurement from last three data points
ww_transmission$Alert_factor <- "No data"
ww_transmission$Alert_factor[ww_transmission$copies <= 1] <- "Low"
ww_transmission$Alert_factor[ww_transmission$copies <= 3.5 & ww_transmission$copies > 1] <- "Moderate"
ww_transmission$Alert_factor[ww_transmission$copies > 3.5] <- "Substantial to High"
# assign alert factor for UB sites based on the new categories
wastewater.historic$copies_factor[wastewater.historic$pcr_target_avg_conc == 0 & wastewater.historic$lab_id == "UB-SUNY"] <- "Not detected"
ww_transmission$Alert_factor[ww_transmission$copies <1 & ww_transmission$lab_id == "UB-SUNY" & ww_transmission$Date_collected >= "2022-04-17"] <- "Low"
ww_transmission$Alert_factor[ww_transmission$copies <4 & ww_transmission$copies >=1 & ww_transmission$lab_id == "UB-SUNY" & ww_transmission$Date_collected >= "2022-04-17"] <- "Moderate"
ww_transmission$Alert_factor[ww_transmission$copies >=4 & ww_transmission$lab_id == "UB-SUNY" & ww_transmission$Date_collected >= "2022-04-17"] <- "Substantial to High"
# assign NA for points with max date not within last fifteen days
ww_transmission$Alert_factor <- ifelse(ww_transmission$maxdate < today() - days(15), NA, ww_transmission$Alert_factor)
# change to factor
ww_transmission$Alert_factor <- factor(as.character(ww_transmission$Alert_factor), levels = c("No data", "Low", "Moderate",
"Substantial to High"))
# select top detection level of the most recent three samples
ww_transmission <- ww_transmission %>%
group_by(SW_ID) %>%
arrange(desc(Alert_factor)) %>%
slice(1) %>%
ungroup()
# select columns and merge back into wastewater_historic
ww_transmission <- ww_transmission %>% dplyr::select(SW_ID, Alert_factor)
wastewater.historic <- left_join(wastewater.historic, ww_transmission, by = c("SW_ID"))
# add gene copy detection level to active wwtp map
wwtp_copies <- wastewater.historic %>%
filter(Method == "Influent") %>%
group_by(SW_ID) %>%
arrange(desc(Date_collected)) %>%
slice(1) %>%
ungroup() %>%
dplyr::select(SW_ID, WWTP_ID, copies_factor, Date_collected, Alert_factor)
# merge in copies for alert factor data
wwtps_active <- left_join(wwtps_active, wwtp_copies, by = c("WWTP_ID"))
# add empty rows with all values
wwtps_active <- wwtps_active %>%
add_row(Trend_factor = "< -75%", Alert_factor = "Low") %>%
add_row(Trend_factor = "-50% to -75%", Alert_factor = "Moderate") %>%
add_row(Trend_factor = "-25% to -50%", Alert_factor = "Substantial to High") %>%
add_row(Trend_factor = "-10% to -25%") %>%
add_row(Trend_factor = "-10% to 10%") %>%
add_row(Trend_factor = " 10% to 25%") %>%
add_row(Trend_factor = " 25% to 50%") %>%
add_row(Trend_factor = " 50% to 75%") %>%
add_row(Trend_factor = "> 75%")
# change to a factor
wwtps_active$Trend_factor <- factor(as.character(wwtps_active$Trend_factor), levels =
c( "< -75%", "-50% to -75%", "-25% to -50%","-10% to -25%",
"-10% to 10%", " 10% to 25%", " 25% to 50%", " 50% to 75%", "> 75%"))
wwtp.map <- left_join(wwtp.map, wwtp_copies, by = c("SW_ID"))
#----------------------------------------------------------------------------------------------------------------------------------------------------
###############################################
# SUMMARY STATS PREPROCESSING #
###############################################
# number of counties
t <- as.data.frame(table(ny_counties$Participating))
active_counties <- t %>% filter(Var1 == "Currently reporting data")
# number of treatment plants
active_plants <- wastewater.historic %>%
filter(Date_collected >= today() - days(31)) %>%
filter(!duplicated(WWTP_ID))
# plants only, no upstream
active_plant_list <- wwtps %>% filter(WWTP_ID %in% active_plants$WWTP_ID) %>%
filter(Method == "Influent")
# remove duplicate influents
r <- active_plant_list %>% filter(!SW_ID %in% active_plants$sw_id)
active_plant_list <- active_plant_list %>% filter(!SW_ID %in% r$SW_ID)
# add one plant because of hamilton
active_plants_value <- length(unique(active_plant_list$Facility.N)) +1
# population
population <- sum(active_plant_list$POP2020, na.rm = TRUE)
#----------------------------------------------------------------------------------------------------------------------------------------------------
##### COLOR PALETTES AND VALUES FOR FACTOR VARIABLES #####
# create color level and value vectors for each factor variable
trend_colors <- c("blue", "dodgerblue3", "cornflowerblue", "lightskyblue", "papayawhip", "khaki2", "orange", "orangered", "orangered4")
trend_levels <- c("< -75%", "-50% to -75%", "-25% to -50%","-10% to -25%",
"-10% to 10%", " 10% to 25%", " 25% to 50%", " 50% to 75%", "> 75%")
alert_colors <- c("plum3", "darkorange2", "red")
alert_levels <- c("Low", "Moderate", "Substantial to High")
#----------------------------------------------------------------------------------------------------------------------------------------------------
#######################################
# SEWERSHED LEVEL PREVIOUS CATEGORIES #
#######################################
#### TABLE 1 DETECTION LEVEL CATEGORY CHANGE ####
# create second max date for previous week's trend
wastewater.historic$maxdate_previous <- max(wastewater.historic$Date_collected) - days(7)
# remove recent data then filter for previous weeks data
ww_transmission_previous <- wastewater.historic %>%
filter(Date_collected < today() - days(15)) %>% # remove recent week of data, old was 7
filter(Date_collected >= maxdate_previous - days(31)) %>% # keep two weeks of data from previous weeks, old was 25
ungroup() %>%
group_by(SW_ID) %>%
arrange(desc(Date_collected)) %>%
slice(1:3) %>%
ungroup()
# select top detection level of the three samples
ww_transmission_previous <- ww_transmission_previous %>%
group_by(SW_ID) %>%
arrange(desc(copies)) %>%
slice(1) %>%
ungroup()
# add factor variable from copies_factor for basic CDC transmission level using highest measurement from last three data points
ww_transmission_previous$Alert_factor <- "No data"
ww_transmission_previous$Alert_factor[ww_transmission_previous$copies <= 1] <- "Low"
ww_transmission_previous$Alert_factor[ww_transmission_previous$copies <= 3.5 & ww_transmission_previous$copies > 1] <- "Moderate"
ww_transmission_previous$Alert_factor[ww_transmission_previous$copies > 3.5] <- "Substantial to High"
# assign NA for points with max date not within last fifteen days
ww_transmission_previous$Alert_factor <- ifelse(ww_transmission_previous$maxdate < today() - days(15), NA, ww_transmission_previous$Alert_factor)
# change to factor
ww_transmission_previous$Alert_factor <- factor(as.character(ww_transmission_previous$Alert_factor), levels = c("No data", "Low", "Moderate",
"Substantial to High"))
# make table of current and previous dat
current_transmission_df <- as.data.frame(table(ww_transmission$Alert_factor))
colnames(current_transmission_df) <- c("Alert_factor", "Count_current")
previous_transmission_df <- as.data.frame(table(ww_transmission_previous$Alert_factor))
colnames(previous_transmission_df) <- c("Alert_factor", "Count_previous")
# merge
percent_change_transmission <- left_join(previous_transmission_df, current_transmission_df, by = "Alert_factor")
# add percent of sites
percent_change_transmission$percent_of_sites <- round( (percent_change_transmission$Count_current / sum(percent_change_transmission$Count_current) ) * 100, 0)
percent_change_transmission$percent_of_sites <- paste(percent_change_transmission$percent_of_sites, "%", sep = "")
# calculate category change in last seven days
percent_change_transmission$cat_change_7_days <- round( (( percent_change_transmission$Count_current - percent_change_transmission$Count_previous ) / percent_change_transmission$Count_previous) * 100, 0)
# change infinity to NA
percent_change_transmission$cat_change_7_days[is.infinite(percent_change_transmission$cat_change_7_days)] <- NA
percent_change_transmission$cat_change_7_days <- ifelse(is.na(percent_change_transmission$cat_change_7_days), NA, paste(percent_change_transmission$cat_change_7_days, "%", sep=""))
# reorder to match CDC and drop unnecessary columns
percent_change_transmission <- percent_change_transmission %>%
dplyr::select(Alert_factor, Count_current, percent_of_sites, cat_change_7_days)
# change column names to be more readable
colnames(percent_change_transmission) <- c("Detection level category", "Number of sites", "Percent of sites", "Category change in the last 15 days")
# create and store table 2
table_alert <- percent_change_transmission %>% gt() %>%
data_color(
columns = "Detection level category",
colors = scales::col_factor(alert_colors,
levels = alert_levels, ordered = TRUE)
)%>%
tab_source_note(paste("Total sites with current data:", sum(percent_change_transmission$`Number of sites`))) %>%
tab_source_note(paste("Total number of wastewater sampling sites:", length(unique(ww_transmission$SW_ID))))%>%
tab_style(style = cell_text(weight = "bold"),
locations = list(
cells_column_labels(gt::everything())
))%>%
# change font size
tab_options(table.font.size = 14)
#### TABLE 2 CATEGORY CHANGE IN TREND ####
# select ww data from previous 15 day period
wastewater <- wastewater.historic %>%
ungroup() %>%
filter(!is.na(SW_ID)) %>%
group_by(SW_ID) %>%
filter(Date_collected < today() - days(15)) %>% # remove recent week of data (old was 7)
filter(Date_collected >= maxdate_previous - days(21)) %>% # keep two weeks of data from previous weeks (old was 15)
filter(n() > 1) %>% #drop anyone that has less than 2 observations
filter(!institution_type == "university" | !institution_type == "Apartments" | !institution_type == "School"|
!institution_type == "other worksite"| !institution_type == "k12"| !institution_type == "higher ed dorm"|
!institution_type == "higher ed other" | is.na(institution_type)
) %>% #drop the universities, apartments, and schools
ungroup()
# make days column numeric
wastewater$days <- as.numeric(wastewater$days)
# empty list to populate regression results within
datalist2 <- list()
# remove sewersheds with no sw_id
wastewater <- wastewater %>% filter(!is.na(SW_ID))
# loop through all current testing sites to get 2 week trends
for(i in base::unique(wastewater$SW_ID)){
# select sewershed
df_reg <- wastewater %>%
filter(SW_ID == i)
###
# two week regression
###
# linear model comparing the trend value over time (intensity or raw gene copies)
model_2weeks <- lm((trend_value) ~ lubridate::as_date(Date_collected), data = df_reg) #
# pull out coefficients as indicators of rising or falling trend
df_reg$TwoWeekBet <- model_2weeks$coefficients[2]
# pull out R2 for confidence metric
df_reg$TwoWeekR2 <- summary(model_2weeks)$r.squared
# add the df to the list object
datalist2[[i]] <- df_reg
}
# convert the list to a df
wastewater.df.previous <- do.call(rbind, datalist2)
wastewater.df.previous$TwoWeekBet <- ifelse(wastewater.df.previous$lab_id == "GO Health", wastewater.df.previous$TwoWeekBet, wastewater.df.previous$TwoWeekBet * 14) # 14 day change; beta is average change per day
# try factor for trend instead of value - use for colors
wastewater.df.previous$Trend_factor <- ""
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet < -0.75] <- "< -75%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet < -0.5 & wastewater.df.previous$TwoWeekBet >= -0.75] <- "-50% to -75%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet < -0.25 & wastewater.df.previous$TwoWeekBet >= -0.5] <- "-25% to -50%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet < -0.1 & wastewater.df.previous$TwoWeekBet >= -0.25] <- "-10% to -25%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet <= 0.1 & wastewater.df.previous$TwoWeekBet >= -0.1] <- "-10% to 10%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet <= 0.25 & wastewater.df.previous$TwoWeekBet > 0.1] <- " 10% to 25%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet > 0.25 & wastewater.df.previous$TwoWeekBet <= 0.50] <- " 25% to 50%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet > 0.5 & wastewater.df.previous$TwoWeekBet <= 0.75] <- " 50% to 75%"
wastewater.df.previous$Trend_factor[ wastewater.df.previous$TwoWeekBet > 0.75] <- "> 75%"
# assign NA for trend if max date is over two weeks old
wastewater.df.previous$Trend_factor <- ifelse(wastewater.df.previous$maxdate < today() - days(15), NA, wastewater.df.previous$Trend_factor)
# change to a factor
wastewater.df.previous$Trend_factor <- factor(as.character(wastewater.df.previous$Trend_factor), levels =
c("< -75%", "-50% to -75%", "-25% to -50%","-10% to -25%",
"-10% to 10%", " 10% to 25%", " 25% to 50%", " 50% to 75%", "> 75%"))
wastewater_previous <- wastewater.df.previous %>% filter(!duplicated(SW_ID))
# MAKE A TABLE OF COUNTS FOR PREVIOUS TREND AND FOR ACTIVE TREND #
previous_trend_df <- as.data.frame(table(wastewater_previous$Trend_factor))
colnames(previous_trend_df) <- c("Trend_factor", "Count_previous")
active_trend_df <- as.data.frame(table(active_plants$Trend_factor))
colnames(active_trend_df) <- c("Trend_factor", "Count_current")
# merge together
percent_change_trend <- left_join(previous_trend_df, active_trend_df, by = "Trend_factor")
# add percent of sites
percent_change_trend$percent_of_sites <- round( (percent_change_trend$Count_current / sum(percent_change_trend$Count_current) ) * 100, 0)
percent_change_trend$percent_of_sites <- paste(percent_change_trend$percent_of_sites, "%", sep = "")
# calculate category change in last seven days
percent_change_trend$cat_change_7_days <- round( (( percent_change_trend$Count_current - percent_change_trend$Count_previous ) / percent_change_trend$Count_previous) * 100, 0)
# change infinity to NA
percent_change_trend$cat_change_7_days[is.infinite(percent_change_trend$cat_change_7_days) ] <- NA
percent_change_trend$cat_change_7_days <- ifelse(is.na(percent_change_trend$cat_change_7_days), NA, paste(percent_change_trend$cat_change_7_days, "%", sep = ""))
# reorder to match CDC and drop unnecessary columns
percent_change_trend <- percent_change_trend %>%
dplyr::select(Trend_factor, Count_current, percent_of_sites, cat_change_7_days)
# change column names
colnames(percent_change_trend) <- c("Two-week trend category", "Number of sites", "Percent of sites", "Category change in the last 15 days")
# create and store Table 1
table_trend <- percent_change_trend %>% gt() %>%
data_color(
columns = "Two-week trend category",
colors = scales::col_factor(trend_colors,
levels = trend_levels,
ordered = TRUE)
)%>%
tab_source_note(paste("Total sites with current data:", sum(percent_change_trend$`Number of sites`))) %>%
tab_source_note(paste("Total number of wastewater sampling sites:", length(unique(ww_transmission$SW_ID))))%>%
tab_style(style = cell_text(weight = "bold"),
locations = list(
cells_column_labels(gt::everything())
)) %>%
# change font size
tab_options(table.font.size = 14)
#----------------------------------------------------------------------------------------------------------------------------------------------------
####################################
# CASE DATA LOAD AND PREPROCESSING #
####################################
# case data from nys website
all.cases <- read.csv("https://health.data.ny.gov/api/views/xdss-u53e/rows.csv?accessType=DOWNLOAD&bom=true&format=true&delimiter=%3B",
header = TRUE, sep = ";")
colnames(all.cases)[1] <- "test_DATE"
# data prep (date variable change and make case data numeric)
all.cases$Date <- mdy(all.cases$test_DATE)
all.cases$Cases <- as.numeric(gsub(",", "", all.cases$New.Positives))
# add test positivity
all.cases$tests <- as.numeric(gsub(",", "", all.cases$Total.Number.of.Tests.Performed))
all.cases$Test_positivity <- all.cases$Cases / all.cases$tests
# add active cases
all.cases <- all.cases %>%
group_by(County) %>%
mutate(active.cases = purrr::map_dbl(Date, ~sum(Cases[between(Date, .-6, .)])),
avg_positivity = purrr::map_dbl(Date, ~mean(Test_positivity[between(Date, .-7, .)], na.rm = TRUE))) # 10 is too many, 7 is close, 5 seems good too
all.cases <- all.cases %>%
group_by(County) %>%
mutate(avg_active.cases = purrr::map_dbl(Date, ~mean(active.cases[between(Date, .-7, . )], na.rm = TRUE))) # 7 day average of active cases
# change st lawrence spelling
all.cases$County[all.cases$County == "St. Lawrence"] <- "St Lawrence"
### UPDATE DATES FOR DASHBOARD DISPLAY ###
update_date <- lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')
last_sample_date <- max(wastewater$maxdate) %>% format('%b %d, %Y')
#----------------------------------------------------------------------------------------------------------------------------------------------------
# TABLE FOR METHODS SECTION SHOWING DETECTION LEVELS AND CASE CORRELATIONS WITH CITATION INFORMATION #
# detection levels
levels <- c("Not detected", "Detected, <LOQ", "Quantifiable detection")
case_correlation <- c("< 10 cases per 100,00", "10 to 49 cases per 100,000", "> 50 cases per 100,000")
alert_cat <- c("Low", "Moderate", "Substantial to High")
# add hyperlink to paper
link <- c("https://doi.org/10.1093/pnasnexus/pgac001")
link <- sprintf('<p><a href = "%s">%s</a>', link, "See this publication for more information on how these levels were calculated.")
link <- gt::html(link)
detection_methods_table <- as.data.frame(cbind(levels, case_correlation, alert_cat))
colnames(detection_methods_table) <- c("Detection level", "Correlated case threshold", "Alert level")
# create table and save
gt_detection_methods_table <-
detection_methods_table %>%
gt() %>%
# edit colors
data_color(
columns = "Alert level",
colors = scales::col_factor(alert_colors,
levels = alert_levels,
ordered = TRUE)
)%>%
# add link as caption
tab_source_note(
(link)
) %>%
# bold font
tab_style(style = cell_text(weight = "bold"),
locations = list(
cells_column_labels(gt::everything())
)) %>%
# font size
tab_options(table.font.size = 14)
# image for info page
figure_2_detection_levels <- base64enc::dataURI(file="www/figure_2_detection_levels.PNG", mime="image/png")
#----------------------------------------------------------------------------------------------------------------------------------------------------
#----------------------------------------------------------------------------------------------------------------------------------------------------
############# APP STARTS HERE #######################
# Define UI
ui <-
function(req){
dashboardPage(
dashboardHeader(title = "NYS SARS-CoV-2 Wastewater Surveillance Platform", # title in the box at top of the page
titleWidth = 450), # this titlewidth is linked to the sidebar
# SIDEBAR CONTENT #
dashboardSidebar( width = 225,
# SIDEBAR MENU #
sidebarMenu(id = "sidebarid",
# STYLE ARGUMENT USES CSS CODE
style = "position:fixed; width:auto; overflow-x: clip;", # keeps the sidebar content from scrolling
# MENU ITEMS THAT ARE TABS ON THE SIDEBAR
menuItem("State Dashboard", tabName = "dashboard", icon = icon("dashboard")), # tabName is called below in the tab argument
menuItem("Resources and toolkit", tabName = "resources", icon = icon("file-alt")),
menuItem("Information", icon = icon("info"), tabName = "Information"),
### CONDITIONAL PANEL FOR SIDEBAR BUTTONS ON MAIN DASHBAORD PAGE ###
# we add this here so that the buttons only show up on the dashboard page (see condition = below)
conditionalPanel(
condition = 'input.sidebarid == "dashboard"',
# RADIO BUTTONS FOR FIRST PLOT SHOWING TRENDS
radioButtons("ww_trend", # id for radio button series
"Wastewater trend", # title of button series
c("SARS-CoV-2 intensity" = "intensity", # plot 1 is the intensity, log refers to the ID of the object
"Gene copies" = "raw gene copies" #plot 2 is the gene copies, gene is the ID of the object to display
),
width = 225),
# TOOLTIP FOR TREND PLOTS
bsTooltip("ww_trend",
"Switch between intensity and gene copies ", ),
# RADIO BUTTONS FOR SECOND PLOT SHOWING CASE DATA
radioButtons("case_switch", # id for the radio button series
"Cases data", # title of button series
c("New cases" = "new_cases",
"Active cases" = "active_cases",
"Test positivity" = "positivity"),
width = 225),
# TOOLTIP FOR CASE PLOT
bsTooltip("case_switch", #"county_case_plotly",
"Switch the case plots between new cases, active cases, and positivity.",
"bottom", )
) # close conditional panel
) # close sidebar menu
), # close dashboard sidebar argument
dashboardBody(
useShinyjs(), #for shinyjs code to work
useShinyalert(), # Set up shinyalert
# CSS style arguments (e.g., font size)
# increase size of acutal map display based on window
tags$style(type = "text/css", "#NYBetaMap {height: calc(100vh - 80px) !important;}"), # NYBetaMap is the ID of the object to modify
tags$head(tags$style('.selectize-dropdown {z-index: 10000}')), # this makes the state_map_toggle overlay the leaflet
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(12,
h2("Welcome to the dashboard for the NYS Wastewater Surveillance Network"),
p("The NYS Wastewater Surveillance Network is a collaboration between Syracuse University, SUNY-ESF, University at Buffalo - SUNY,
Stony Brook University, Upstate Medical University, NYS Department of Health, and NYS Department of Environmental Conservation.
This website is where all the wastewater surveillance data collected by participating counties is reported. You can view data in the
interactive map and graphs below for all current and past participants. Additional information is available
in the information tab on the left sidebar."),
br(),
h4("Updates to data"),
p("Erie county historical data (2020 and 2021) are available on the ", tags$a(href="https://erieny.maps.arcgis.com/apps/dashboards/a95853269eec489ea59e5b71571f2e76",
"Erie County Dashboard.",
style = "font-weight: bold;"),
"The New York State Network is in the process of adding data from all participating counties in both the state
program and the CDC national program to this dashboard. Data are added as they are received. CDC data undergoes
different data processing and trends displayed on the ", tags$a(href = "https://covid.cdc.gov/covid-data-tracker/#wastewater-surveillance",
"national dashboard",
style = "font-weight: bold;"
), # end tags argument for html link
"might differ from trends displayed here."),
# note on gene copy trends
p(tags$b("Note: Trends for New York City and the counties Genesee, Orleans, and Suffolk are based on the natural log of raw gene copies.")),
br(),
# link to video and pdf tutorial document
p("First time visiting the dashboard? A dashboard tutorial is now available online. Please follow ", tags$a(href = "https://youtu.be/iUBOJ5nRP3s", "this link",
style = "font-weight:bold;") ,
" to watch a demonstration and learn more about how to use the interactive figures. Also, we have a document that explains the steps
of how to use the features on this page and navigate the dashboard interactive content.",
tags$a(href = "https://drive.google.com/file/d/1lgy8wltN68gS0wG8tlYfW-LeWxmj2UPB/view?usp=sharing", "Dashboard Tutorial"), ". (A PDF will open for you to view)."
),
)# end column argument
), # end fluid row opening paragraph
# VALUE BOXES WITH STATE SUMMARIES #
fluidRow(column(width = 12, h2(HTML(paste("Statewide participation summary", "<sup>", "1", "</sup>"))))),
fluidRow(
# number of counties actively reporting
valueBox( value = active_counties$Freq,
subtitle = "Participating counties",
color = "light-blue",
icon = icon("map")
),
# number of treatment plants reporting
valueBox( value = active_plants_value,
#subtitle = "Participating WWTPs",
subtitle = "Participating WWTPs",
color = "aqua",
icon = icon("water")
),
# population covered
valueBox( value = formatC(population, format="d", big.mark=","),
subtitle = "Population covered",
color = "blue",
icon = icon("users"))
), # end fluid row summary boxes
fluidRow(column(width = 12, p(HTML(paste("<sup>", "1", "</sup>", "Participation as of ", lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))))),
# UPDATE INFORMATION ROW
fluidRow(column(12,
titlePanel(h3(paste("Last Updated: ", update_date, sep = ""))),
titlePanel(h3(paste("Most recent sample: ", last_sample_date, sep = "")))
)
), # end fluid row
br(),
# MAIN DASHBOARD MAP (ID = NYBetaMap)
fluidRow(box(width = 12, id = "map_container",
title = "Map of participating treatment plants and counties",
column(width = 8,
# withspinner adds loading icon
withSpinner(
leafletOutput('NYBetaMap'),
type = 8), # type of loading icon to show
fluidRow(# create action button to show or hide description
actionButton(inputId = "button_map", label = "Map description show / hide", width = 250)
) # close fluid row
), # close column
# RIGHT OF MAP SIDEBAR #
column(width = 4,
# MAIN MAP TOGGLE SELECTIONS AND BUTTONS
fluidRow(selectInput(inputId = "state_map_toggle", label = "Wastewater Metric",
choices = c("SARS-CoV-2 detection level" = "Alert_factor",
"Two week trend" = "Trend_factor"),
selected = "SARS-CoV-2 detection level"
)# end select input
), # close fluid row
# CATEGORY CHANGE TABLES
fluidRow(wellPanel(id = "category_tables",
conditionalPanel(condition = "input.state_map_toggle == 'Alert_factor'",
gt_output("alert_table")
), # close conditional panel
conditionalPanel(condition = "input.state_map_toggle == 'Trend_factor'",
gt_output("trend_table")
) # close conditional panel
) # close well panel
), # close fluid row
# CATEGORY CHANGE DESCRIPTION
fluidRow(wellPanel(
conditionalPanel(condition = "input.state_map_toggle == 'Alert_factor'",
box(width = 12, title = "SARS-CoV-2 detection level",
p("SARS-CoV-2 detection level is displayed in three categories: Low, Moderate, and Substantial to High.
Current estimated levels are based on the highest detection reported from the most recent three samples. These detection levels have
been shown to correlate with estimated community transmission levels. Category change in the last 15 days is calculated by subtracting
the current number of sites in each current level category from the number of sites in the same category 15 days earlier and dividing by
the number of sites in the same category 15 days earlier.
See the Map description for more detailed information."))
), # close conditional panel
conditionalPanel(condition = "input.state_map_toggle == 'Trend_factor'",
box(width = 12, title = "Two-week trend",
p("To identify how wastewater results are changing over time, trend analysis is conducted on the most recent data. A two-week trend is
calculated for each location using all data points within the fifteen previous days of the most recent sample for that location.
The trend analysis calculates the average change in the SARS-CoV-2 Intensity over the fifteen-day period using a linear
regression. Sites with fewer than two samples within the fifteen-day window appear as NA values. Category change in the last 15 days is
calculated by subtracting the current number of sites in each current level category from the number of sites in the same category 15
days earlier and dividing by the number of sites in the same category 15 days earlier.
See the Map description for more
detailed information.")
) # close box
)# close conditional panel
)# close well panel
) # close fluid row
) # close column
), #close map box
), # end map fluidrow
# new tooltip to try
# NYBetaMap TOOLTIP #
bsTooltip("NYBetaMap",
"Zoom in or click a county to see sewersheds. Click a marker or catchment to see wastewater trends (displayed below).",
trigger = "hover",
"bottom", ),
# map container second TOOLTIP #
bsTooltip("map_container",
"Zoom in or click a county to see sewersheds. Click a marker or catchment to see wastewater trends (displayed below).",
trigger = "hover",
"top", ),
br(),
# NYBetaMap DESCRIPTION (observe event is in the server)
hidden(div(id = "maptext_wrapper",
box(id = "mapText", title = "Map description", width = 12,
h4("Map"),
# disclaimer on state of the science
p(HTML(paste0("<b>", "NOTE: Results presented here are based on the current state of the science. Understanding regarding the
data and science around what different detection values mean is evolving and the
correlations may change in the future leading to changes in how wastewater results are categorized.", "</b>"))),
p("This dashboard provides trend analysis of the wastewater surveillance
being conducted in participating counties in New York State. The detection level of SARS-CoV-2 indicates how much
viral RNA was detected in the sample and these detection levels correlate highly with the probability of
community transmission based on current understanding of the science. These correlations are based on
statistical analysis of wastewater intensity and active case data.
The two-week trend indicates the
average increase or decrease in the SARS-CoV-2 intensity (the population normalized ratio) detected
in wastewater. The statewide map displays
the current participating counties as well as those that have participated in the past.
To learn more information about SARS CoV-2 detection and trends
within a county, ", HTML(paste0("<b>", "select a county in the dropdown menu on the right or zoom in or click on a county", "</b>")),
" on the map."),
br(),
h4("Zoom in or click to see more detail"),
p("Zoom in on the map to see more information or click on a county of interest and the map will zoom into that county's sample sites. You can see what
wastewater treatment plants are participating, where they are located, and view trends for each.
Zooming in will also display the sewershed boundaries corresponding to the treatment plants.
Counties that participated in the past but are not currently reporting surveillance have older data available for review.
Zoom in on those counties to see their sample sites and view historical data"),
br(),
h4("SARS-CoV-2 detection level"),
gt_output("methods_table_1"),
p("Detection levels were determined based on statistical correlation between active case thresholds and wastewater detection. Detailed methods
and documentation are available", tags$a(href = "https://doi.org/10.1093/pnasnexus/pgac001", "here.")),
# p("Detection level is displayed in three categories: Low, Moderate, and Substantial to High.
# Current estimated levels are based on the highest detection reported from the most recent three samples."),
# p("Low detection levels correlate with approximately less than 10 cases per 100,000 population in the past seven days based on
# statistical models tracking wastewater detection of SARS-CoV-2 and active case counts."),
# p("Moderate detection levels correlate with approximately 10 to 50 cases per 100,000 in the past seven days."),
# p("Substantial to high detection levels correlate with 50 or more cases per 100,000 in the past seven days."),
br(),
h4("Two-week Trend Calculation"),
p("To identify how wastewater results are changing over time, trend analysis is conducted on the most recent data. A two-week trend is calculated for each
location using all data points within the fifteen previous days of the most recent sample for that location.
The trend anlysis calculates the average change in the SARS-CoV-2 Intensity (log of the viral gene copies divided by the log of the fecal indicator)
over the fifteen day period using a linear regression. Fifteen days was selected because it contains the most information about recent viral
transmission within the community and provides the most up-to-date context for what direction transmission might be going.
CDC trend analysis also uses the fifteen day period to calculate trends. If a sample site has fewer than two samples within the fifteen day window,
then their trend results will show up as a grey color on the map.")
) # end box
)# end div
), # end hidden,
#
# WASTEWATER TREND PLOTS
# created in a well panel and conditional panel linked to the radio buttons above
br(),
fluidRow(
box(width = 12, title = "Wastewater trend",
wellPanel(id = "sewershed_plots",
conditionalPanel(
condition = "input.ww_trend == 'intensity'",
withSpinner(plotlyOutput("sewershed_plotly_default_log"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.ww_trend == 'raw gene copies'",
withSpinner(plotlyOutput("sewershed_plotly_default"), type = 8) # add loading icon
)
),# end well panel
column(12, actionButton(inputId = "button_trendText", label = "Trend graph description show / hide", width = 250)
)# end column
)# end box
), # end fluidrow
bsTooltip("sewershed_plots", #"sewershed_plotly_default",
"This plot shows the trend values for SARS CoV-2 detected in wastewater at the selected treatment plant.",
"bottom", ),
# sewershed trend plot description
hidden(
div(id = "trendPlotText_wrapper",
box(id = "trendPlotText", title = "Wastewater trend description", width = 12,
h4("Detection trend graph"),
p("The first graph displays the change in wastewater detection of SARS-CoV-2 RNA over time.
This graph displays the log-transformed ratio of SARS-CoV-2 to human fecal indicator detected. This ratio adjusts the detected values
based on population
so that lower levels of detection indicate fewer shedding events. As detection levels
rise, the trend line will also rise indicating increases in detection."),
br(),
h5("Intensity ratio of SARS-CoV-2 detected"),
p("Recovery of viral fragments of SARS-CoV-2 RNA from wastewater is influenced by many factors that impact the final value
measured in the lab including that RNA fragments decay over time in waste. Most samples are turned around in 24
hours limiting these effects, however, to better understand the amount of SARS-CoV-2 detected in wastewater, a ratio is
used. This ratio is the natural log of total gene copies of SARS-CoV-2 RNA detected divided by the natural log of total copies of human fecal indicator
detected in the sample. The human fecal indicator is constantly shed by humans and
works as a measure for the total amount of waste coming into the sewer system. This value is generally stable
meaning that it helps compare one SARS-CoV-2 RNA sample to another. Thus, the ratio is a good
indicator for how much SARS-CoV-2 virus might be transmitting in the observed community. This ratio is called the
Intensity of SARS-CoV-2 detected in wastewater. Current methods being used in New York use two different human fecal indicators. The first
is crAssphage DNA, which is a ubiquitous bacteriophage found in most humans. The second is pepper mild mottle virus or PMMoV, which is a common
virus found in peppers and excreted in humans."),
br(),
h5("Gene copies"),
p("This plot shows the average number of gene copies (units are copies per milliliter) detected in each sample of wastewater. These values are not
normalized by population but do show general trend information. For some counties and jurisdictions, the natural log of gene copies is used to determine
the two-week trend instead of intensity. The natural log of gene copies was found to correlate best with lab-confirmed case data and is suitable for
sampling sites that do not collect fecal indicator data. One benefit of reporting gene copies
is that detection levels can be grouped based on three categories. When no gene copies are detected, this is known
as a non-detect so it is classified as ", HTML(paste0("<b>","Not detected.","</b>"))), br(),
p("Sometimes, labs detect SARS CoV-2 viral fragments, but levels
are too low to quantify how much is in the wastewater. These readings indicate that there is SARS-CoV-2 RNA in the wastewater, but
it is at a lower level indicating fewer infections in the community that is connected to the sewer system. This is known as
a detection below the limit of quantification or ",
HTML(paste0("<b>","detected, ","<", "LOQ.","</b>"))
), br(),
p("When labs detect SARS-CoV-2 RNA fragments and can quantify the values, this is known as a ",
HTML(paste0("<b>","quantifiable detection.","</b>")),
" This indicates higher levels of SARS-CoV-2 RNA in wastewater and greater infections in the community linked to that sewer system."),
br(),
p("Toggle between the intensity plot and gene copies using the buttons on the left sidebar.")
) # end box
)# end div
), # end hidden
br(),
#fluidRow(
# box(width = 12,
# plotlyOutput("county_case_plotly"))
#),
fluidRow(
box(width = 12, title = "Case data",
wellPanel(id = "case_plots", conditionalPanel(
condition = "input.case_switch == 'new_cases'",
withSpinner(plotlyOutput("county_case_plotly"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.case_switch == 'active_cases'",
withSpinner(plotlyOutput("county_active_plotly"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.case_switch == 'positivity'",
withSpinner(plotlyOutput("county_positivity_plotly"), type = 8) # add loading icon
)
),
column(12, actionButton(inputId = "caseText_button", label = "Case plot description show / hide", width = 250))
)# end box
), # end fluid row
# case plot tooltip
bsTooltip("case_plots", #"county_case_plotly",
"This plot shows the total positive test results for the county.",
"bottom", ),
# case plot description popup
hidden(
div(id = "caseText_wrapper",
box(id = "caseText", title = "Case plot description", width = 12,
h4("Case graphs"),
p("Case data are downloaded from the NYS Department of Health website and displayed at the county level.
New cases are reported positive lab confirmed tests from that day. At home tests are not included."),
p("Active cases are the estimated 7-day rolling average for individuals that tested positive via a lab confirmed result and may be in quarantine or isolation."),
p("Positivity is calculated by dividing the total positive tests
by the total tests performed on that day. Positivity is the 7-day rolling average."),
p("You can change the graph to show new cases or positivity using
the buttons on the left sidebar.")
) # end box
)# end div
), # end hidden
br(),
h4("Key terms"),
p("Intensity of SARS CoV-2 RNA in wastewater - the natural log-adjusted ratio of SARS-CoV-2 RNA copies detected to total human fecal indicator detected."),
p("Natural log of raw gene copies - SARS-CoV-2 RNA copies are natural log transformed to provide a more linear fit to the data for calculating trends over time."),
p("Sewershed - a term used to refer to the service area of a treatment plant. Sewersheds can
represent the entire service area for a plant or a portion of the service area. These smaller portions are sometimes called
catchments and represent sampling at manholes or pump stations before the influent reaches the primary treatment facility."),
p("crAssphage - bacteriophage commonly excreted from humans which is used to determine the relative
level of SARS-CoV-2 RNA in the wastewater. The ratio of crAssphage to SARS-CoV-2 helps estimate if there
is small amount of SARS-CoV-2 or if detection levels indicate greater infection in the population. It is one
of the fecal indicators used to normalize data and calculate the intensity value."),
p("PMMoV - pepper mild mottle virus - common virus found in peppers that is excreted in human waste. It is one of the human fecal indicators used to normalize
wastewater sample results to adjust for different population sizes."),
p("WWTP - wastewater treatment plant")
###############
),
tabItem(tabName = "resources",
fluidRow(
column(12,
h3("Wastewater surveillance toolkit"),
br(),
p("The links below are to documents that Local Health Departments (LHDs) might find useful for understanding
and communicating wastewater results. These documents are meant to supplement existing forms of communication
between LHDs and communities and not replace current methods."),
br(),
h4(tags$a(href = "https://docs.google.com/document/d/1U2ATfRBfZ9oLDCswVkeC9VEu0Nny3h9X/edit?usp=sharing&ouid=108902605522388810362&rtpof=true&sd=true",
"Sample press release")),
h4(tags$a(href = "https://docs.google.com/document/d/1ZiHUusaMcesEaTzz0Q19ZCdq6_0I0iCp/edit?usp=sharing&ouid=108902605522388810362&rtpof=true&sd=true",
"Who to inform")),
h4(tags$a(href = "https://docs.google.com/document/d/1lyGA0piGM6JfRa3xoqs7Pk7LY76cM-o_/edit?usp=sharing&ouid=108902605522388810362&rtpof=true&sd=true",
"Suggested social media posts")),
h4(tags$a(href = "https://docs.google.com/document/d/1cMEMgiMMmPit1lpVV0clnjE7hNyeEb14/edit?usp=sharing&ouid=108902605522388810362&rtpof=true&sd=true",
"FAQs"))
)
)
),
tabItem(tabName = "Information",
# notes and disclaimers
# fluidRow(
# box(
#title = "NOTE", background = "green",
#)
#),
fluidRow(
column(12,
h3("Project description"),
p("The SARS-CoV-2 early warning wastewater surveillance platform began
in early March of 2020. Participating
counties and wastewater treatment plants provide wastewater
samples weekly or semi-weekly (two to three times per week). Lab analyses are
caried out at partner organizations, several of which are listed below. Trends and maps are
created using the results of surveillance to help guide response to the
coronavirus pandemic. In addition, trends can help inform public health
actions that can be taken to protect communities where increased transmission is detected
and when transmission is declining or very low."),
br(),
# notes on methods
h3("Methods"),
h4("Trend calculations"),
p("Wastewater data are normalized for fluctuations in human fecal content contribution. Two human fecal indicators are used: crAssphage and PMMoV.
The specific fecal indicator measured for the sample varies based on the lab analyzing the sample. The ratio
of SARS CoV-2 RNA to human fecal indicator is a unitless ratio indicating the intensity of coronavirus gene
copies detected in the wastewater. Higher values indicate higher viral load and potentially higher transmission in the community that the
sample is from. Trend plots use natural log-adjusted values for this intensity metric to reduce the influence of large spikes or declines in detection due
to things like high intensity rain events that can make accurate detection difficult. Single samples show a snapshot in time for
the level of coronavirus detected in wastewater, while several data points over time provide indicators of viral trends in a community.
This dashboard provides two-week trend metrics to display if viral detection is increasing or decreasing by comparing samples taken over a fourteen-day
window."),
p("For some counties and jurisdictions, the natural log of gene copies is used to determine
the two-week trend instead of intensity. The natural log of gene copies was found to correlate best with lab-confirmed case data and is suitable for
sampling sites that do not collect fecal indicator data. Current sites using this method are in Genesee, Orleans, Allegany, and Suffolk Counties as well as
New York City."),
p("Comparing these trends to the observed case data is useful for confirming trends seen among clinical case data and provides
additional information about viral transmission in communities. Wastewater samples are an excellent supplement to clinical testing
and provide additional information about large populations quickly to understand and track the spread of COVID-19."),
h4("Dashboard"),
p("This dashboard was created in R version 4.1.1 using the R Shiny package. Additional packages include shinydashboard, sf, dplyr,
lubridate, tigris, rgdal, leaflet, ggplot2, htmlwidgets, htmltools, leaflet.extras, tidyr, scales, plotly, shinyBS,
magrittr, and stringr. Documentation for these packages is available ", tags$a(href="https://cran.r-project.org/web/packages/available_packages_by_name.html", "online.")),
# DETECTION LEVEL EXPLANATION #
h4("Detection level calculations"),
# note on the change in categories for detection level and probability of community transmission
p(tags$b("Note on change from community transmission language to detection level"), "In March of 2022, we began reporting
correlations between levels in wastewater and probability of community transmission. The label for this set of categories
was updated in May 2022 to reflect the current state of the science and understanding of what different detection levels
mean related to estimated case counts. The previous levels remain valid; however, it is more accurate to report
the metric as detection level of SARS-CoV-2 RNA in the wastewater since that is what is being measured. Low, Moderate, and
Substantial to High levels of SARS-CoV-2 in the wastewater correlate with estimated levels of community transmission
and active case counts within the community contributing wastewater to the sample site. The new levels are:"),
# p("Low detection levels correlate with approximately less than 10 new cases per 100,000 population in the past seven days based on
# statistical models tracking wastewater detection of SARS-CoV-2 and active case counts."),
# p("Moderate detection levels correlate with approximately 10 to 50 new cases per 100,000 in the past seven days."),
# p("Substantial to high detection levels correlate with 50 or more new cases per 100,000 in the past seven days."),
br()
), # end column
column(12,
# methods table
gt_output("methods_table_2"),
br(),
br(),
p("Detection levels were determined based on statistical correlation between active case thresholds and wastewater detection. Detailed methods
and documentation are available", tags$a(href = "https://doi.org/10.1093/pnasnexus/pgac001", "here."),
"The figure below provides a visual representation of correlations between case thresholds and each detection level used."),
# insert image
img(src=figure_2_detection_levels, align = "left", height = '350px', width = '650px'),
p(tags$b("COVID-19 Incidence and Detection Levels Figure:"),"Estimates of the limits of detection (in terms of cases reported in the
health system) of SARS-CoV-2 testing in wastewater relative to classification of transmission risk. Clear differentiation in the
level of measured community-level COVID-19 incidence when categorizing wastewater results as quantifiable, detected but below the
level of quantification, and not detected. Size of the circles represents the number of individuals tested. Nondetection of
SARS-CoV-2 RNA clusters around < 10 cases per 100,000.")
), # end column
column(12,
# notes on data
h4("Data"),
p(tags$b("NOTE"), "Erie county data are available on the ", tags$a(href="https://erieny.maps.arcgis.com/apps/dashboards/a95853269eec489ea59e5b71571f2e76",
"Erie County Dashboard."
), # end tags argument
"The New York State Network is in the process of adding data from all participating counties in both the state
program and the CDC national program to this dashboard. Data are added as they are received. CDC data undergoes
different data processing and trends displayed on the ", tags$a(href = "https://covid.cdc.gov/covid-data-tracker/#wastewater-surveillance",
"national dashboard"
), # end tags argument
"might differ from trends displayed here."
),
h5(tags$b("Notes on lab methods")),
p("Labs that are contributing wastewater results in New York State use different methods. Comparison of data between and across sites
analyzed by different labs may not correlate and is not recommend particularly for raw gene copies. If a method changes at the lab
analyzing that site, past data may also not correlate."),
p("Quadrant biosciences is analyzing wastewater samples for most New York State counties. The limit of quantification for Quadrant's analysis method is
5 gene copies per milliliter. University at Buffalo - SUNY is analyzing wastewater samples for most of the Western Region of NYS. The limit
of quantification for the method used by University at Buffalo - SUNY is 1 gene copy per milliliter. University at Buffalo - SUNY changed their methods
to magnetic bead processing the week of April 17, 2022. It is recommended that data not be compared before and after this time point for University at Buffalo - SUNY
sites. This is noted on the gene copies plot for those locations (e.g., Erie County WWTPs). Stony Brook University is analyzing wastewater
samples for Suffolk County. Genesee and Orleans County Public Health Department is analyzing data for Genesee and Orleans Counties."),
p("New York City data are reported weekly. For more information on methods used for SARS-CoV-2 detection in New York City, please visit",
tags$a(href = "https://doi.org/10.1039/D1EW00747E", "this website."),
"For access to New York City historical data, please visit: ",
tags$a(href = "https://data.cityofnewyork.us/Health/SARS-CoV-2-concentrations-measured-in-NYC-Wastewat/f7dc-2q9f/data", "this website.")
),
p("Wastewater samples are collected at participating treatment plants usually at influent points where the pipes run into the
treatment plant."),
p("Case data are obtained from", tags$a(href="https://health.data.ny.gov/Health/New-York-State-Statewide-COVID-19-Testing/xdss-u53e", "New York State Department of Health.")),
p("Sewershed boundaries are created from several sources including physical maps provided by treatment plant operators, existing GIS data from participants,
and digitized using ", tags$a(href="http://gis.ny.gov/parcels/", "NYS parcel data."), "Boundaries indicated the estimated service area for
the treatment plant providing information on the community represented by each wastewater sample."),
p("Treatment plant locations are from the NYS GIS data clearinghouse and available ", tags$a(href="https://data.ny.gov/Energy-Environment/Wastewater-Treatment-Plants/2v6p-juki", "here.")),
br(),
h3("Partners"),
tags$ul(
tags$li("New York State Department of Health"),
tags$li("New York State Department of Environmental Conservation"),
tags$li("Syracuse University"),
tags$li("SUNY ESF"),
tags$li("SUNY Upstate Medical University"),
tags$li("Quadrant Biosciences"),
tags$li("University at Buffalo - SUNY"),
tags$li("Stony Brook University"),
tags$li("Genesee and Orleans County Public Health Department"),
tags$li("CDC National Wastewater Surveillance System")#,
#tags$li("Arcadis")
),
br(),
h3("Dashboard design and analysis contributors"),
tags$ul(
tags$li("David Larsen, Department of Public Health, Syracuse University: Supervision, method development, data analysis"),
tags$li("Hyatt Green, Department of Environmental and Forest Biology, SUNY-ESF: Method development, data analysis"),
tags$li("Dustin Hill, Department of Public Health, Syracuse University: Web development, data analysis, data visualization"),
tags$li("Mary Collins, Department of Environmental Studies, Center for Environmental Medicine and Informatics, SUNY-ESF: Web development, data visualization"),
tags$li("Christopher Dunham, Director Research & Decision Support, Syracuse University: Web development, data management, quality assurance.")
),
br(),
h3("Contact us"),
p("For questions about wastewater data and results, contact Dr. David Larsen at dalarsen@syr.edu"),
p("For bug reports and issues with the dashboard, contact Dr. Dustin Hill at dthill@syr.edu")
#h3("Additional information"), #title
#a("youtube video"), #hyperlink for youtube video
#br(),),
) # end column
)# end fluid row
) # end tab item
)# end tab items plural
) # end dashboard body
)# end dashboardPage
} # close function for ui
###################### SERVER ############################
server <- function(input, output, session) {
## helper command to keep app open longer ##
output$clock = renderText({
invalidateLater(4500)
Sys.time()
})
###### LEAFLET MAP OF NEW YORK #######
# palette for county participation
fact_pal <- colorFactor(c("cyan4", "light blue", "black"), levels = c("Currently reporting data", "No current surveillance reported", "Not currently participating"))
# create map for renders
nybetamap_preset <- leaflet(data = ny_counties, options = leafletOptions(zoomControl = TRUE, maxZoom = 13, minZoom = 6,
dragging = TRUE)
) %>%
addMapPane("nymap", zIndex = 420) %>%
addMapPane("tiles", zIndex = 400) %>%
addMapPane("catchment", zIndex = 422) %>%
addMapPane("wwtps", zIndex = 435) %>%
#addMapPane("zip_codes", zIndex = 405)%>%
#addTiles(group = "base") %>%
addPolygons(data = ny_counties,
smoothFactor = 0.2, fillOpacity = 0.7,
fillColor = ~fact_pal(Participating),
stroke = TRUE,
color = "black",
weight = 1,
layerId = ny_counties$County,
options = pathOptions(pane = "nymap", clickable = TRUE),
label = ny_counties$County,
group = "County status",
highlightOptions = highlightOptions(color = "white", weight = 2,
bringToFront = TRUE)) %>%
addLegend(position = c("topright"), pal = fact_pal,
values = ~Participating, #
opacity = 0.7, #na.label = "NA",
title = "Surveillance status",
group = "County status",
layerId = "legend_participating") %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Base map",
options = c(pathOptions(pane = "tiles"))) %>%
addProviderTiles(providers$Stamen.TonerLines, group = "Base map",
options = c(providerTileOptions(opacity = 0.35), pathOptions(pane = "tiles")))%>%
addProviderTiles(providers$Stamen.TonerLabels,group = "Base map",
options = pathOptions(pane = "tiles")) %>%
# counties appear through zoom levels 3 to 10 then become transparent
groupOptions("County status", zoomLevels = 3:10) %>%
# add counties to appear transparent at lower zoom
addMapPane("county_transparent", zIndex = 421) %>%
addPolygons(data = ny_counties,
smoothFactor = 0.2, #fillOpacity = 0.7,
fillColor = "transparent",
stroke = TRUE,
color = "black",
weight = 3,
layerId = ny_counties$FIPS_CODE,
group = "County transparent",
options = pathOptions(pane = "county_transparent",
clickable = FALSE) # cannot click counties
) %>%
# transparent counties appear at zoom levels 11 to 15
groupOptions("County transparent", zoomLevels = 11:15) #%>%
#### SHOW/HIDE ALERT LEVELS IF SELECT INPUT IS ON COMMUNITY TRANSMISSION ####
observe({
##### TWO COLOR FACTOR SETS BASED ON USER INPUT FOR WHAT PATTERN TO DISPLAY ####
if (input$state_map_toggle == "Alert_factor") {
wastewater_pal <- colorFactor(alert_colors,
levels = alert_levels, ordered = TRUE)
} else if (input$state_map_toggle == "Trend_factor") {
wastewater_pal <- colorFactor(trend_colors,
levels = trend_levels,
ordered = TRUE) }
proxy_map <- leafletProxy("NYBetaMap") %>%
# add new markers with the trend level
addCircleMarkers(data = wwtps_active , ~Longitude, ~Latitude,
fillColor = ~wastewater_pal(eval(as.symbol(input$state_map_toggle))), #~pal(TwoWeekBet),
fillOpacity = 0.9,
color = "black", #
opacity = 0.5,
popup = paste("Facility:", (as.character(wwtps_active$Facility.N)), "<br>",
"Estimated population served:", formatC(wwtps_active$pop_served_2, format = "d", big.mark = ","), "<br>",
"SARS-CoV-2 detection level: ", wwtps_active$Alert_factor, "<br>",
"Current trend:", ifelse(wwtps_active$TwoWeekBet > 0, "Increasing", "Decreasing"), "<br>",
round(abs((wwtps_active$TwoWeekBet) ) * 100, 0), "percent", ifelse(wwtps_active$TwoWeekBet > 0, "increase", "decrease"), "in ", ifelse(wwtps_active$trend_measure == "raw gene copies", "natural log of raw gene copies", "intensity") ," over two weeks", "<br>",
"Last sample", lubridate::as_date(wwtps_active$Date_collected) %>% format('%b %d, %Y')
),
label = ~paste(as.character(Facility.N)),
layerId = wwtps_active$WWTP_ID,
options = pathOptions(pane = "wwtps"),
group = "WWTPs"
) %>%
# add sewersheds to appear at specific zoom level
addPolygons(data = wwtp.map, smoothFactor = 0.2, fillOpacity = 0.7,
fillColor = ~wastewater_pal(eval(as.symbol(input$state_map_toggle))), #~pal(TwoWeekBet),
stroke = TRUE,
color = "black",
weight = 2,
highlight = highlightOptions(
weight = 5,
color = "black",
fillOpacity = 0.7,
bringToFront = TRUE),
layerId = wwtp.map$SW_ID,
group = "Catchments",
options = pathOptions(pane = "catchment"),
label = ~paste( wwtp.map$Sewershed),
popup = paste((as.character(wwtp.map$Sewershed)), "sewershed", "<br>",
"Estimated population served:", formatC(wwtp.map$POP2020, format = "d", big.mark = ","), "<br>",
"SARS-CoV-2 detection level: ", wwtp.map$Alert_factor, "<br>",
"Current trend:", ifelse(wwtp.map$TwoWeekBet > 0, "Increasing", "Decreasing"), "<br>",
round(abs((wwtp.map$TwoWeekBet) ) * 100, 0), "percent", ifelse(wwtp.map$TwoWeekBet > 0, "increase", "decrease"), "in ", wwtp.map$trend_measure, " over two weeks", "<br>",
"Last sample", lubridate::as_date(wwtp.map$Date_collected.y) %>% format('%b %d, %Y')
),
labelOptions = labelOptions(noHide = FALSE)) %>%
# sewershed catchemtns appear at zoom levels 11 to 15
groupOptions("Catchments", zoomLevels = 11:15) %>%
# legend for values
# legend for alert
addLegend(data = wwtps_active, position = c("topright"),
pal = wastewater_pal,
values = ~eval(as.symbol(input$state_map_toggle)),
opacity = 0.7,
title = ifelse(input$state_map_toggle == "Alert_factor", "SARS-CoV-2 detection level",
"Two week trend"),
group = "WWTP",
layerId = "legend_wastewater"
)
})
##### PRESET STATE MAP FOR STATE MAP VIEW BUTTON #####
# render output
output$NYBetaMap <- renderLeaflet({
nybetamap_preset
})
# button press to display description of map
observeEvent(input$button_map, {
toggle("maptext_wrapper")
})
############################
# DETECTION METHODS TABLE #
############################
output$methods_table_1 <- render_gt(
gt_detection_methods_table, align = "left"
)
output$methods_table_2 <- render_gt(
gt_detection_methods_table, align = "left"
)
###############################
### CATEGORY CHANGE TABLES ###
###############################
output$alert_table <- render_gt(
table_alert
)
output$trend_table <- render_gt(
table_trend
)
##############################
### default plots and map ###
# ############################
# create sewer data df
sewershed_plot <- wastewater.sewersheds %>%
filter(Date_collected == max(Date_collected)) %>%
arrange(desc(IntensityDNA))
sewershed_plot <- head(sewershed_plot, 1)
sewershed_plot <- wastewater.historic %>%
filter(SW_ID %in% sewershed_plot$SW_ID)
#simple ggplot then turn to ggplotly
sewershed_plot$Date_collected <- ymd(sewershed_plot$Date_collected)
# create case data df
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County) %>%
filter(Date >= min(sewershed_plot$Date))
# ww plot function for gene copies # input is dataframe with data
sewershed_ww_plot_function <- function(plot_dataframe){
# or spike plot
sewershed_sars_plot <- ggplot(plot_dataframe, aes (x = lubridate::as_date(Date), y = copies, group = 1,
text = paste0("Date: ", lubridate::as_date(Date) %>% format('%b %d, %Y'), "<br>",
"Copies ", ifelse(copies == 1, 0, round(copies,2)), "<br>",
copies_factor)
)# end aes call
) + # end ggplot call
#geom_area(fill="#69b3a2", alpha=0.5) +
geom_line(color="black") +
#geom_smooth(color="#69b3a2", se = TRUE, span = 0.7) +
geom_point(aes(x = lubridate::as_date(Date), y = copies, shape = (copies_factor), color = (copies_factor)), alpha = 0.7, size = 4)+
scale_shape_manual(values=c("Not detected"= 15,
"Detected, <LOQ" = 16,
"Quantifiable detection" = 17))+
scale_color_manual(values=c("Not detected"= '#4E79A7',
"Detected, <LOQ" = '#F28E2B',
"Quantifiable detection" = '#E15759')
)+
#ylab("crAssphage adjusted levels of\nSARS-CoV-2 RNA in wastewater")+ #for unscaled, also can call intensity and explain*
ylab("Gene copies/mL")+
xlab("")+
theme_minimal()+
scale_y_continuous(#limits = c(0, NA),
expand = expansion(mult = c( 0, 1 ))) + # modify this later if needed, it buffers the title from the top of the values
xlim(min(lubridate::as_date(plot_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))+ # match ww data end date with case data
#theme(axis.text.y = element_blank())+
#scale_color_tableau(breaks = levels(plot_dataframe$copies_factor)) +
ylim(0.5, max(plot_dataframe$copies + 10))+
labs(color = "", shape = "") +
# add vertical line to plot if displaying UB data
geom_vline(xintercept = ifelse(plot_dataframe$lab_id == "UB-SUNY", as.numeric(lubridate::as_date("2022-04-17")), NA),
linetype = "dashed", color = "black", size = 1)+
# label vertical line
annotate(geom = "text",
label = ifelse(plot_dataframe$lab_id == "UB-SUNY", "UB detection method changed\nApr. 17, 2022", ""),
x = as.Date("2022-04-17"),
y = median(plot_dataframe$copies) + 5,
angle = 90,
vjust = 1)
# change to plotly
sewershed_plotly_default <- ggplotly(sewershed_sars_plot,
tooltip = c( "text")) %>%
layout(title = list(text = paste0(paste("<br>",
plot_dataframe$County, "County", "SARS-CoV-2 RNA gene copies detection trend",sep = " "), # title
'<br>',
'<sup>',
# subtitle
paste("WWTP:", plot_dataframe$WWTP, ",",
# more than one upstream location
ifelse(length(unique(plot_dataframe$Sewershed))==1, plot_dataframe$Sewershed, "" ),
"sewershed", sep = " "), '</sup>',
'<br>'
)
), legend = list(orientation = "h",
y = -0.15, x = 0.3) # adjust legend position #old was orientation v, and y = 0.5
) # end layout call
# remove hover on trend line
sewershed_plotly_default <- sewershed_plotly_default %>%
style(hoverinfo = "skip", traces = 2) %>%
style(hoverinfo = "skip", traces = 3)
return(sewershed_plotly_default)
}
default_ww_plot <-sewershed_ww_plot_function(sewershed_plot)
output$sewershed_plotly_default <- renderPlotly(default_ww_plot)
###
# update sewershed plot with intensity
###
###### WW PLOT OF INTENSITY FOR RECENT DATA #####
sewershed_ww_plot_function_log_recent <- function(plot_dataframe){
sewershed_sars_plot <- ggplot(plot_dataframe, aes (x = lubridate::as_date(Date), y = IntensityDNA,
group = 1,
text = paste0("Date: ", lubridate::as_date(Date) %>% format('%b %d, %Y'),
"<br>",
"Intensity ", round(IntensityDNA, 3),
"<br>",
"Fecal indicator: ", lab_method # change labels for ggplotly and round intensity value
)# end paste0 call
)# end aes call
) +
# add a rectangle, window where the data are calculating the trend from
geom_rect(data = plot_dataframe %>% filter(lubridate::as_date(Date) %in% lubridate::as_date(wastewater.df.sewersheds$Date)), aes(fill = factor(Trend_factor),
ymin = 0, ymax = max(plot_dataframe$IntensityDNA),
xmin = min(plot_dataframe$maxdate) - days(15),
xmax = max(plot_dataframe$maxdate)
),
color = "black",
alpha = 0.1)+
# points
geom_point(color="black") +
# smoothed line
geom_smooth(color="#69b3a2", se = TRUE, span = ifelse(length(plot_dataframe$Date) >4 & length(plot_dataframe$Date) <= 25, 0.75, 0.25),
method = ifelse(length(plot_dataframe$Date) <=4, "lm", "loess")) + # try different spans, 0.25 is in the memos?, 0.7 is the old version used
geom_point(data = plot_dataframe %>% filter(lubridate::as_date(Date) %in% lubridate::as_date(wastewater.df.sewersheds$Date)), aes(x = lubridate::as_date(Date), y = IntensityDNA), color = "black")+
#ggplot2::geom_smooth(data = plot_dataframe %>% filter(lubridate::as_date(Date) %in% lubridate::as_date(wastewater.df.sewersheds$Date)), aes(x = lubridate::as_date(Date), y = IntensityDNA, color = factor(Trend_factor)), method = "lm", se = FALSE)+
# second trend line for two week trend
ggplot2::geom_smooth(data = plot_dataframe %>%
filter(Date >= maxdate-days(15)),
aes(x = lubridate::as_date(Date), y = IntensityDNA, color = factor(Trend_factor)),
method = "lm", se = FALSE)+
scale_color_manual(values = c("< -75%" = "blue", "-50% to -75%" = "dodgerblue3", "-25% to -50%" = "cornflowerblue", "-10% to -25%" = "lightskyblue", "-10% to 10%" = "papayawhip",
" 10% to 25%" = "khaki2", " 25% to 50%" = "orange", " 50% to 75%" = "orangered", "> 75%" = "orangered4")
)+
#ylab("crAssphage adjusted levels of\nSARS-CoV-2 RNA in wastewater")+ #for unscaled, also can call intensity and explain*
ylab("Intensity of SARS-CoV-2")+
xlab("")+
theme_minimal()+
theme(legend.position = "none")+
scale_y_continuous(#limits = c(0, NA),
expand = expansion(mult = c( 0, 1 ))) + # modify this later if needed, it buffers the title from the top of the values
xlim(min(lubridate::as_date(plot_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y'))) +
# fix y axis
#ylim(0, max(plot_dataframe$IntensityDNA + 0.1))+
scale_fill_manual(values = c("< -75%" = "blue", "-50% to -75%" = "dodgerblue3", "-25% to -50%" = "cornflowerblue", "-10% to -25%" = "lightskyblue", "-10% to 10%" = "papayawhip",
" 10% to 25%" = "khaki2", " 25% to 50%" = "orange", " 50% to 75%" = "orangered", "> 75%" = "orangered4")
) +
# label the box for the trend
annotate(geom = "text",
label = "Two week trend",
x = min(plot_dataframe$maxdate - days(7)),
y = median(plot_dataframe$IntensityDNA) + 0.1,
expand = c(1,1)
)
# change to plotly
sewershed_plotly_default <- ggplotly(sewershed_sars_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",
plot_dataframe$County, "County", "SARS-CoV-2 RNA intensity detection trend",sep = " "), # title
'<br>',
'<sup>',
# subtitle
paste("WWTP:", plot_dataframe$WWTP, ",",
# more than one upstream location
ifelse(length(unique(plot_dataframe$Sewershed))==1, plot_dataframe$Sewershed, "" ),
"sewershed", sep = " "), '</sup>',
'<br>'
)
)
)
# remove hover on trend line
sewershed_plotly_default <- sewershed_plotly_default %>%
style(hoverinfo = "skip", traces = 1) %>%
style(hoverinfo = "skip", traces = 2) %>%
style(hoverinfo = "skip", traces = 5) %>%
style(hoverinfo = "skip", traces = 6)%>%
style(hoverinfo = "skip", traces = 8)
return(sewershed_plotly_default)
}
default_ww_plot_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
output$sewershed_plotly_default_log <- renderPlotly(default_ww_plot_log)
#### WW TREND OF INTENSITY PLOT FOR HISTORIC DATA #####
sewershed_ww_plot_function_log_historic <- function(plot_dataframe){
sewershed_sars_plot <- ggplot(plot_dataframe, aes (x = lubridate::as_date(Date), y = IntensityDNA,
group = 1,
text = paste0("Date: ", lubridate::as_date(Date) %>% format('%b %d, %Y'),
"<br>",
"Intensity ", round(IntensityDNA, 3),
"<br>",
"Fecal indicator: ", lab_method # change labels for ggplotly and round intensity value
)# end paste0 call
)# end aes call
) +
#geom_area(fill="#69b3a2", alpha=0.5) +
geom_point(color="black") +
geom_smooth(color="#69b3a2", se = TRUE, span = ifelse(length(plot_dataframe$Date) >4 & length(plot_dataframe$Date) <= 25, 0.75, 0.25),
method = ifelse(length(plot_dataframe$Date) <=4, "lm", "loess")) + # try different spans, 0.25 is in the memos?, 0.7 is the old version used
#ylab("crAssphage adjusted levels of\nSARS-CoV-2 RNA in wastewater")+ #for unscaled, also can call intensity and explain*
ylab("Intensity of SARS-CoV-2")+
xlab("")+
theme_minimal()+
scale_y_continuous(#limits = c(0, NA),
expand = expansion(mult = c( 0, 1 ))) + # modify this later if needed, it buffers the title from the top of the values
xlim(min(lubridate::as_date(plot_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))
# change to plotly
sewershed_plotly_default <- ggplotly(sewershed_sars_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",
plot_dataframe$County, "County", "SARS-CoV-2 RNA intensity detection trend",sep = " "), # title
'<br>',
'<sup>',
# subtitle
paste("WWTP:", plot_dataframe$WWTP, ",",
# more than one upstream location
ifelse(length(unique(plot_dataframe$Sewershed))==1, plot_dataframe$Sewershed, "" ),
"sewershed", sep = " "), '</sup>',
'<br>'
)
)
)
# remove hover on trend line
sewershed_plotly_default <- sewershed_plotly_default %>%
style(hoverinfo = "skip", traces = 2) %>%
style(hoverinfo = "skip", traces = 3) %>%
style(hoverinfo = "skip", traces = 6)
return(sewershed_plotly_default)
}
# button press to display description of plot
observeEvent(input$button_trendText, {
toggle("trendPlotText_wrapper")
})
######
# case plot default
#######
# new cases
case_plot_function <- function(case_dataframe){
case_county_plot <- ggplot(case_dataframe, aes(x = lubridate::as_date(Date), y = Cases,
group = 1,
text = paste0("Date: ", lubridate::as_date(Date)%>% format('%b %d, %Y'), "<br>",
"New cases ", Cases)# end paste0 call
))+
geom_bar(position = "dodge", stat= "identity")+
theme(plot.background = element_blank()) +
theme(panel.background = element_blank()) +
theme(panel.grid.major.y = element_line(color = "grey")) +
xlab("") +
ylab("New cases (total)")+
labs(caption = "")+
theme(axis.text.x=element_text(hjust=1),
text = element_text(size=12))+
theme_minimal()+
xlim(min(lubridate::as_date(case_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))
case_county_plot
case_plotly_default <- ggplotly(case_county_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",
case_dataframe$County, "County reported new cases (lab-confirmed)", sep = " "), # title
'<br>',
'</sup>',
'<br>')
)
)
return(case_plotly_default)
}
# active cases
case_active_plot_function <- function(case_dataframe){
case_county_plot <- ggplot(case_dataframe, aes(x = lubridate::as_date(Date), y = avg_active.cases,
group = 1,
text = paste0("Date: ", lubridate::as_date(Date)%>% format('%b %d, %Y'), "<br>",
"Active cases ", round(avg_active.cases, 0))# end paste0 call
))+
geom_bar(position = "dodge", stat= "identity")+
theme(plot.background = element_blank()) +
theme(panel.background = element_blank()) +
theme(panel.grid.major.y = element_line(color = "grey")) +
xlab("") +
ylab("Active cases (total)")+
labs(caption = "")+
theme(axis.text.x=element_text(hjust=1),
text = element_text(size=12))+
theme_minimal()+
xlim(min(lubridate::as_date(case_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))
case_county_plot
case_plotly_default <- ggplotly(case_county_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",
case_dataframe$County, "County reported active cases (lab confirmed)", sep = " "), # title
'<br>',
'<sup>',
"7-day rolling average", # subtitle
'</sup>',
'<br>')
)
)
return(case_plotly_default)
}
# positivity
case_positivity_plot_function <- function(case_dataframe){
case_county_plot <- ggplot(case_dataframe, aes(x = lubridate::as_date(Date), y = avg_positivity,
text = paste0("Date: ", lubridate::as_date(Date) %>% format('%b %d, %Y'), "<br>",
"Positivity ", round(avg_positivity, 2))# end paste0 call
))+
geom_bar(position = "dodge", stat= "identity")+
theme(plot.background = element_blank()) +
theme(panel.background = element_blank()) +
theme(panel.grid.major.y = element_line(color = "grey")) +
xlab("") +
ylab("Test positivity (percent)")+
labs(caption = "")+
theme(axis.text.x=element_text(hjust=1),
text = element_text(size=12))+
theme_minimal()+
xlim(min(lubridate::as_date(case_dataframe$Date)), max(lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))#
case_county_plot
case_plotly_default <- ggplotly(case_county_plot,
tooltip = c("text")) %>%
layout(title = list(text = paste0(paste("<br>",
case_dataframe$County, "County positive test rate (reported cases only)", sep = " "), # title
'<br>',
'<sup>',
"7-day rolling average", # subtitle
'</sup>',
'<br>')
),
margin=list(t = 75)
)
return(case_plotly_default)
}
# barplot
case_plotly <- case_plot_function(case_dataframe =county.case)
output$county_case_plotly <- renderPlotly(case_plotly)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
output$county_active_plotly <- renderPlotly(active_plotly)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
# button press to display description of case plot
observeEvent(input$caseText_button, {
toggle("caseText_wrapper")
})
##############
# update case data with clicked county data
##############
observeEvent(input$NYBetaMap_shape_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
sewershed_plot <- wastewater.historic %>%
filter(County == click$id)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# grab county data
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County)%>%
filter(Date >= min(sewershed_plot$Date))
case_plotly <- case_plot_function(case_dataframe =county.case)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
# return case plotly
if(!is.null(click$id)){
output$county_case_plotly <- renderPlotly(case_plotly)
}
# return active plotly
if(!is.null(click$id)){
output$county_active_plotly <- renderPlotly(active_plotly)
}
# return positivity plotly
if(!is.null(click$id)){
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
}
})
####
# update catchment ggplot when click circle marker
###
# filter historic sewershed data and create plot
observeEvent(input$NYBetaMap_marker_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_marker_click
sewershed_plot <- wastewater.historic %>%
filter(WWTP_ID == click$id)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# function to create plots
sewershed_plotly_default <- sewershed_ww_plot_function(sewershed_plot)
# use recent function if currently monitoring with two week trend, otherwise use historic function
if (click$id %in% wastewater_recent$WWTP_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
} else if (!click$id %in% wastewater_recent$WWTP_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_historic(sewershed_plot)
}
# update radio buttons
if(sewershed_plot$trend_measure == "intensity"){
updateRadioButtons(session, "ww_trend", selected = "intensity")
}
if(sewershed_plot$trend_measure == "raw gene copies"){
updateRadioButtons(session, "ww_trend", selected = "raw gene copies")
}
# render plots
if(!is.null(click$id)){
output$sewershed_plotly_default <- renderPlotly(sewershed_plotly_default)
}
if(!is.null(click$id)){
output$sewershed_plotly_default_log <- renderPlotly(sewershed_plotly_default_log)
}
})
###
###
# update county plot when click circle marker on ny map
###
observeEvent(input$NYBetaMap_marker_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_marker_click
sewershed_plot <- wastewater.historic %>%
filter(WWTP_ID == click$id)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# grab county data
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County)%>%
filter(Date >= min(sewershed_plot$Date))
case_plotly <- case_plot_function(case_dataframe =county.case)
#output$county_case_plotly <- renderPlotly(case_plotly)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
# return nothing if na click
if(!is.null(click$id)){
output$county_case_plotly <- renderPlotly(case_plotly)
}
# return nothing if na click
if(!is.null(click$id)){
output$county_active_plotly <- renderPlotly(active_plotly)
}
# return positivity plotly
if(!is.null(click$id)){
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
}
})
#### CLICK A COUNTY, ZOOM INTO THAT COUNTY ####
observe({
click <- input$NYBetaMap_shape_click
if(is.null(click))
return()
observe({
#capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
#obtain wwtp catchments
county.catchment.click <- wwtp.map %>%
filter(County == click$id)
#stop if empty df
req(!is.na(county.catchment.click$SW_ID))
# create bounding object for county zoom
Bounds <- as.list(st_bbox(county.catchment.click)) #get the bounds for the catchments
# proxy map to zoom into county
proxy_map <- leafletProxy("NYBetaMap"
) %>%
fitBounds(Bounds$xmin, Bounds$ymin, Bounds$xmax, Bounds$ymax)
})
})
###
# update catchment ggplot when click sewershed polygon
###
observeEvent(input$NYBetaMap_shape_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
sewershed_plot <- wastewater.historic %>%
filter(SW_ID == click$id)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# function to create wastewater trend plots
sewershed_plotly_default <- sewershed_ww_plot_function(sewershed_plot)
# use recent function if currently monitoring with two week trend, otherwise use historic function
if (click$id %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
} else if (!click$id %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_historic(sewershed_plot)
}
# update radio buttons
if(sewershed_plot$trend_measure == "intensity"){
updateRadioButtons(session, "ww_trend", selected = "intensity")
}
if(sewershed_plot$trend_measure == "raw gene copies"){
updateRadioButtons(session, "ww_trend", selected = "raw gene copies")
}
if(!is.null(click$id)){
output$sewershed_plotly_default <- renderPlotly(sewershed_plotly_default)
}
if(!is.null(click$id)){
output$sewershed_plotly_default_log <- renderPlotly(sewershed_plotly_default_log)
}
})
######################################################
# update sewershed trend when click county #
######################################################
observeEvent(input$NYBetaMap_shape_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
sewershed_plot <- wastewater.historic %>%
filter(County == click$id)
# select default catchment if more than one
county_catchment_default <- head(sewershed_plot, 1)
sewershed_plot <- sewershed_plot %>% filter(SW_ID %in% county_catchment_default$SW_ID)
#stop if empty df
req(!is.na(sewershed_plot$IntensityDNA))
#simple ggplot then turn to ggplotly
# function to create plot
sewershed_plotly_default <- sewershed_ww_plot_function(sewershed_plot)
# use recent function if currently monitoring with two week trend, otherwise use historic function
if (sewershed_plot$SW_ID %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
} else if (!sewershed_plot$SW_ID %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_historic(sewershed_plot)
}
# update radio buttons
if(sewershed_plot$trend_measure == "intensity"){
updateRadioButtons(session, "ww_trend", selected = "intensity")
}
if(sewershed_plot$trend_measure == "raw gene copies"){
updateRadioButtons(session, "ww_trend", selected = "raw gene copies")
}
if(!is.null(click$id)){
output$sewershed_plotly_default <- renderPlotly(sewershed_plotly_default)
}
if(!is.null(click$id)){
output$sewershed_plotly_default_log <- renderPlotly(sewershed_plotly_default_log)
}
})
###
# update county case plot when click sewershed on ny map
###
observeEvent(input$NYBetaMap_shape_click, {
#capture the info of the clicked polygon
click <- input$NYBetaMap_shape_click
sewershed_plot <- wastewater.historic %>%
filter(SW_ID == click$id)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# grab county data
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County)%>%
filter(Date >= min(sewershed_plot$Date))
case_plotly <- case_plot_function(case_dataframe =county.case)
#output$county_case_plotly <- renderPlotly(case_plotly)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
# return nothing if na click
if(!is.null(click$id)){
output$county_case_plotly <- renderPlotly(case_plotly)
}
# return nothing if na click
if(!is.null(click$id)){
output$county_active_plotly <- renderPlotly(active_plotly)
}
# return positivity plotly
if(!is.null(click$id)){
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
}
})
#########
#### UPDATE PLOTS WHEN SELECT A COUNTY IN DROPDOWN ####
# update sewershed trend when select county
observeEvent(input$county_map_toggle, {
#capture the info of county dropdown
county_selection <- input$county_map_toggle
sewershed_plot <- wastewater.historic %>%
filter(County == county_selection)
# select default catchment if more than one
county_catchment_default <- head(sewershed_plot, 1)
sewershed_plot <- sewershed_plot %>% filter(SW_ID %in% county_catchment_default$SW_ID)
#stop if empty df
req(!is.na(sewershed_plot$IntensityDNA))
#simple ggplot then turn to ggplotly
# function to create plot
sewershed_plotly_default <- sewershed_ww_plot_function(sewershed_plot)
# use recent function if currently monitoring with two week trend, otherwise use historic function
if (sewershed_plot$SW_ID %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_recent(sewershed_plot)
} else if (!sewershed_plot$SW_ID %in% wastewater_recent$SW_ID) {
sewershed_plotly_default_log <-sewershed_ww_plot_function_log_historic(sewershed_plot)
}
# update radio buttons
if(sewershed_plot$trend_measure == "intensity"){
updateRadioButtons(session, "ww_trend", selected = "intensity")
}
if(sewershed_plot$trend_measure == "raw gene copies"){
updateRadioButtons(session, "ww_trend", selected = "raw gene copies")
}
if(!is.null(input$county_map_toggle)){
output$sewershed_plotly_default <- renderPlotly(sewershed_plotly_default)
}
if(!is.null(input$county_map_toggle)){
output$sewershed_plotly_default_log <- renderPlotly(sewershed_plotly_default_log)
}
})
#### update county case plot when click sewershed on ny map ####
observeEvent(input$county_map_toggle, {
#capture the info of the dropdown selection
county_selection <- input$county_map_toggle
sewershed_plot <- wastewater.historic %>%
filter(County == county_selection)
#stop if empty df
req(!is.na(sewershed_plot$trend_value))
# grab county data
county.case <- all.cases %>%
filter(County %in% sewershed_plot$County)%>%
filter(Date >= min(sewershed_plot$Date))
case_plotly <- case_plot_function(case_dataframe =county.case)
#output$county_case_plotly <- renderPlotly(case_plotly)
active_plotly <- case_active_plot_function(case_dataframe = county.case)
positivity_plotly <- case_positivity_plot_function(case_dataframe = county.case)
# return nothing if na click
if(!is.null(input$county_map_toggle)){
output$county_case_plotly <- renderPlotly(case_plotly)
}
# return nothing if na click
if(!is.null(input$county_map_toggle)){
output$county_active_plotly <- renderPlotly(active_plotly)
}
# return positivity plotly
if(!is.null(input$county_map_toggle)){
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)Blank dashboard code
Use this code as a framework for your own dashboard.
###################################
# BLANK APP #
###################################
#### PACKAGE GROUPS ####
# shiny app support packages
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyBS)
library(shinyjs)
library(shinyalert)
library(shinycssloaders)
#library(htmlwidgets) # check this one
library(htmltools) # check this one
# data processing (spatial and nonspatial)
library(sf)
library(aws.s3)
library(dplyr)
library(tidyr)
library(magrittr)
library(purrr)
library(stringr)
library(lubridate)
#library(tigris) # do we use this still?
#library(rgdal) # do we still use this one?
#library(scales) # check this one
# leaflet packages
library(leaflet)
library(leaflet.extras)
# figure and table creation
library(ggplot2)
#library(ggthemes) #check this one
library(plotly)
library(gt)
#------------------------------------------------------------------------------------------------------------------------------------------------------
### GLOBAL ENVIRONMENT DATA LOADING AND PREPROCESSING PLACE HERE ###
### REACTIVE DATES ###
update_date <- lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')
last_sample_date <- today() %>% format('%b %d, %Y')
#------------------------------------------------------------------------------------------------------------------------------------------------------
#------------------------------------------------------------------------------------------------------------------------------------------------------
############# APP STARTS HERE #######################
# Define UI
ui <-
function(req){
dashboardPage(
dashboardHeader(title = "Title", # title in the box at top of the page
titleWidth = 450), # this titlewidth is linked to the sidebar
# SIDEBAR CONTENT #
dashboardSidebar( width = 225,
# SIDEBAR MENU #
sidebarMenu(id = "sidebarid",
# STYLE ARGUMENT USES CSS CODE
style = "position:fixed; width:auto; overflow-x: clip;", # keeps the sidebar content from scrolling
# MENU ITEMS THAT ARE TABS ON THE SIDEBAR
menuItem("State Dashboard", tabName = "dashboard", icon = icon("dashboard")), # tabName is called below in the tab argument
menuItem("Resources and toolkit", tabName = "resources", icon = icon("file-alt")),
menuItem("Information", icon = icon("info"), tabName = "Information"),
### CONDITIONAL PANEL FOR SIDEBAR BUTTONS ON MAIN DASHBAORD PAGE ###
# we add this here so that the buttons only show up on the dashboard page (see condition = below)
conditionalPanel(
condition = 'input.sidebarid == "dashboard"',
# RADIO BUTTONS FOR FIRST PLOT SHOWING TRENDS
radioButtons("ww_trend", # id for radio button series
"Wastewater trend", # title of button series
c("SARS-CoV-2 intensity" = "intensity", # plot 1 is the intensity, log refers to the ID of the object
"Gene copies" = "raw gene copies" #plot 2 is the gene copies, gene is the ID of the object to display
),
width = 225),
# TOOLTIP FOR TREND PLOTS
bsTooltip("ww_trend",
"Switch between intensity and gene copies ", ),
# RADIO BUTTONS FOR SECOND PLOT SHOWING CASE DATA
radioButtons("case_switch", # id for the radio button series
"Cases data", # title of button series
c("New cases" = "new_cases",
"Active cases" = "active_cases",
"Test positivity" = "positivity"),
width = 225),
# TOOLTIP FOR CASE PLOT
bsTooltip("case_switch", #"county_case_plotly",
"Switch the case plots between new cases, active cases, and positivity.",
"bottom", )
) # close conditional panel
) # close sidebar menu
), # close dashboard sidebar argument
dashboardBody(
useShinyjs(), #for shinyjs code to work
useShinyalert(), # Set up shinyalert
# CSS style arguments (e.g., font size)
# increase size of acutal map display based on window
tags$style(type = "text/css", "#NYBetaMap {height: calc(100vh - 80px) !important;}"), # NYBetaMap is the ID of the object to modify
tags$head(tags$style('.selectize-dropdown {z-index: 10000}')), # this makes the state_map_toggle overlay the leaflet
tabItems(
tabItem(tabName = "dashboard",
# web issues box
# update list
#fluidRow(
# box(width = 12,
# title = "Note: Browser issues", background = "red",
# "We are aware of issues regarding the dashboard not working as it should in certain browsers (i.e., Google Chrome). We recommend trying
# a different browser (e.g., Safari, Edge) or clearing the cache on your browser."
#) # end update box
# ), # end fluid row update box
# update list
# fluidRow(
# box(width = 12,
# title = "Update: August 2022", background = "green",
# p("New York City data are now available and reported weekly. For more information on methods used for SARS-CoV-2 detection in New York City, please visit",
# tags$a(href = "https://doi.org/10.1039/D1EW00747E", "this website.", style = "color: darkblue;"),
# "For access to New York City historical data, please visit: ",
# tags$a(href = "https://data.cityofnewyork.us/Health/SARS-CoV-2-concentrations-measured-in-NYC-Wastewat/f7dc-2q9f/data", "this website.",
# style = "color: darkblue;")
# )
#
# ) # end update box
#), # end fluid row update box
fluidRow(
column(12,
h2("Intro title"),
p("Optional introductory text"),
br(), # line break between paragraphs
)# end column argument
), # end fluid row opening paragraph
# VALUE BOXES WITH STATE SUMMARIES #
fluidRow(column(width = 12, h2(HTML(paste("Statewide participation summary", "<sup>", "1", "</sup>"))))),
fluidRow(
# number of counties actively reporting
valueBox( value = 1000,
subtitle = "Participating counties",
color = "light-blue",
icon = icon("map")
),
# number of treatment plants reporting
valueBox( value = 100,
#subtitle = "Participating WWTPs",
subtitle = "Participating WWTPs",
color = "aqua",
icon = icon("water")
),
# population covered
valueBox( value = formatC(14500000, format="d", big.mark=","),
subtitle = "Population covered",
color = "blue",
icon = icon("users"))
), # end fluid row summary boxes
fluidRow(column(width = 12, p(HTML(paste("<sup>", "1", "</sup>", "Participation as of ", lubridate::today(tzone = 'America/New_York') %>% format('%b %d, %Y')))))),
# UPDATE INFORMATION ROW
fluidRow(column(12,
titlePanel(h3(paste("Last Updated: ", update_date, sep = ""))),
titlePanel(h3(paste("Most recent sample: ", last_sample_date, sep = "")))
)
), # end fluid row
br(),
# MAIN DASHBOARD MAP (ID = NYBetaMap)
fluidRow(box(width = 12, id = "map_container",
title = "Map of participating treatment plants and counties",
column(width = 8,
# withspinner adds loading icon
withSpinner(
leafletOutput('NYBetaMap'),
type = 8), # type of loading icon to show
fluidRow(# create action button to show or hide description
actionButton(inputId = "button_map", label = "Map description show / hide", width = 250)
) # close fluid row
), # close column
# RIGHT OF MAP SIDEBAR #
column(width = 4,
# MAIN MAP TOGGLE SELECTIONS AND BUTTONS
fluidRow(selectInput(inputId = "state_map_toggle", label = "Wastewater Metric",
choices = c("SARS-CoV-2 detection level" = "Alert_factor",
"Two week trend" = "Trend_factor"),
selected = "SARS-CoV-2 detection level"
)# end select input
), # close fluid row
# CATEGORY CHANGE TABLES
fluidRow(wellPanel(id = "category_tables",
conditionalPanel(condition = "input.state_map_toggle == 'Alert_factor'",
gt_output("alert_table")
), # close conditional panel
conditionalPanel(condition = "input.state_map_toggle == 'Trend_factor'",
gt_output("trend_table")
) # close conditional panel
) # close well panel
), # close fluid row
# CATEGORY CHANGE DESCRIPTION
fluidRow(wellPanel(
conditionalPanel(condition = "input.state_map_toggle == 'Alert_factor'",
box(width = 12, title = "SARS-CoV-2 detection level",
p("SARS-CoV-2 detection level is displayed in three categories: Low, Moderate, and Substantial to High.
Current estimated levels are based on the highest detection reported from the most recent three samples. These detection levels have
been shown to correlate with estimated community transmission levels. Category change in the last 15 days is calculated by subtracting
the current number of sites in each current level category from the number of sites in the same category 15 days earlier and dividing by
the number of sites in the same category 15 days earlier.
See the Map description for more detailed information."))
), # close conditional panel
conditionalPanel(condition = "input.state_map_toggle == 'Trend_factor'",
box(width = 12, title = "Two-week trend",
p("To identify how wastewater results are changing over time, trend analysis is conducted on the most recent data. A two-week trend is
calculated for each location using all data points within the fifteen previous days of the most recent sample for that location.
The trend analysis calculates the average change in the SARS-CoV-2 Intensity over the fifteen-day period using a linear
regression. Sites with fewer than two samples within the fifteen-day window appear as NA values. Category change in the last 15 days is
calculated by subtracting the current number of sites in each current level category from the number of sites in the same category 15
days earlier and dividing by the number of sites in the same category 15 days earlier.
See the Map description for more
detailed information.")
) # close box
)# close conditional panel
)# close well panel
) # close fluid row
) # close column
), #close map box
), # end map fluidrow
# new tooltip to try
# NYBetaMap TOOLTIP #
bsTooltip("NYBetaMap",
"Zoom in or click a county to see sewersheds. Click a marker or catchment to see wastewater trends (displayed below).",
trigger = "hover",
"bottom", ),
# map container second TOOLTIP #
bsTooltip("map_container",
"Zoom in or click a county to see sewersheds. Click a marker or catchment to see wastewater trends (displayed below).",
trigger = "hover",
"top", ),
br(),
# NYBetaMap DESCRIPTION (observe event is in the server)
hidden(div(id = "maptext_wrapper",
box(id = "mapText", title = "Map description", width = 12,
h4("Header"),
# disclaimer on state of the science
p("optional description text")
) # end box
)# end div
), # end hidden,
# WASTEWATER TREND PLOTS
# created in a well panel and conditional panel linked to the radio buttons above
br(),
fluidRow(
box(width = 12, title = "Wastewater trend",
wellPanel(id = "sewershed_plots",
conditionalPanel(
condition = "input.ww_trend == 'intensity'",
withSpinner(plotlyOutput("sewershed_plotly_default_log"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.ww_trend == 'raw gene copies'",
withSpinner(plotlyOutput("sewershed_plotly_default"), type = 8) # add loading icon
)
),# end well panel
column(12, actionButton(inputId = "button_trendText", label = "Trend graph description show / hide", width = 250)
)# end column
)# end box
), # end fluidrow
bsTooltip("sewershed_plots", #"sewershed_plotly_default",
"This plot shows the trend values for SARS CoV-2 detected in wastewater at the selected treatment plant.",
"bottom", ),
# sewershed trend plot description
hidden(
div(id = "trendPlotText_wrapper",
box(id = "trendPlotText", title = "Wastewater trend description", width = 12,
h4("Header"),
p("optional text")
) # end box
)# end div
), # end hidden
br(),
#fluidRow(
# box(width = 12,
# plotlyOutput("county_case_plotly"))
#),
fluidRow(
box(width = 12, title = "Case data",
wellPanel(id = "case_plots", conditionalPanel(
condition = "input.case_switch == 'new_cases'",
withSpinner(plotlyOutput("county_case_plotly"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.case_switch == 'active_cases'",
withSpinner(plotlyOutput("county_active_plotly"), type = 8) # add loading icon
),
conditionalPanel(
condition = "input.case_switch == 'positivity'",
withSpinner(plotlyOutput("county_positivity_plotly"), type = 8) # add loading icon
)
),
column(12, actionButton(inputId = "caseText_button", label = "Case plot description show / hide", width = 250))
)# end box
), # end fluid row
# case plot tooltip
bsTooltip("case_plots", #"county_case_plotly",
"This plot shows the total positive test results for the county.",
"bottom", ),
# case plot description popup
hidden(
div(id = "caseText_wrapper",
box(id = "caseText", title = "Case plot description", width = 12,
h4("Header"),
p("optional text")
) # end box
)# end div
)# end hidden
###############
),
tabItem(tabName = "resources",
fluidRow(
column(12
) # close column
) # close fluid row
),
tabItem(tabName = "Information",
fluidRow(
column(12
) # end column
)# end fluid row
) # end tab item
)# end tab items plural
) # end dashboard body
)# end dashboardPage
} # close function for ui
###################### SERVER ############################
server <- function(input, output, session) {
## helper command to keep app open longer ##
output$clock = renderText({
invalidateLater(4500)
Sys.time()
})
###### LEAFLET MAP #######
# create map for renders
nybetamap_preset <- leaflet() %>%
addMapPane("tiles", zIndex = 400) %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Base map",
options = c(pathOptions(pane = "tiles"))) %>%
addProviderTiles(providers$Stamen.TonerLines, group = "Base map",
options = c(providerTileOptions(opacity = 0.35), pathOptions(pane = "tiles")))%>%
addProviderTiles(providers$Stamen.TonerLabels,group = "Base map",
options = pathOptions(pane = "tiles"))
##### PRESET STATE MAP FOR STATE MAP VIEW BUTTON #####
# render output
output$NYBetaMap <- renderLeaflet({
nybetamap_preset
})
# button press to display description of map
observeEvent(input$button_map, {
toggle("maptext_wrapper")
})
# sample ggplot for the first plot
default_ww_plot <-ggplotly(ggplot(mpg, aes(displ, hwy, colour = class)) +
geom_point())
output$sewershed_plotly_default <- renderPlotly(default_ww_plot)
# sample ggplot for the second plot behind the wellpanel
default_ww_plot_log <-ggplotly(ggplot(mpg, aes(displ, hwy, colour = class)) +
geom_line())
output$sewershed_plotly_default_log <- renderPlotly(default_ww_plot_log)
# button press to display description of plot
observeEvent(input$button_trendText, {
toggle("trendPlotText_wrapper")
})
# barplot
case_plotly <- ggplotly(ggplot(mpg, aes(displ, hwy, fill = class)) +
geom_bar(position = "stack", stat= "identity"))
output$county_case_plotly <- renderPlotly(case_plotly)
active_plotly <- ggplotly(ggplot(mpg, aes(displ, year, fill = class)) +
geom_bar(position = "stack", stat= "identity"))
output$county_active_plotly <- renderPlotly(active_plotly)
positivity_plotly <- ggplotly(ggplot(mpg, aes(displ, trans, fill = class)) +
geom_bar(position = "stack", stat= "identity"))
output$county_positivity_plotly <- renderPlotly(positivity_plotly)
# button press to display description of case plot
observeEvent(input$caseText_button, {
toggle("caseText_wrapper")
})
}
# Run the application
shinyApp(ui = ui, server = server)References
Attali, D. (2021). shinyjs: Easily Improve the User Experience of Your Shiny Apps in Seconds (2.1.0).https://CRAN.R-project.org/package=shinyjs
Attali, D., & Edwards, T. (2021). shinyalert: Easily Create Pretty Popup Messages (Modals) in “shiny” (3.0.0) [R].https://CRAN.R-project.org/package=shinyalert
Bache, S. M., & Wickham, H. (2022). magrittr: A Forward-Pipe Operator for R (2.0.3) [R].https://CRAN.R-project.org/package=magrittr
Bailey, E. (2022). ShinyBS: Twitter Bootstrap Components for shiny (0.61.1) [R].https://CRAN.R-project.org/package=shinyBS
Chang, W., & Borges Ribeiro, B. (2021). shinydashboard: Create Dashboards with “shiny” (0.7.2) [R].
Chang, W., Cheng, J., Allaire, J. J., Sievert, C., Schloerke, B., Xie, Y., Allen, J., McPherson, J., DiPert, A., & Borges, B. (2021). shiny: Web Application Framework for R (1.7,1).
Cheng, J., Karambelkar, B., & Xie, Y. (2022). leaflet: Create Interactive Web Maps with the JavaScript ’Leaflet" Library (2.1.1) [R].https://CRAN.R-project.org/package=leaflet
Cheng, J., Sievert, C., Schloerke, B., Chang, W., Xie, Y., & Allen, J. (2021). htmltools: Tools for HTML (0.5.2).https://CRAN.R-project.org/package=htmltools
DOH. (2022). COVID-19 Data in New York | Department of Health. https://coronavirus.health.ny.gov/covid-19-data-new-york Granjon, D. (2021). shinydashboardPlus: Add More “AdminLTE2” Components to “shinydashboard” (2.0.3) [R]. https://CRAN.R-project.org/package=shinydashboardPlus
Grolemund, G., & Wickham, H. (2011). Dates and Times Made Easy with lubridate. Journal of Statistical Software, 40, 1–25. https://doi.org/10.18637/jss.v040.i03
Henry, L., & Wickham, H. (2020). purrr: Functional Programming Tools (0.3.4) [R]. https://CRAN.R-project.org/package=purrr Iannone, R., Cheng, J., & Schloerke, B. (2022). gt: Easilty Create Presentation-Ready Display Tables (0.6.0) [R]. https://CRAN.R-project.org/package=gt
Karambelkar, B., & Schloerke, B. (2018). leaflet.extras: Extra Functionality for “leaflet” Package (1.0.0) [R]. https://CRAN.R-project.org/package=leaflet.extras
Larsen, D. A., Collins, M. B., Du, Q., Hill, D., Insaf, T. Z., Kilaru, P., Kmush, B. L., Middleton, F., Stamm, A., Wilder, M. L., Zeng, T., & Green, H. (2022). Coupling freedom from disease principles and early warning from wastewater surveillance to improve health security. PNAS Nexus, 1(1), pgac001. https://doi.org/10.1093/pnasnexus/pgac001
Leeper, T. J. (2020). aws.s3: AWS S3 Client Package (0.3.21) [R].
Pebesma, E. (2018). Simple features for R: Standardized support for spatial vector data. The R Journal, 10(1), 439–446. https://doi.org/10.32614/RJ-2018-009
Sail, A., & Attali, D. (2020). shinycssloaders: Add Loading Animations to a “shiny” Output while It’s Recalculating (1.0.0) [R]. https://CRAN.R-project.org/package=shinycssloaders
Sievert, C. (2020). Interactive Web-Based Data Visualization with R, plotly, and shiny. Chapman and Hall/CRC. https://plotly-r.com
Wickham, H. (n.d.). ggplot2: Elegant Graphics for Data Analysis. Springer-Verlag New York. https://ggplot2.tidyverse.org
Wickham, H. (2019). stringr: Simple, Consistent Wrappers for Common String Operations (1.4.0) [R]. https://CRAN.R-project.org/package=stringr
Wickham, H., Francois, R., Henry, L., & Muller, K. (2022). dplyr: A Grammar of Data Manipulation (1.0.9) [R]. https://CRAN.R-project.org/package=dplyr
Wickham, H., & Girlich, M. (2022). tidyr: Tidy Messy Data (1.2.0) [R]. https://CRAN.R-project.org/package=tidyr