filter_df <- function(data, filter_list) { if (!is.list(filter_list) || is.null(filter_list) || length(filter_list) == 0) { return(data) } data <- data.table::copy(data) # filter as specified by the user for (expr in filter_list) { data <- data[eval(parse(text = expr)), ] } return(data) }
df <- filter_df(data, filter_list) quantiles <- round(c(0.01, 0.025, seq(0.05, 0.95, by = 0.05), 0.975, 0.99), 3) df <- df %>% # Check all quantiles per target/location group_by(location, target_variable, target_end_date, model) %>% mutate(all_quantiles_present = (length(setdiff(quantiles, quantile)) == 0)) %>% ungroup() %>% filter(all_quantiles_present == TRUE) %>% select(-all_quantiles_present) ## if more than 1 location exists, filter to have at least half of them if (length(unique(df$location)) > 1) { df <- df %>% group_by(model) %>% mutate(n = length(unique(location))) %>% ungroup() %>% mutate(nall = length(unique(location))) %>% filter(n >= nall / 2) %>% select(-n, -nall) } table <- eval_forecasts(df, summarise_by = summarise_by, compute_relative_skill = TRUE) if (nrow(table) == 0) { } else { setcolorder(table, c("model", "relative_skill")) htmltools::tagList( table %>% arrange(relative_skill) %>% dplyr::select(-scaled_rel_skill) %>% mutate_if(is.numeric, round, 2) %>% dplyr::rename(wis = interval_score, underpred = underprediction, overpred = overprediction, cvrage_dev = coverage_deviation, rel_skill = relative_skill) %>% DT::datatable(extensions = c('FixedColumns', 'Buttons'), width = "100%", options = list( paging = FALSE, info = FALSE, buttons = c('csv', 'excel'), dom = 'Bfrtip', scrollX = TRUE, fixedColumns = TRUE ), class = 'white-space: nowrap') ) }
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.