Nothing
# Load packages and initialize data here library(scales) library(viridis) library(ggplot2) library(dplyr) library(tibble) library(evaluator) library(extrafont) 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 <- summarize_scenarios(simulation_results) scenario_outliers <- identify_outliers(scenario_summary) %>% filter(outlier == TRUE) %>% pull(scenario_id) scenario_summary <- scenario_summary %>% mutate(outlier = scenario_id %in% scenario_outliers) max_loss <- calculate_max_losses(simulation_results, scenario_outliers) domains <- dat$domains risk_tolerances <- dat$risk_tolerances scenarios <- dat$quantitative_scenarios capabilities <- purrr::map2_dfr(scenarios$control_descriptions, scenarios$domain_id, ~tibble(capability = as_vector(.x), capability_id = names(.x), domain_id = .y)) %>% dplyr::distinct()
# determine the correct base font family to use basefont <- get_base_fontfamily() # given a scenario id, create a loss table get_loss_table <- function(sid) { scenario_data <- simulation_results[simulation_results$scenario_id == sid, ][[1, "results"]] loss_table <- tibble::tibble(Category = c("Loss Events / Year", "Loss Magnitude", "Total Loss Exposure"), Minimum = c(min(scenario_data$loss_events), min(scenario_data$sle_min) %>% dollar, min(scenario_data$ale) %>% dollar), Mean = c(mean(scenario_data$loss_events, na.rm = TRUE), mean(scenario_data$sle_mean, na.rm = TRUE) %>% dollar, mean(scenario_data$ale, na.rm = TRUE) %>% dollar), Mode = c(statip::mfv(scenario_data$loss_events)[1], statip::mfv(scenario_data$sle_median)[1] %>% as.numeric %>% dollar, statip::mfv(scenario_data$ale)[1] %>% as.numeric %>% dollar), Maximum = c(max(scenario_data$loss_events), max(scenario_data$sle_max) %>% dollar, max(scenario_data$ale) %>% dollar) ) return(loss_table) } # given a scenario id, get the results dataframe get_scenario_results <- function(sid){ simulation_results %>% filter(scenario_id == sid) %>% pull(results) %>% .[[1]] } # given a domain_id - scenario_id syntax, get the scenario_id get_scenario_id <- function(x){ str_split(x, " - ", simplify = TRUE)[2] } # given a scenario id, get the scenario summary table get_summary_table <- function(sid) { summary_data <- scenario_summary %>% filter(scenario_id == sid) %>% select(-c(results, control_descriptions)) # add pretty formatting summary_data <- mutate_at(summary_data, .funs = dollar, .vars = vars(ale_median, ale_max, ale_var, sle_mean, sle_median, sle_max, sle_min)) %>% mutate(mean_tc_exceedance = ifelse(is.nan(mean_tc_exceedance), NA, percent(mean_tc_exceedance))) %>% mutate(mean_vuln = percent(mean_vuln)) names(summary_data) <- stringi::stri_trans_totitle(gsub("_", " ", names(summary_data))) summary_data <- summary_data %>% mutate_all(as.character) %>% tidyr::gather(key = "Parameter", value = "Value") summary_data } # populate the threat summary table get_threat_table <- reactive({ #filter_input <- get_threat_id(input$input_threat) scenario_data <- scenarios[scenarios$scenario_id == get_scenario_id(input$input_scenario), ][[1, "scenario"]] threat_data <- as_tibble(scenario_data) %>% filter(openfair_factor %in% c("tef", "tc")) %>% tidyr::gather(param, value, c(min:shape)) %>% mutate(value = ifelse(openfair_factor == "tef" | param == "shape", as.integer(value), percent(value))) %>% tidyr::spread(param, value) %>% mutate(type = ifelse(openfair_factor == "tc", "Capability", "Frequency")) threat_data <- threat_data %>% select(Type = openfair_factor, Low = min, "Most Likely" = mode, "High" = max, Confidence = shape) threat_data }) # populate the control summary table get_control_table <- reactive({ scenario_data <- scenarios[scenarios$scenario_id == get_scenario_id(input$input_scenario), ][[1, "scenario"]] # add control description control_data <- as_tibble(scenario_data) %>% filter(openfair_factor == "diff") %>% left_join(capabilities, by = c("id" = "capability_id")) # format percentages control_data <- mutate_at(control_data, vars(min, mode, max), list(percent)) # display control_data %>% select(Control = capability, Low = min, "Most Likely" = mode, High = max, Confidence = shape) }) # populate the loss summary table get_loss_distribution_table <- reactive({ scenario_data <- scenarios[scenarios$scenario_id == get_scenario_id(input$input_scenario), ][[1, "scenario"]] loss_data <- as_tibble(scenario_data) %>% filter(openfair_factor == "lm") %>% mutate_at(vars(min, mode, max), dollar) %>% select(Low = min, "Most Likely" = mode, "High" = max, "Confidence" = shape) loss_data })
shiny::renderPlot({ simulation_data <- simulation_results %>% unnest(results) gg <- ggplot(simulation_data, aes(x = scenario_id, y = ale)) gg <- gg + scale_y_continuous(labels = dollar_millions) gg <- gg + labs(x = "Risk Scenario", y = "Annual Loss") gg <- gg + stat_boxplot(geom = 'errorbar', width = 0.5) gg <- gg + geom_boxplot(fill = viridis(1), alpha = 1/3) gg <- gg + facet_grid(~ domain_id, scales = "free_x", space = "free_x", switch = "x") gg <- gg + theme_evaluator(base_family = basefont) gg <- gg + theme(panel.grid.major = element_blank()) gg <- gg + theme(panel.grid.minor = element_blank()) print(gg) })
DT::renderDataTable({ summary_data <- scenario_summary dat <- mutate_at(summary_data, .funs = scales::dollar, .vars = vars(starts_with("ale"), starts_with("sle"))) %>% mutate(loss_events_mean = comma(loss_events_mean)) %>% mutate(mean_tc_exceedance = percent(mean_tc_exceedance)) %>% mutate(mean_vuln = percent(mean_vuln)) %>% select(-c(control_descriptions, results)) names(dat) <- names(dat) %>% stringr::str_replace("_", " ") %>% stringi::stri_trans_totitle() DT::datatable(dat, rownames = FALSE, options = list( scrollX = TRUE, sScrollY = "300px", fixedColumns = list(leftColumns = 2)), extensions = c("Scroller", "FixedColumns")) })
Select a specific risk scenario for detailed analysis.
scenario_input <- paste(scenario_summary$domain_id, "-", scenario_summary$scenario_id) selectInput("input_scenario", "Risk Scenario", scenario_input)
shiny::renderText({ scenarios[scenarios$scenario_id == get_scenario_id(input$input_scenario), "scenario_description"][[1]] })
shiny::renderText({ paste("Community:", scenarios[scenarios$scenario_id == get_scenario_id(input$input_scenario), "tcomm"]) }) renderTable({ get_threat_table() }, include.rownames = FALSE, width = 500)
shiny::renderTable({ get_control_table() }, include.rownames = FALSE, width = 500)
shiny::renderTable({ get_loss_distribution_table() }, include.rownames = FALSE, width = 500)
Simulation data generated on
r format(map(simulation_results$results, ~attr(.x, "generated_on")) %>% purrr::reduce(max), "%F %H:%M:%S%z")
shiny::renderPlot({ # get scenario_id via input$bins from ui.R scenario_id <- get_scenario_id(input$input_scenario) # draw the scatterplot for this threat scenario filter(simulation_results, scenario_id == scenario_id) %>% unnest(results) %>% loss_scatterplot() })
flexdashboard::renderValueBox({ scenario_data <- simulation_results %>% unnest(results) %>% filter(scenario_id == get_scenario_id(input$input_scenario)) dat <- quantile(scenario_data$ale, 0.95, na.rm = TRUE) if (is.na(dat)) dat <- 0 flexdashboard::valueBox(dollar(dat), caption = "Value at Risk", icon = "fa-pencil", color = case_when( dat >= risk_tolerances[risk_tolerances$level == "high", ]$amount ~ "danger", dat >= risk_tolerances[risk_tolerances$level == "medium", ]$amount ~ "warning", TRUE ~ "success") ) })
flexdashboard::renderValueBox({ sid <- get_scenario_id(input$input_scenario) dat <- scenario_summary %>% filter(scenario_id == sid) %>% pull(mean_vuln) if (is.na(dat)) dat <- 0 flexdashboard::valueBox(percent(dat), caption = "Vulnerability", icon = "ion-nuclear", color = ifelse(dat >= .75, "danger", ifelse( dat >= .50, "warning", "success"))) })
summary_table <- reactive({ scenario_id <- get_scenario_id(input$input_scenario) get_summary_table(scenario_id) }) shiny::renderTable({summary_table()}, include.rownames = FALSE)
loss_table <- reactive({ scenario_id <- get_scenario_id(input$input_scenario) get_loss_table(scenario_id) }) shiny::renderTable({loss_table()}, include.rownames = FALSE)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.