Widget System Risk Analysis Report

Published

August 15, 2024

Modified

August 18, 2025

Example quantrr risk analysis of the “Widget Management System” (WMS).

Code
library(quantrr)
library(readxl)
library(janitor)
library(validate)
library(dplyr)
library(formattable)
library(purrr)
library(ggplot2)
library(plotly)

# set the relative file path and name to import
report_file <- "data/widgetsys.xlsx"

Environment Statement

The Widget Management System (WMS) is over 30 years old and its architecture has not changed significantly since the original implementation. Over the years, the widget system has become an integral part of our services in managing widgets for our clients. In reviewing the system, three major risks were identified: First, the age of the technology prevents updating components of the system that no longer meet contemporary cybersecurity standards, which increases the likelihood of a breach. Second, the system is less reliable and experiences frequent outages, typically about 2 major outages per year, which results in lost revenue, contractual penalties, and overtime pay to recover from the incident. Third, limitations of the widget system have started to affect sales - we have recently lost a customer due to the functional obsolescence of the widget system, and expect to both lose more existing and prospective customers in the future due to increased competition in the widget management market.

Experts were asked to consider two risk treatment scenarios:

  • None: The current system as it is today (baseline risk)
  • Replace: Complete replacement of the WMS with a modern, customer-centric solution

Import

Import and validate data from Excel.

The data was collected from 3 Technology SMEs, 3 Business SMEs, and one SME with experience in both. Experts were calibrated, informed by historical and industry data, and only gave estimates for areas in which they were confident in answering.

Code
risks <- read_xlsx(report_file, sheet = "Risks") |>
  clean_names()

validate_risks <- local({
  validate_rules <- validator(
    risk_char = is.character(risk),
    risk_not_na = !is.na(risk),
    risk_not_blank = nzchar(risk, keep_na = TRUE),
    desc_char = is.character(description),
    desc_not_na = !is.na(description),
    desc_not_blank = nzchar(risk, keep_na = TRUE)
  )
  confront(risks, validate_rules)
})

check_validation(validate_risks, sheet = "Risks")

treatments <- read_xlsx(report_file, sheet = "Treatments") |>
  clean_names()

validate_treatments <- local({
  validate_rules <- validator(
    treatment_char = is.character(treatment),
    treatment_not_na = !is.na(treatment),
    treatment_not_blank = nzchar(treatment, keep_na = TRUE),
    desc_char = is.character(description),
    desc_not_na = !is.na(description),
    desc_not_blank = nzchar(treatment, keep_na = TRUE)
  )
  confront(treatments, validate_rules)
})

check_validation(validate_treatments, sheet = "Treatments")

estimates <- read_xlsx(report_file, sheet = "Estimates") |>
  clean_names() |>
  rename(
    lambda = frequency_per_yer, p50 = most_likely, p95 = high_95_percent, p05 = low_5_percent
  )

validate_estimates <- local({
  validate_rules <- validator(
    risk_not_na = !is.na(risk),
    risk_match = risk %in% risks$risk,
    expert_char = is.character(expert),
    expert_not_na = !is.na(expert),
    expert_not_blank = nzchar(expert, keep_na = TRUE),
    lambda_num = is.numeric(lambda),
    lambda_pos = lambda > 0,
    p50_num = is.numeric(p50),
    p50_pos = p50 > 0,
    p95_num = is.numeric(p95),
    p95_pos = p95 > 0,
    p05_num = is.numeric(p05),
    p05_pos = p05 > 0
  )
  confront(estimates, validate_rules)
})

check_validation(validate_estimates, sheet = "Estimates")

Risks

Risk descriptions:

Code
formattable(risks, align = "l")
risk description
Cybersecurity Breach Risk of a cybersecurity breach of the inventory system.
Technology Outage Risk of an inventory system outage.
Loss of Customer Risk of losing and existing customer or failure to acquire a new customer due to functional limitations of the inventory system.

Treatment descriptions:

