Constraints vs Performance

security differently
Author

John Benninghoff

Published

April 30, 2024

Modified

February 25, 2025

Visualizations exploring the use of constraints vs performance improvements in risk management.

library(ggplot2)
library(jbplot)
library(fs)
library(tibble)
library(dplyr)

Normal Performance

Replicate a version of Figure 9 from the Safety-II White Paper, with help from https://ggplot2tor.com/tutorials/sampling_distributions:

xmin <- -5
xmax <- 5

save_png <- function(filename) {
  ggsave(filename = path("rendered", filename), width = 16 * 0.6, height = 9 * 0.6, bg = "white")
}

background <- ggplot(data.frame(x = c(xmin, xmax)), aes(x)) +
  scale_x_continuous(breaks = -3:3, minor_breaks = NULL) +
  labs(x = NULL, y = NULL) +
  theme_quo(minor.y = FALSE)

baseline <- stat_function(fun = dnorm, geom = "line")
bad <- stat_function(fun = dnorm, geom = "area", fill = "red", xlim = c(xmin, -2))

background + bad + baseline

A normal curve of height 0.4 and mean of 0 with the area under the curve between -2 and -3 colored red.

save_png("01-baseline-bad.png")

The plot above shows “bad” outcomes in red. Let’s add in “good” outcomes (>1) in green:

good <- stat_function(fun = dnorm, geom = "area", fill = "green", xlim = c(1, xmax))

background + bad + good + baseline

A normal curve of height 0.4 and mean of 0 with the area under the curve between -2 and -3 colored red and the area under the curve between 1 and 3 colored green.

save_png("02-baseline-bad-good.png")

Constrained Performance

One way of reducing “bad” outcomes is by constraining performance - reducing the standard deviation.

constrained <- stat_function(fun = dnorm, args = list(sd = 0.7), geom = "line", color = "blue")
taller <- scale_y_continuous(limits = c(0, 0.6))

background +
  stat_function(
    fun = dnorm, args = list(sd = 0.7), geom = "area", fill = "red", xlim = c(xmin, -2)
  ) +
  stat_function(
    fun = dnorm, args = list(sd = 0.7), geom = "area", fill = "green", xlim = c(1, xmax)
  ) +
  constrained +
  taller

A taller normal curve of height just under 0.6 and mean of 0 with the area under the curve between -2 and -3 colored red and the area under the curve between 1 and 3 colored green. The colored areas are smaller than in the previous plot.

save_png("03-constrained.png")

Plotting both on the same grid shows the reduction in both “bad” and “good” outcomes:

background +
  bad +
  good +
  baseline +
  constrained +
  taller

A plot showing both the first normal curve overlaid with the taller, narrower normal curve.

save_png("04-baseline-constrained.png")

Improved Performance

Another way of reducing bad outcomes is by improving performance - shifting the mean.

performance <- stat_function(fun = dnorm, args = list(mean = 1), geom = "line", color = "blue")
improved <- stat_function(
  fun = dnorm, args = list(mean = 1), geom = "area", fill = "green", xlim = c(1, xmax)
)

background +
  stat_function(
    fun = dnorm, args = list(mean = 1), geom = "area", fill = "red", xlim = c(xmin, -2)
  ) +
  improved +
  performance

A normal curve of height 0.4 and mean of 1 with the area under the curve between -2 and -3 colored red.

save_png("05-improved.png")

Plotting both together shows a reduction in “bad” and an increase in “good” outcomes:

background +
  bad +
  improved +
  baseline +
  performance

A plot showing both the first normal curve with a mean of 0 overlaid with the right-shifted normal curve with a mean of 1.

save_png("06-baseline-improved.png")

Comparing all three:

background +
  bad +
  improved +
  baseline +
  constrained +
  performance +
  taller

A plot showing the first normal curve overlaid with the taller, narrower normal curve and the right-shifted normal curve.

save_png("07-baseline-constrained-improved.png")

Growth of Controls

Visualize an example of the growth of controls using the Cyentia/RiskRecon State of Third-Party Risk Management 2020 and 2024 reports (data from 2023).

Source:

questionnaire <- tribble(
  ~year, ~questions, ~percent,
  2020,  ">400",     0.041,
  2020,  "101-400",  0.148,
  2020,  "11-100",   0.705,
  2020,  "1-10",     0.107,
  2023,  ">400",     0.02,
  2023,  "101-400",  0.333,
  2023,  "11-100",   0.616,
  2023,  "1-10",     0.030
) |>
  mutate(
    year = as.factor(year),
    questions = factor(questions, levels = c("1-10", "11-100", "101-400", ">400"))
  )

ggplot(questionnaire, aes(questions, percent, fill = year)) +
  geom_col(position = "dodge") +
  scale_y_continuous(labels = scales::label_percent()) +
  scale_fill_manual(values = c("steelblue2", "steelblue4")) +
  labs(x = NULL, y = NULL, fill = "Year", title = "Third-Party Questionnaire Length by Year") +
  labs(caption = "Source: Cyentia/RiskRecon State of Third-Party Risk Management, 2020 and 2024") +
  theme_quo()

A bar plot comparing questionnaire length in 2020 and 2023. Questionnaires of length 101-400 questions increased and other lengths decreased between 2020 and 2023.

save_png("08-questionnaire-length.png")

Transparent Donut

Create a transparent donut plot showing an 80% reduction.

# custom function based on ggplot_donut_percent()
custom_donut <- function(p, text = "", accuracy = NULL, hsize = 4, size = 12, family = "Lato") {
  percent_true <- data.frame(group = c(TRUE, FALSE), n = c(p, 1 - p))
  label <- paste0(scales::label_percent(accuracy = accuracy)(p), "\n", text)

  ggplot_donut(percent_true, hsize = hsize) +
    guides(fill = "none") +
    geom_text(x = 0, label = label, size = size, family = family) +
    scale_fill_grey() +
    theme(plot.background = element_rect(fill = "transparent", color = NA))
}

custom_donut(0.8, "reduction")

A donut plot with 80% gray and 20% black area with text '80% reduction' inside the donut

ggsave("rendered/80-percent-safety.png")
Saving 8.5 x 5 in image
custom_donut(0.8, "reduction?")

A donut plot with 80% gray and 20% black area with text '80% reduction?' inside the donut

ggsave("rendered/80-percent-security.png")
Saving 8.5 x 5 in image