Sample narrative section.
knitr::opts_chunk$set(echo = FALSE) library(evaluator) library(dplyr) input_directory <- params$input_directory results_directory <- params$results_directory
dat <- read_quantitative_inputs(input_directory) simulation_results <- readRDS(file.path(results_directory, "simulation_results.rds")) scenario_summary <- mutate(simulation_results, summary = map(results, summarize_scenario)) scenario_summary <- unnest(scenario_summary, summary, .drop = TRUE) scenario_outliers <- identify_outliers(scenario_summary) %>% filter(outlier == TRUE) %>% pull(scenario_id) iteration_summary <- summarize_iterations(simulation_results$results) domains <- dat$domains domain_summary <- summarize_domains(simulation_results) domain_summary <- domain_summary %>% left_join(domains, by = "domain_id") simulation_results_unnested <- unnest(simulation_results, results) %>% mutate(outlier = scenario_id %in% scenario_outliers) risk_tolerances <- dat$risk_tolerances scenarios <- dat$quantitative_scenarios
basefont <- get_base_fontfamily()
max_loss <- calculate_max_losses(simulation_results, scenario_outliers)
agg_risk <- quantile(iteration_summary$ale_sum, 0.95) flexdashboard::valueBox(dollar_millions(agg_risk), icon = "glyphicon-eye-open", caption = "Aggregate 95% Value at Risk", color = ifelse(agg_risk > risk_tolerances[risk_tolerances$level == "high", "amount"], "danger", ifelse( agg_risk > risk_tolerances[risk_tolerances$level == "medium", "amount"], "warning", "info")))
loss_exceedance <- min(iteration_summary$ale_sum) flexdashboard::valueBox(dollar_millions(loss_exceedance), icon = "glyphicon-warning-sign", caption = "Minimum Expected Annual Losses", color = ifelse( loss_exceedance > risk_tolerances[risk_tolerances$level == "high", "amount"], "danger", ifelse(loss_exceedance > risk_tolerances[risk_tolerances$level == "medium", "amount"], "warning", "info")))
loss_events <- median(iteration_summary$loss_events) flexdashboard::valueBox(scales::comma(loss_events), icon = "glyphicon-flag", caption = "Expected Annual Loss Events", color = "info")
gg <- generate_heatmap(domain_summary) # modify the base plot for displaying on the dashboard gg <- gg + labs(title = NULL, caption = NULL) gg <- gg + theme(legend.position = "right") gg <- gg + viridis::scale_fill_viridis(guide = FALSE, end = 0.75, option = "D") gg <- gg + guides(fill = FALSE) gg
# helper function to roll up scenarios that aren't in the top_n sum_bottom_n <- function(dat, top_n=10, sortby="max_ale") { cluster_hack <- max(dat$cluster_id) full_label <- "full_label" sortby <- rlang::enquo(sortby) # assign a flag on outliers keep_nokeep <- dat %>% group_by_at(.vars = full_label) %>% summarise(foo = max(!!sortby)) %>% mutate(keep = ifelse(row_number() <= top_n, TRUE, FALSE)) %>% select(-foo) # sum up the outliers others <- filter(keep_nokeep, keep == FALSE) %>% left_join(dat, by = "full_label") %>% group_by(iteration) %>% summarize(ale = max(ale), scenario_count = n()) %>% mutate(full_label = paste0("others (", scenario_count, ")")) %>% mutate(cluster_id = cluster_hack) # combine the outliers with the top_n items union_all(filter(keep_nokeep, keep == TRUE) %>% left_join(dat, by = "full_label"), others) } # assign the text label to scenarios and order simulation_results %>% unnest(results) %>% mutate(full_label = paste0(domain_id, " - ", scenario_id)) %>% arrange(domain_id, scenario_id) -> dat # identify the top 10 scenarios by VaR top_n_scenarios <- group_by(dat, full_label) %>% summarize(ale_var = quantile(ale, 0.95)) %>% filter(row_number(desc(ale_var)) <= 10 ) %>% .[["full_label"]] # remove no loss scenarios, enhance, and cluster dat <- group_by(dat, full_label) %>% filter(sum(ale) != 0) %>% mutate(var = quantile(ale, 0.95), max_ale = max(ale), ale_median = median(ale)) %>% ungroup %>% mutate(cluster_id = kmeans(max_ale, 3)$cluster) # assign labels to the clusters text_labels <- c("High", "Medium", "Low") cluster_descriptions <- group_by(dat, cluster_id, full_label) %>% summarize(ale = max(max_ale)) %>% summarise(highest_ale = max(ale), n = n()) %>% arrange(desc(highest_ale)) %>% mutate(cluster_labels = factor(text_labels, levels = text_labels), top_n = min(last(n), n)) # roll up on a per-cluster basis, addng descriptive text to the cluster summed_dat <- group_by(dat, cluster_id) %>% left_join(cluster_descriptions, by = "cluster_id") %>% do(sum_bottom_n(., top_n = max(.$top_n))) %>% select(-c(cluster_labels, n, top_n, highest_ale)) %>% left_join(cluster_descriptions, by = "cluster_id") %>% ungroup summed_dat <- group_by(summed_dat, full_label) %>% mutate(ale_median = median(ale)) # slimmed down alternative view of the dataset minimal_dat <- filter(dat, full_label %in% top_n_scenarios, ale != 0) %>% group_by(full_label) %>% mutate(ale_median = median(ale)) %>% ungroup %>% mutate(full_label = forcats::fct_reorder(full_label, ale_median)) # plot! gg <- ggplot(minimal_dat, aes(x = forcats::fct_reorder(full_label, desc(ale_median)), y = ale + 1)) gg <- gg + stat_boxplot(geom = 'errorbar', width = 0.4) gg <- gg + geom_boxplot(fill = viridis::viridis(1), coef = 0, alpha = 1/3, outlier.shape = NA) gg <- gg + viridis::scale_fill_viridis(discrete = TRUE) gg <- gg + scale_y_log10(label = scales::dollar) + annotation_logticks(sides = "l") gg <- gg + guides(fill = FALSE) gg <- gg + labs(x = NULL, y = "Annual\nLoss") gg <- gg + theme_evaluator(base_family = basefont) gg <- gg + theme(panel.grid.major.x = element_line()) gg <- gg + theme(panel.grid.minor.x = element_line(color = "grey92")) gg <- gg + theme(axis.title.y = element_text(angle = 0, vjust = 0.5, hjust = 0)) gg
select(domain_summary, domain, mean_vuln, mean_tc_exceedance, mean_diff_exceedance) %>% mutate_at(vars(starts_with("mean_")), scales::percent) %>% rename("Domain" = domain, "Succesful Threat Events" = mean_vuln, "Control Gap" = mean_tc_exceedance, "Surplus Control Strength" = mean_diff_exceedance) %>% pander::pander(justify = c("left", "right", "right", "right"), split.cells = c(35, rep(10, 3)))
top_n(scenario_summary, 5, ale_var) %>% arrange(desc(ale_var)) %>% left_join(scenarios, by = c("scenario_id" = "scenario_id", "domain_id" = "domain_id")) %>% mutate(ale_var = scales::dollar(ale_var), ale_median = scales::dollar(ale_median), full_label = paste(domain_id, scenario_id, sep = " - ")) %>% select("ID" = full_label, Scenario = scenario_description, "Median Annual Loss" = ale_median, "Value at Risk" = ale_var) %>% pander::pander(justify = c(rep("left", 2), rep("right", 2)), split.cells = c(12, rep(30, 3)))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.