Code
formattable(treatments, align = "l")
treatment description
None Current system as it is today
Replace Replace WMS with a modern solution

Forecast

Forecast risk using Monte Carlo simulation. The average events, losses, ‘typical’ losses (geometric mean), and percentage of years with no losses for each risk and treatment are summarized below:

Code
consensus <- estimates |>
  group_by(treatment, risk) |>
  summarize(across(lambda:p05, ~ mean(.x, na.rm = TRUE)), .groups = "drop")

consensus_params <- consensus |>
  mutate(as_tibble(lnorm_param(p50 = .data$p50, p95 = .data$p95, p05 = .data$p05)))

forecast <- consensus_params |>
  select(c("risk", "lambda", "meanlog", "sdlog", "treatment")) |>
  pmap(calc_risk) |>
  list_rbind()

forecast |>
  group_by(treatment, risk) |>
  mutate(no_losses = events == 0) |>
  summarize(
    avg_events = mean(events), avg_losses = mean(losses), typ_losses = gmean(losses),
    no_losses = mean(no_losses), .groups = "drop"
  ) |>
  mutate(
    across(avg_losses:typ_losses, ~ currency(.x, digits = 0L)),
    no_losses = percent(no_losses)
  ) |>
  formattable(align = "l")
treatment risk avg_events avg_losses typ_losses no_losses
None Cybersecurity Breach 0.25760 $5,830,131 $361,506 77.36%
None Loss of Customer 2.00492 $10,717,189 $4,291,229 13.14%
None Technology Outage 2.01368 $96,858 $35,381 13.65%
Replace Cybersecurity Breach 0.10044 $2,144,844 $318,752 90.41%
Replace Loss of Customer 0.23544 $1,140,109 $1,617,617 79.17%
Replace Technology Outage 1.11980 $42,246 $18,860 32.59%

Losses

Base losses (with no risk treatment) by risk:

Code
forecast |>
  filter(tolower(treatment) == "none") |>
  # remove zero losses to plot using log10 scale
  filter(losses > 0) |>
  ggplot(aes(losses)) +
  facet_grid(vars(risk)) +
  geom_histogram(color = "black", fill = "white", bins = 100) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, title = "Base Losses by Risk") +
  theme_minimal()

Stacked histograms of number of losses by value for each risk.

Combined losses by treatment:

Code
forecast |>
  group_by(treatment, year) |>
  summarize(total_losses = sum(losses), .groups = "drop_last") |>
  # remove zero losses to plot using log10 scale
  filter(total_losses > 0) |>
  ggplot(aes(total_losses)) +
  facet_grid(vars(treatment)) +
  geom_histogram(color = "black", fill = "white", bins = 100) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, title = "Combined Losses by Treatment") +
  theme_minimal()

Stacked histograms of number of combined losses by value for each treatment.

Loss Exceedance Curves

Plot loss exceedance curves for all risks and combined risk, with risk treatments.

By Risk

Plot loss exceedance curves for each risk:

Code
risk_le <- forecast |>
  group_by(risk, treatment) |>
  mutate(probability = 1 - percent_rank(losses)) |>
  filter(losses > 0) |>
  ungroup() |>
  mutate(losses = currency(losses, digits = 0), probability = percent(probability)) |>
  ggplot(aes(losses, probability, color = treatment)) +
  facet_grid(vars(risk)) +
  geom_line() +
  scale_y_continuous(labels = scales::label_percent(), limits = c(0, 1)) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, color = "Treatment", title = "Loss Exceedance by Risk") +
  scale_color_viridis_d() +
  theme_minimal()

risk_le

Plot showing likelihood of experiencing a loss exceeding a given dollar value by risk, comparing treatments.

Interactive plot:

Code
ggplotly(risk_le + guides(color = "none"))

Combined Risk

Plot loss exceedance curve for combined risk:

