Commit b718467b authored by fabian.krueger's avatar fabian.krueger
Browse files

edit score table in app

parent a668f2c5
......@@ -53,7 +53,7 @@ cols_transp <- gsub(")", ", 0.5)", cols_transp, fixed = TRUE)
dat_truth <- list()
# DAX data:
getSymbols('^GDAXI',src='yahoo', from = as.Date("2021-09-01"))
getSymbols('^GDAXI',src='yahoo', from = as.Date("2021-09-01"))
dat_truth$DAX <- data.frame(date(GDAXI), value = GDAXI$GDAXI.Close)
colnames(dat_truth$DAX) <- c("time", "value")
dat_truth$DAX$time <- as.POSIXlt(dat_truth$DAX$time, "GMT") + 17.5*60*60
......@@ -84,7 +84,7 @@ for(i in seq_along(available_plot_data)){
# Define server logic:
shinyServer(function(input, output, session) {
# listen to "skip backward" button
observe({
# if pressed decreas input by 7 days
......@@ -93,13 +93,13 @@ shinyServer(function(input, output, session) {
if(!is.null(input$select_date) & input$skip_backward > 0){
new_date <- as.Date(input$select_date) - 7
if(as.character(new_date) %in% available_dates){
updateSelectInput(session = session, inputId = "select_date",
updateSelectInput(session = session, inputId = "select_date",
selected = as.character(new_date))
}
}
})
})
# listen to "skip forward" button
observe({
# if pressed increase input by 7 days
......@@ -108,30 +108,30 @@ shinyServer(function(input, output, session) {
if(!is.null(input$select_date) & input$skip_forward > 0){
new_date <- as.Date(input$select_date) + 7
if(as.character(new_date) %in% available_dates){
updateSelectInput(session = session, inputId = "select_date",
updateSelectInput(session = session, inputId = "select_date",
selected = as.character(new_date))
}
}
})
})
####### reactive handling of data sets:
# prepare data for plotting:
plot_data <- reactiveValues()
observe({
# a mapping to determine which trace corresponds to what (needed to replace things below)
temp <- list("selected_date" = 1, # 0 is grey area
"truth" = 14) # truth plotted on top of everything else
# indices of different forecasts: always one for shaded area, one for point forecast:
for(i in seq_along(plot_data$select_models)) temp[[plot_data$select_models[i]]] <- 2*i + 1 - 1:0
plot_data$mapping <- temp
# truth data as of selected date:
plot_data$truth <- NULL
# use the truth date corresponding to the input:
if(input$select_target == "DAX"){
# for DAX we need to take into account the value at the respective forecast date:
......@@ -141,15 +141,15 @@ shinyServer(function(input, output, session) {
colnames(truth_temp) <- c("time", "value")
plot_data$truth <- truth_temp
}
if(input$select_target == "temperature"){
plot_data$truth <- dat_truth$temperature
}
if(input$select_target == "wind"){
plot_data$truth <- dat_truth$wind
}
# get selected models from input:
plot_data$select_models <- c(input$select_models1,
input$select_models2,
......@@ -157,7 +157,7 @@ shinyServer(function(input, output, session) {
input$select_models4,
input$select_models5,
input$select_models6)
# y axis limit depending on target:
yl <- NULL
if(input$select_target == "DAX"){
......@@ -170,7 +170,7 @@ shinyServer(function(input, output, session) {
yl <- c(-20, 50)
}
plot_data$ylim <- yl
ylab <- NULL
if(input$select_target == "DAX"){
ylab <- paste("cumulative log return relative to", input$select_date)
......@@ -182,20 +182,20 @@ shinyServer(function(input, output, session) {
ylab <- "wind speed (km/h)"
}
plot_data$ylab <- ylab
# prepare plotting data for forecasts
if(!is.null(input$select_date)){
# run through models:
for(mod in models){
# only if not already loaded
#if(!is.null(forecast_data[[input$select_date]])){
# subset to required info:
subs <- subset(forecast_data[[input$select_date]],
target == input$select_target &
model == mod)
if(nrow(subs) > 0){
# prepare list of simple data frames for plotting:
points <- subs[, c("target_end_date", "q0.5")]
......@@ -212,11 +212,11 @@ shinyServer(function(input, output, session) {
lower <- subs[, c("target_end_date", "q0.025")]
upper <- subs[, c("target_end_date", "q0.975")]
}
colnames(points) <- colnames(lower) <- colnames(upper) <-
colnames(scores) <- c("x", "y")
intervals <- rbind(lower, upper[nrow(upper):1, ])
# store:
plot_data[[mod]] <- list(points = points, intervals = intervals, scores = scores)
}else{
......@@ -224,15 +224,15 @@ shinyServer(function(input, output, session) {
}
}
}
})
# initial plot:
output$tsplot <- renderPlotly({
# only run at start of app, rest is done in updates below
isolate({
# initialize plot:
p <- plot_ly(mode = "lines", hovertemplate = '%{y}', source = "tsplot") %>% # last argument ensures labels are completely visible
layout(yaxis = list(title = plot_data$ylab), # axis + legend settings
......@@ -249,7 +249,7 @@ shinyServer(function(input, output, session) {
line = list(color = 'rgb(0.5, 0.5, 0.5)', dash = "dot"),
showlegend = FALSE) # %>%
# event_register(event = "plotly_click") # enable clicking to select date
# add forecasts: run through models
for(m in seq_along(plot_data$select_models)){
mod <- plot_data$select_models[m]
......@@ -285,7 +285,7 @@ shinyServer(function(input, output, session) {
color = cols[m]),
legendgroup = mod, showlegend = show_nowcast)
}
# trace for most truth data on top
p <- p %>% add_lines(x = plot_data$truth$time,
y = plot_data$truth$value,
......@@ -298,11 +298,11 @@ shinyServer(function(input, output, session) {
p
})
})
# register proxy (necessary to modify plotly objsect):
myPlotProxy <- plotlyProxy("tsplot", session)
# update shaded area to mark selected date:
observe({
plotlyProxyInvoke(myPlotProxy, "restyle", list(x = list(rep(as.Date(input$select_date) + 1, 2)),
......@@ -313,14 +313,14 @@ shinyServer(function(input, output, session) {
y = list(rep(plot_data$ylim, each = 2))),
list(0))
})
# update truth as of selected date:
observe({
plotlyProxyInvoke(myPlotProxy, "restyle", list(x = list(plot_data$truth$time),
y = list(plot_data$truth$value)),
list(plot_data$mapping$truth))
})
# update forecasts:
observe({
for(mod in c(paste0("empty", 1:6), models)){
......@@ -354,9 +354,9 @@ shinyServer(function(input, output, session) {
showlegend = show_nowcast),
list(plot_data$mapping[[mod]][2]))
}
})
# update ylim
observe({
# y axis limit
......@@ -372,13 +372,13 @@ shinyServer(function(input, output, session) {
}
plot_data$ylim <- yl
})
observe({
plotlyProxyInvoke(myPlotProxy, "relayout",
list(yaxis = list(title = plot_data$ylab)))
})
# table with scores:
# output table:
output$tab <- DT::renderDataTable({
......@@ -386,14 +386,14 @@ shinyServer(function(input, output, session) {
sub[, c("ae", "mean_qscore", "interval_coverage_0.5", "interval_coverage_0.95", "scores_imputed")] <-
round(sub[, c("ae", "mean_qscore", "interval_coverage_0.5", "interval_coverage_0.95", "scores_imputed")], 2)
datatable(sub, filter = "top",
colnames = c("", "model", "target", "horizon", "MAE", "MQS", "C0.5", "C0.95", "n", "imputed"))
colnames = c("", "model", "target", "horizon", "AE_Skill", "Quantile_Skill", "C0.5", "C0.95", "n", "imputed"))
})
# table with ranks:
# output table:
output$tab_rankings <- DT::renderDataTable({
datatable(rankings[, -2], filter = "top",
colnames = c("", "model", "av. rank wind", "av. rank temperature", "av. rank DAX", "av. rank overall"))
})
})
......@@ -15,19 +15,19 @@ default_shown <- sample(models[models != "median_ensemble"], 4)
# Define UI for application
shinyUI(fluidPage(
# Application title
titlePanel("Probabilistic Time Series Forecasting Challenge"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
strong("Select forecast date"),
br(),
div(style="display: inline-block;vertical-align:top;", actionButton("skip_backward", "<")),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_date",
label = NULL,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_date",
label = NULL,
choices = rev(available_dates))),
div(style="display: inline-block;vertical-align:top;", actionButton("skip_forward", ">")),
selectizeInput("select_target",
......@@ -35,33 +35,34 @@ shinyUI(fluidPage(
choices = c("DAX" = "DAX",
"Temperature" = "temperature",
"Wind" = "wind"), width = "200px"),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models1", "Model 1:", choices = models, multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models1", "Model 1:", choices = models, multiple = FALSE,
selected = c("median_ensemble"))),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models2", "Model 2:", choices = c("(none selected)" = "empty2", models), multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models2", "Model 2:", choices = c("(none selected)" = "empty2", models), multiple = FALSE,
selected = "(none selected)")),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models3", "Model 3:", choices = c("(none selected)" = "empty3", models), multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models3", "Model 3:", choices = c("(none selected)" = "empty3", models), multiple = FALSE,
selected = "(none selected)")),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models4", "Model 4:", choices = c("(none selected)" = "empty4", models), multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models4", "Model 4:", choices = c("(none selected)" = "empty4", models), multiple = FALSE,
selected = "(none selected)")),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models5", "Model 5:", choices = c("(none selected)" = "empty5", models), multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models5", "Model 5:", choices = c("(none selected)" = "empty5", models), multiple = FALSE,
selected = "(none selected)")),
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models6", "Model 6:", choices = c("(none selected)" = "empty6", models), multiple = FALSE,
div(style="display: inline-block;vertical-align:top;width:200px",
selectizeInput("select_models6", "Model 6:", choices = c("(none selected)" = "empty6", models), multiple = FALSE,
selected = "(none selected)")),
radioButtons("select_interval", label = "Show prediction interval:",
radioButtons("select_interval", label = "Show prediction interval:",
choices = c("95%", "50%", "none"), selected = "95%", inline = TRUE)
),
# Show a plot of the generated distribution
mainPanel(
h4("Forecast visualization"),
plotlyOutput("tsplot", height = "600px"),
h4("Average evaluation scores by target and horizon"),
h4("Forecast evaluation by target and horizon"),
h6("Larger skill scores are better. 1 = perfect performance, 0 = performance equal to benchmark. C0.5 and C0.95 denote coverage of 50% and 95% prediction intervals."),
dataTableOutput("tab"),
h4("Rankings"),
dataTableOutput("tab_rankings")
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment