Risk Dashboard

In evaluator: Quantified Risk Assessment Toolkit

Sample narrative section.

knitr::opts_chunk$set(echo = FALSE) 
library(extrafont)
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)

Risk Dashboard

Value Boxes

Aggregate Risk

````r 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")))

### Minimum Expected Annual Losses

```r
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")))

Expected Loss Events Per Year

loss_events <- median(iteration_summary$loss_events)
flexdashboard::valueBox(scales::comma(loss_events), icon = "glyphicon-flag",
         caption = "Expected Annual Loss Events",
         color = "info")

Domain Summary {data-height=150}

Domain Heatmap {.no-padding}

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

Scenario Results {.data-height=250}

Loss Ranges for Top 10 Scenarios {.no-padding}

# 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

Details

Control Gaps/Surplus by Domain

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 Risk Scenarios

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)))

evaluator documentation built on July 6, 2021, 9:06 a.m.