Code
combined_le <- forecast |>
  group_by(treatment, year) |>
  summarize(total_losses = sum(losses), .groups = "drop_last") |>
  mutate(probability = 1 - percent_rank(total_losses)) |>
  filter(total_losses > 0) |>
  ungroup() |>
  mutate(total_losses = currency(total_losses, digits = 0), probability = percent(probability)) |>
  ggplot(aes(total_losses, probability, color = treatment)) +
  geom_line() +
  scale_y_continuous(labels = scales::label_percent(), limits = c(0, 1)) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, color = "Treatment", title = "Combined Loss Exceedance") +
  scale_color_viridis_d() +
  theme_minimal()

combined_le

Plot showing likelihood of experiencing a combined loss exceeding a given dollar value by risk, comparing treatments.

Interactive plot:

Code
ggplotly(combined_le + guides(color = "none"))

Appendix

Additional details on the risk quantification analysis.

Validation

Data validation results for Risks tab:

Code
plot(validate_risks)

Plot showing percentage of values validated by rule, with passing values in green, failing values in red, and missing values in gray.

Data validation results for Treatments tab:

Code
plot(validate_treatments)

Plot showing percentage of values validated by rule, with passing values in green, failing values in red, and missing values in gray.

Data validation results for Estimates tab:

Code
plot(validate_estimates)

Plot showing percentage of values validated by rule, with passing values in green, failing values in red, and missing values in gray.

Estimates

All risk estimates:

Code
estimates |>
  mutate(across(p50:p05, ~ currency(.x, digits = 0L))) |>
  formattable(align = "l")
treatment risk expert lambda p50 p95 p05
None Cybersecurity Breach Technology Expert 1 0.25 NA NA NA
None Cybersecurity Breach Technology Expert 2 0.33 NA NA NA
None Cybersecurity Breach Technology Expert 3 0.20 NA NA NA
None Cybersecurity Breach Business Expert 1 NA $300,000 $45,000,000 $2,000
None Cybersecurity Breach Business Expert 2 NA $200,000 $34,000,000 $1,400
None Cybersecurity Breach Business Expert 3 NA $500,000 $54,000,000 $2,100
None Cybersecurity Breach Unicorn Expert 0.25 $275,000 $44,000,000 $1,900
None Technology Outage Technology Expert 1 2.00 NA NA NA
None Technology Outage Technology Expert 2 3.00 NA NA NA
None Technology Outage Technology Expert 3 1.00 NA NA NA
None Technology Outage Business Expert 1 NA $15,000 $200,000 $700
None Technology Outage Business Expert 2 NA $10,000 $150,000 $500
None Technology Outage Business Expert 3 NA $11,000 $180,000 $675
None Technology Outage Unicorn Expert 2.00 $16,000 $220,000 $800
None Loss of Customer Technology Expert 1 NA NA NA NA
None Loss of Customer Technology Expert 2 NA NA NA NA
None Loss of Customer Technology Expert 3 NA NA NA NA
None Loss of Customer Business Expert 1 2.00 $1,500,000 $20,000,000 $100,000
None Loss of Customer Business Expert 2 3.00 $2,000,000 $30,000,000 $150,000
None Loss of Customer Business Expert 3 1.00 $1,200,000 $15,000,000 $75,000
None Loss of Customer Unicorn Expert 2.00 $1,000,000 $15,000,000 $75,000
Replace Cybersecurity Breach Technology Expert 1 0.10 NA NA NA
Replace Cybersecurity Breach Technology Expert 2 0.15 NA NA NA
Replace Cybersecurity Breach Technology Expert 3 0.05 NA NA NA
Replace Cybersecurity Breach Business Expert 1 NA $300,000 $45,000,000 $2,000
Replace Cybersecurity Breach Business Expert 2 NA $200,000 $34,000,000 $1,400
Replace Cybersecurity Breach Business Expert 3 NA $500,000 $54,000,000 $2,100
Replace Cybersecurity Breach Unicorn Expert 0.10 $275,000 $44,000,000 $1,900
Replace Technology Outage Technology Expert 1 1.00 NA NA NA
Replace Technology Outage Technology Expert 2 1.50 NA NA NA
Replace Technology Outage Technology Expert 3 1.00 NA NA NA
Replace Technology Outage Business Expert 1 NA $10,000 $150,000 $700
Replace Technology Outage Business Expert 2 NA $7,500 $125,000 $500
Replace Technology Outage Business Expert 3 NA $10,000 $160,000 $675
Replace Technology Outage Unicorn Expert 1.00 $11,000 $155,000 $800
Replace Loss of Customer Technology Expert 1 NA NA NA NA
Replace Loss of Customer Technology Expert 2 NA NA NA NA
Replace Loss of Customer Technology Expert 3 NA NA NA NA
Replace Loss of Customer Business Expert 1 0.20 $1,500,000 $20,000,000 $100,000
Replace Loss of Customer Business Expert 2 0.40 $2,000,000 $30,000,000 $150,000
Replace Loss of Customer Business Expert 3 0.25 $1,200,000 $15,000,000 $75,000
Replace Loss of Customer Unicorn Expert 0.10 $1,000,000 $15,000,000 $75,000

