Skip to content
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
111 changes: 57 additions & 54 deletions dashboard/app.R
Original file line number Diff line number Diff line change
Expand Up @@ -9,10 +9,7 @@ library(shinyjs)
library(tsibble)
library(aws.s3)

COVERAGE_INTERVALS = c("10", "20", "30", "40", "50", "60", "70", "80", "90", "95", "98")
DEATH_FILTER = "deaths_incidence_num"
CASE_FILTER = "confirmed_incidence_num"
TOTAL_LOCATIONS = "Totaled Over States*"
source('./common.R')

# Score explanations
wisExplanation = includeMarkdown("wis.md")
Expand All @@ -32,9 +29,12 @@ if(length(cssFiles)!=1){
cssFile = cssFiles[1]
cat(file=stderr(),"Loaded css file:",cssFile,"\n")

source('./export_scores.R')

########
# Layout
########

ui <- fluidPage(padding=0,
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = cssFile)
Expand All @@ -48,7 +48,7 @@ ui <- fluidPage(padding=0,
)
),
div(id="title", class="col-sm-6",
HTML("FORECAST <span id='bold-title'>EVALUATION DASHBOARD</span> <a id='back-button' href='https://delphi.cmu.edu'>",
HTML("FORECAST <span id='bold-title'>EVALUATION DASHBOARD</span> <a id='back-button' href='https://delphi.cmu.edu'>",
includeHTML("arrow-left.svg"), " Back</a>"),
),
div(id="github-logo-container", class="col-sm-1",
Expand All @@ -63,10 +63,10 @@ ui <- fluidPage(padding=0,
sidebarPanel(id = "inputOptions",
conditionalPanel(condition = "input.tabset == 'evaluations'",
radioButtons("targetVariable", "Target Variable",
choices = list("Incident Deaths" = "Deaths",
choices = list("Incident Deaths" = "Deaths",
"Incident Cases" = "Cases")),


radioButtons("scoreType", "Scoring Metric",
choices = list("Weighted Interval Score" = "wis",
"Spread" = "sharpness",
Expand Down Expand Up @@ -94,7 +94,7 @@ ui <- fluidPage(padding=0,
),
tags$p(id="forecaster-disclaimer", "Some forecasters may not have data for the chosen location or scoring metric"),
checkboxGroupInput(
"aheads",
"aheads",
"Forecast Horizon (Weeks)",
choices = c(1,2,3,4),
selected = 1,
Expand All @@ -119,11 +119,13 @@ ui <- fluidPage(padding=0,
)
),
tags$hr(),
export_scores_ui,
tags$hr(),
),
includeMarkdown("about-dashboard.md"),
width=3,
),

mainPanel(
width=9,
tabsetPanel(id = "tabset",
Expand Down Expand Up @@ -151,7 +153,7 @@ ui <- fluidPage(padding=0,
fluidRow(column(11, textOutput('renderWarningText'))),
plotlyOutput(outputId = "summaryPlot", height="auto"),
fluidRow(
column(11, offset=1,
column(11, offset=1,
div(id="refresh-colors", actionButton(inputId="refreshColors", label= "Recolor"))
)),
tags$br(),
Expand All @@ -174,7 +176,6 @@ ui <- fluidPage(padding=0,
tags$br()
)
)

)
),
),
Expand All @@ -194,7 +195,7 @@ server <- function(input, output, session) {
return(NULL)
}
)

# Get and prepare data
getData <- function(filename){
if(!is.null(s3bucket)) {
Expand All @@ -211,7 +212,7 @@ server <- function(input, output, session) {
getFallbackData(filename)
}
}

getFallbackData = function(filename) {
path = ifelse(
file.exists(filename),
Expand All @@ -220,12 +221,12 @@ server <- function(input, output, session) {
)
readRDS(path)
}

dfStateCases <- getData("score_cards_state_cases.rds")
dfStateDeaths <- getData("score_cards_state_deaths.rds")
dfNationCases = getData("score_cards_nation_cases.rds")
dfNationDeaths = getData("score_cards_nation_deaths.rds")

# Pick out expected columns only
covCols = paste0("cov_", COVERAGE_INTERVALS)
expectedCols = c("ahead", "geo_value", "forecaster", "forecast_date",
Expand All @@ -237,18 +238,18 @@ server <- function(input, output, session) {
dfStateDeaths = dfStateDeaths %>% select(all_of(expectedCols))
dfNationCases = dfNationCases %>% select(all_of(expectedCols))
dfNationDeaths = dfNationDeaths %>% select(all_of(expectedCols))

df <- rbind(dfStateCases, dfStateDeaths, dfNationCases, dfNationDeaths)
df <- df %>% rename("10" = cov_10, "20" = cov_20, "30" = cov_30, "40" = cov_40, "50" = cov_50, "60" = cov_60, "70" = cov_70, "80" = cov_80, "90" = cov_90, "95" = cov_95, "98" = cov_98)

# Prepare color palette
colorSeed = 100

# Prepare input choices
forecasterChoices = sort(unique(df$forecaster))
updateForecasterChoices(session, df, forecasterChoices, 'wis')


##################
# CREATE MAIN PLOT
##################
Expand All @@ -262,13 +263,13 @@ server <- function(input, output, session) {
if (targetVariable == "Deaths") {
signalFilter = DEATH_FILTER
}
scoreDf = scoreDf %>%
scoreDf = scoreDf %>%
filter(signal == signalFilter) %>%
filter(ahead %in% horizon) %>%
filter(forecaster %in% forecasters)

filteredScoreDf <- scoreDf %>% rename(Forecaster = forecaster, Week_End_Date = target_end_date)

if (scoreType == "wis" || scoreType == "sharpness") {
# Only show WIS or Sharpness for forecasts that have all intervals
filteredScoreDf = filteredScoreDf %>% filter(!is.na(`50`)) %>% filter(!is.na(`80`)) %>% filter(!is.na(`95`))
Expand Down Expand Up @@ -299,7 +300,7 @@ server <- function(input, output, session) {
if (allLocations || scoreType == "coverage") {
filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score))
# Create df with col for all locations across each unique date, ahead and forecaster combo
locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>%
locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>%
summarize(location_list = paste(sort(unique(geo_value)),collapse=","))
# Create a list containing each row's location list
locationList = sapply(locationDf$location_list, function(x) strsplit(x, ","))
Expand Down Expand Up @@ -345,15 +346,15 @@ server <- function(input, output, session) {
output$renderLocations <- renderText("")
output$renderWarningText <- renderText("")
}

# Render truth plot with observed values
showElement("truthPlot")
showElement("refresh-colors")
truthDf = filteredScoreDf
output$truthPlot <- renderPlotly({
truthPlot(truthDf, targetVariable, locationsIntersect, allLocations || scoreType == "coverage")
})

# Format and transform data
filteredScoreDf = filteredScoreDf[c("Forecaster", "Week_End_Date", "Score", "ahead")]
filteredScoreDf = filteredScoreDf %>% mutate(across(where(is.numeric), ~ round(., 2)))
Expand Down Expand Up @@ -382,15 +383,15 @@ server <- function(input, output, session) {
as_tsibble(key = c(Forecaster, ahead), index = Week_End_Date) %>%
group_by(Forecaster, ahead) %>%
fill_gaps(.full = TRUE)
filteredScoreDf$ahead = factor(filteredScoreDf$ahead, levels = c(1, 2, 3, 4),

filteredScoreDf$ahead = factor(filteredScoreDf$ahead, levels = c(1, 2, 3, 4),
labels = c("Horizon: 1 Week", "Horizon: 2 Weeks", "Horizon: 3 Weeks", "Horizon: 4 Weeks"))
set.seed(colorSeed)
forecasterRand <- sample(unique(df$forecaster))
colorPalette = setNames(object = viridis(length(unique(df$forecaster))), nm = forecasterRand)

p = ggplot(
filteredScoreDf,
filteredScoreDf,
aes(x = Week_End_Date, y = Score, color = Forecaster, shape = Forecaster)
) +
geom_line() +
Expand All @@ -399,7 +400,7 @@ server <- function(input, output, session) {
scale_x_date(date_labels = "%b %Y") +
facet_wrap(~ahead, ncol=1) +
scale_color_manual(values = colorPalette) +
theme_bw() +
theme_bw() +
theme(panel.spacing=unit(0.5, "lines")) +
theme(legend.title = element_blank())

Expand All @@ -412,23 +413,23 @@ server <- function(input, output, session) {
p = p + scale_y_continuous(limits = c(0,NA), labels = scales::comma)
}
plotHeight = 550 + (length(horizon)-1)*100
finalPlot <-
ggplotly(p,tooltip = c("x", "y", "shape")) %>%
finalPlot <-
ggplotly(p,tooltip = c("x", "y", "shape")) %>%
layout(
height = plotHeight,
legend = list(orientation = "h", y = -0.1),
margin = list(t=90),
height=500,
hovermode = 'x unified',
height = plotHeight,
legend = list(orientation = "h", y = -0.1),
margin = list(t=90),
height=500,
hovermode = 'x unified',
xaxis = list(
title = list(text = "Target Date",standoff = 8L),
title = list(text = "Target Date",standoff = 8L),
titlefont = list(size = 12))
) %>%
config(displayModeBar = F)

return(finalPlot)
}

###################
# CREATE TRUTH PLOT
###################
Expand All @@ -437,16 +438,16 @@ server <- function(input, output, session) {
titleText = paste0('<b>Observed Incident ', targetVariable, '</b>')
if (allLocations) {
titleText = paste0('<b>Observed Incident ', targetVariable, '</b>', ' <br><sup>Totaled over all states and territories common to selected forecasters*</sup>')
}
}
scoreDf <- scoreDf %>%
group_by(Week_End_Date) %>% summarize(Reported_Incidence = actual)

return (ggplotly(ggplot(scoreDf, aes(x = Week_End_Date, y = Reported_Incidence)) +
geom_line() +
geom_point() +
labs(x = "", y = "", title = titleText) +
scale_y_continuous(limits = c(0,NA), labels = scales::comma) +
scale_x_date(date_labels = "%b %Y") + theme_bw())
scale_x_date(date_labels = "%b %Y") + theme_bw())
%>% layout(hovermode = 'x unified')
%>% config(displayModeBar = F))
}
Expand All @@ -455,22 +456,22 @@ server <- function(input, output, session) {
# PLOT OUTPUT
#############
output$summaryPlot <- renderPlotly({
summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters,
summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters,
input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline)
})

###################
# EVENT OBSERVATION
###################

observeEvent(input$refreshColors, {
colorSeed = floor(runif(1, 1, 1000))
output$summaryPlot <- renderPlotly({
summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters,
summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters,
input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline)
})
})

# When the target variable changes, update available forecasters, locations, and CIs to choose from
observeEvent(input$targetVariable, {
if (input$targetVariable == 'Deaths') {
Expand All @@ -482,16 +483,16 @@ server <- function(input, output, session) {
updateLocationChoices(session, df, input$targetVariable, input$forecasters, input$location)
updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output)
})

observeEvent(input$scoreType, {
if (input$targetVariable == 'Deaths') {
df = df %>% filter(signal == DEATH_FILTER)
} else {
df = df %>% filter(signal == CASE_FILTER)
}
# Only show forecasters that have data for the score chosen
# Only show forecasters that have data for the score chosen
updateForecasterChoices(session, df, input$forecasters, input$scoreType)

if (input$scoreType == "wis") {
show("wisExplanation")
hide("sharpnessExplanation")
Expand Down Expand Up @@ -540,7 +541,7 @@ server <- function(input, output, session) {
updateLocationChoices(session, df, input$targetVariable, input$forecasters, input$location)
updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output)
})

# Ensure the minimum necessary input selections
observe({
# Ensure there is always one ahead selected
Expand All @@ -557,7 +558,9 @@ server <- function(input, output, session) {
if(input$scaleByBaseline && !("COVIDhub-baseline" %in% input$forecasters)) {
updateSelectInput(session, "forecasters", selected = c(input$forecasters, "COVIDhub-baseline"))
}
})
})

export_scores_server(input, output, df)
}

################
Expand Down
5 changes: 5 additions & 0 deletions dashboard/common.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@

COVERAGE_INTERVALS = c("10", "20", "30", "40", "50", "60", "70", "80", "90", "95", "98")
DEATH_FILTER = "deaths_incidence_num"
CASE_FILTER = "confirmed_incidence_num"
TOTAL_LOCATIONS = "Totaled Over States*"
42 changes: 42 additions & 0 deletions dashboard/export_scores.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,42 @@
source('./common.R')

create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) {
signalFilter = CASE_FILTER
if (targetVariable == "Deaths") {
signalFilter = DEATH_FILTER
}
scoreDf = scoreDf %>%
filter(signal == signalFilter) %>%
filter(ahead %in% horizon) %>%
filter(forecaster %in% forecasters)
if (loc != TOTAL_LOCATIONS) {
Copy link
Contributor

@kateharwood kateharwood Jun 30, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It seems that if loc == TOTAL_LOCATIONS, this download actually includes all locations. The downloaded file (with just the initial selections on app load selected) included AS, although it technically shouldn't since the baseline nor ensemble forecasters have data for that. It also technically shouldn't include the US, since that is not included in the plot either.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There is probably a cleaner way of doing it, but this is what I did in the app to find and reduce by the locations that all forecasters have data for:

      locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>%
        summarize(location_list = paste(sort(unique(geo_value)),collapse=","))

      # Create a list containing each row's location list
      locationList = sapply(locationDf$location_list, function(x) strsplit(x, ","))
      locationList = lapply(locationList, function(x) x[x != 'us'])

      # Get the intersection of all the locations in these lists
      locationsIntersect = unique(Reduce(intersect, locationList))
      filteredScoreDf = filteredScoreDf %>% filter(geo_value %in% locationsIntersect)```

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also now that I am adding hospitalizations which require even more data preprocessing (because of the difference in how the aheads work) this export function will probably need even more adjustments and require more decisions of what we actually want to show (the raw data vs the processed/filtered data that is shown in the plot). I can bring this up in our next meeting to get thoughts on what we want users to download.

scoreDf = scoreDf %>% filter(geo_value == tolower(loc))
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm wondering if we should include somewhere what locations are included when the user has selected total locations (not all of the locations are included - it is based on what forecasters are selected and which locations they have in common). But maybe that is not necessary...

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

how is this information currently shown in the user interface?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Currently it is shown at the bottom like this:
Screen Shot 2021-06-30 at 12 42 30 PM

}
return(scoreDf)
}

export_scores_ui = div(
downloadButton("exportScores", "Download CSV")
)

export_scores_server = function(input, output, df) {
output$exportScores <- downloadHandler(
filename = function() {
filename = paste0("forecast-eval-scores-", input$targetVariable)
if (input$location != TOTAL_LOCATIONS) {
filename = paste0(filename, '-', input$location)
}
paste0(filename,'-', Sys.Date(), ".csv")
},
contentType = 'text/csv',
content = function(file) {
withProgress(message = 'Preparing export',
detail = 'This may take a while...', value = 0, max = 2, {
out_df = create_export_df(df, input$targetVariable, input$forecasters, input$aheads, input$location)
incProgress(1)
write.csv(out_df, file, row.names=FALSE)
incProgress(2)
})
}
)
}