Consensus Estimate

Using a simple average of all experts that provided an estimate (not blank/NA), this gives us a consensus estimate for the three risks of:

Code
consensus |>
  mutate(across(p50:p05, ~ currency(.x, digits = 0L))) |>
  formattable(align = "l")
treatment risk lambda p50 p95 p05
None Cybersecurity Breach 0.2575 $318,750 $44,250,000 $1,850
None Loss of Customer 2.0000 $1,425,000 $20,000,000 $100,000
None Technology Outage 2.0000 $13,000 $187,500 $669
Replace Cybersecurity Breach 0.1000 $318,750 $44,250,000 $1,850
Replace Loss of Customer 0.2375 $1,425,000 $20,000,000 $100,000
Replace Technology Outage 1.1250 $9,625 $147,500 $669

The consensus estimates result in the following parameters for log-normal loss magnitude. When both p05 and p95 are provided, the p50 estimate is used to calculate the percentage difference from the actual median (mdiff), a measure of estimate accuracy (otherwise mdiff is NA):

Code
consensus_params |>
  mutate(across(p05:p50, ~ currency(.x, digits = 0L)), mdiff = percent(mdiff)) |>
  formattable(align = "l")
treatment risk lambda p50 p95 p05 meanlog sdlog mdiff
None Cybersecurity Breach 0.2575 $318,750 $44,250,000 $1,850 12.564153 3.064840 11.41%
None Loss of Customer 2.0000 $1,425,000 $20,000,000 $100,000 14.162084 1.610574 0.76%
None Technology Outage 2.0000 $13,000 $187,500 $669 9.323472 1.713260 16.09%
Replace Cybersecurity Breach 0.1000 $318,750 $44,250,000 $1,850 12.564153 3.064840 11.41%
Replace Loss of Customer 0.2375 $1,425,000 $20,000,000 $100,000 14.162084 1.610574 0.76%
Replace Technology Outage 1.1250 $9,625 $147,500 $669 9.203497 1.640320 -3.09%

Forecast Summary

A summary() of the forecast results.

Code
summary(forecast)
      year           risk            treatment             events       
 Min.   :    1   Length:150000      Length:150000      Min.   : 0.0000  
 1st Qu.: 6251   Class :character   Class :character   1st Qu.: 0.0000  
 Median :12500   Mode  :character   Mode  :character   Median : 0.0000  
 Mean   :12500                                         Mean   : 0.9553  
 3rd Qu.:18750                                         3rd Qu.: 2.0000  
 Max.   :25000                                         Max.   :10.0000  
     losses         
 Min.   :0.000e+00  
 1st Qu.:0.000e+00  
 Median :0.000e+00  
 Mean   :3.329e+06  
 3rd Qu.:1.323e+05  
 Max.   :7.983e+09