What this measures

This is the collection margin of error: what our collection effort might have missed and how significant that could be. We start from the empirically-collected baseline network and grow it into a larger network 25 times, each time adding a plausible unseen periphery through our proprietary agent based modeling synthetic network generator. and re-measure the 38 frozen core officers. The spread of each officer’s index across those 25 grown networks is the margin that incomplete collection puts on the read. It is a distribution and should not be regarded as a correction of the empirically-collected data.

The check is model-free: the core officers are byte-identical inputs in every draw, so any movement in their scores is caused by the added periphery alone. The inference is computed by boot (confidence intervals) and coin (permutation test); the full code is availlable for review in the Appendix.

1. The margin on each officer

Each officer’s observed read (the periphery-free score from the baseline Book Network) is the dot, sorted left to right. Around it, the bar is the plausible-periphery margin (thin = full min to max, thick gold = central 80%) and the gold dash is the periphery median. The red dashed line is the line of inquiry which is our baseline threshold for recommending further inquiry into that particular officer.

Growing the observed baseline network by baseline+ 119 to 141 unseen nodes moves each officer’s IOI by a median of 0.029 SD (median full range 0.118).

Direction: does the periphery raise or lower the read?

The plausible periphery lowers the observed read for 34 of 38 officers and raises it for 4; the typical shift is -0.222 IOI. So the sparse observed read tends to sit above the fuller plausible one.

2. Is the periphery test diverse and demanding?

A margin is only as honest as the test that made it. If the plausible peripheries all came out alike then the spread would be small and the uncertainty would look smaller than it really is. So before we read the margin, we check the test itself: we measure the structure of each grown periphery and see how much of the model’s unconstrained range it covers by comparing it to 50 iterations of letting the ABM generator build out from the organizations structure. When a test ranges almost as wide as the ABM running freely demonstrates that our constrained network, that only grows a periphery from the empirically observed baseline, is sufficient.

he grown peripheries cover a median 85% of the ABM’s unconstrained structural range, and core attachment, the most score-relevant axis, covers 113% of it. This test satisfied our sufficiency demands. This was run against a set of generated networks that are tested for structural realism (the network-realism report). It should not be presumed that this is an accurate representation of the real and unseen world.

3. The most periphery-sensitive officers

The officers whose read moves most as the unseen periphery changes: the ones a collection gap could most change the picture for. The Margin SD column is the main margin measure: the typical movement across the plausible peripheries. The Margin (min to max) column shows the full range of movement across the plausible peripheries, which can be much wider if there are outlier draws that spike an officer’s score. The Crosses line of inquiry column flags officers whose margin reaches across the line of inquiry, meaning that they could be flagged or not depending on what the unseen periphery actually contains.

Officer Median IOI Margin (min to max) Margin SD Crosses line of inquiry
George Smiley 0.81 0.64 to 1.14 0.148 yes, in some draws
Toby Esterhase 0.61 0.40 to 0.86 0.107 no
Connie Sachs 0.28 0.26 to 0.70 0.101 no
Bill Haydon 1.18 0.97 to 1.37 0.085 yes, in some draws
Control 0.47 0.35 to 0.68 0.078 no
Peter Guillam 0.41 0.33 to 0.61 0.069 no
Research Analyst 1 0.30 0.25 to 0.55 0.062 no
Research Analyst 2 0.29 0.25 to 0.56 0.061 no

4. Decision-flag stability

The decision is the line-of-inquiry flag (above_tau). Across the draws, 2 of 38 officers ever change that flag. The margin is wide enough to flip the decision for some of the officers named in the table above.

5. Does a larger unseen periphery move the scores more?

This relationship is weak and uncertain at this n: a larger plausible periphery does not reliably move the known scores more.

6. Margin vs observed connectivity

Observed degree versus margin is not reliably related: how well an officer is observed does not set how wide their margin is.

Verdict

Across 25 plausible peripheries grown from the empirical baseline, the core officers’ IOI carries a median margin of 0.029 SD, and the line-of-inquiry decision changes for 2 of 38 officers. The relationship between how much was left uncollected and how much the known scores move is weak. This characterises this empirical core across its 25 peripheries. The margin is hypothetical and it is not to be taken as definitive. However in this case more collection is not expected to change the picture much, and the observed read is not an outlier in the plausible-periphery distribution, so the margin is small enough that the decision does not significantly move under it.

Scope

This exercise demonstrates the variability in scores already-observed officers could have if a plausible unseen network exists around them. It is not field derived and therefore is not sufficiently field accurate: whether the read is correct about a real person is a separate, client-confidential question that should not be a public artifact. Definitively answering such a question ought not be published on this subject matter (insider risk, individual opportunity) due to the sensitive nature of the information involved. That is a recognition of the problem’s nature and this effort is put forth in good faith to demonstrate the handling and seriousness the problem is afforded by Tessera Semita.

References

  • Efron, B. & Tibshirani, R.J. (1993). An Introduction to the Bootstrap. Chapman & Hall. (bootstrap confidence intervals)
  • Hothorn, T., Hornik, K., van de Wiel, M.A. & Zeileis, A. (2008). Implementing a class of permutation tests: the coin package. J. Stat. Soft. 28(8). (permutation test)
  • Phipson, B. & Smyth, G.K. (2010). Permutation p-values should never be zero. Stat. Appl. Genet. Mol. Biol. 9(1). (the add-one correction)

Methods and terminology

Collection margin of error · Bootstrapping · Permutation test · Spearman rank correlation · Confidence interval · Degree (graph theory)

Computed with R packages boot, coin, and igraph.

Appendix: the code that produced every result

Every number and figure above is produced by exactly the following code, run against the published ABC Calibration tests/*/targets.csv and node_attributes.csv files. Nothing is entered by hand. Set the working directory to the project root (or this folder) and knit to reproduce it.

knitr::opts_chunk$set(echo = FALSE, warning = FALSE, message = FALSE,
                      fig.align = "center", dev = "png", dpi = 150)

# Recognised packages do the inference and the charts: boot (bootstrap CIs),
# coin (permutation test, with a base fallback), igraph (observed degree),
# ggplot2 + ggrepel (figures). Every number and figure is produced by the code in
# the Appendix, run against the published targets.csv files.
.need <- c("boot", "ggplot2", "ggrepel")
.miss <- .need[!vapply(.need, requireNamespace, logical(1), quietly = TRUE)]
if (length(.miss))
  stop("Install required packages: install.packages(c(",
       paste(sprintf('"%s"', .miss), collapse = ", "), "))")
suppressMessages({library(ggplot2); library(ggrepel)})
.has_coin   <- requireNamespace("coin", quietly = TRUE)
.has_igraph <- requireNamespace("igraph", quietly = TRUE)

ts_navy <- "#0a1628"; ts_gold <- "#c4a265"; ts_stone <- "#8a8d91"
ts_text <- "#c8ccd0"; ts_dark <- "#060e1a"; ts_red <- "#c2553f"; ts_white <- "#e8eaed"; ts_green <- "#6f9a4e"

# One dark Tessera theme for every ggplot, so the charts match the site.
theme_tessera <- function(base = 13) {
  theme_minimal(base_size = base) +
    theme(plot.background  = element_rect(fill = ts_dark, colour = NA),
          panel.background = element_rect(fill = ts_dark, colour = NA),
          panel.grid.major = element_line(colour = "#16222f", linewidth = 0.3),
          panel.grid.minor = element_blank(),
          text  = element_text(colour = ts_text),
          axis.text = element_text(colour = ts_stone),
          plot.title    = element_text(colour = ts_white, face = "bold"),
          plot.subtitle = element_text(colour = ts_stone, size = base - 2.5),
          plot.caption  = element_text(colour = ts_stone, size = base - 4, hjust = 0),
          legend.position = "top", legend.title = element_blank(),
          legend.text = element_text(colour = ts_text))
}

proj_root <- function() {
  d <- normalizePath(getwd(), winslash = "/", mustWork = FALSE)
  for (i in 1:8) { if (dir.exists(file.path(d, "validation_networks"))) return(d)
    p <- dirname(d); if (identical(p, d)) break; d <- p }
  stop("Could not find the project root. Set the working directory to it.")
}
ROOT <- proj_root()
read_internal <- function(p) {
  d <- read.csv(p, stringsAsFactors = FALSE)
  if ("boundary" %in% names(d)) d <- d[d$boundary == "internal", , drop = FALSE]
  d
}
# Bootstrap percentile 95% CI for a Spearman correlation (boot::boot +
# boot::boot.ci). Efron & Tibshirani (1993).
boot_ci <- function(x, y, R = 4999) {
  ok <- is.finite(x) & is.finite(y); x <- x[ok]; y <- y[ok]
  if (length(x) < 4) return(c(NA_real_, NA_real_))
  st <- function(df, i) suppressWarnings(cor(df$x[i], df$y[i], method = "spearman"))
  b  <- boot::boot(data.frame(x = x, y = y), st, R = R)
  ci <- tryCatch(boot::boot.ci(b, type = "perc")$percent[4:5],
                 error = function(e) c(NA_real_, NA_real_))
  as.numeric(ci)
}
# Permutation p-value for a Spearman correlation. coin::spearman_test when
# available (distribution-free, right for small n); base cor.test otherwise.
perm_p <- function(x, y, R = 9999) {
  ok <- is.finite(x) & is.finite(y); x <- x[ok]; y <- y[ok]
  if (length(x) < 4 || sd(x) == 0 || sd(y) == 0) return(NA_real_)
  if (.has_coin) {
    p <- tryCatch(as.numeric(coin::pvalue(coin::spearman_test(
           y ~ x, data = data.frame(x = x, y = y),
           distribution = coin::approximate(nresample = R)))),
         error = function(e) NA_real_)
    if (is.finite(p)) return(p)
  }
  suppressWarnings(cor.test(x, y, method = "spearman", exact = FALSE)$p.value)
}
rho <- function(x, y) suppressWarnings(cor(x, y, method = "spearman"))
abc <- file.path(ROOT, "ABC Calibration tests")
draws <- list.dirs(abc, recursive = FALSE, full.names = TRUE)
draws <- draws[grepl("/[0-9]+$", draws)]; draws <- draws[order(as.integer(basename(draws)))]

core_ids <- NULL; labels <- c()
ioi_cols <- list(); osi_cols <- list(); flag_cols <- list()
peri_size <- setNames(rep(NA_real_, length(draws)), basename(draws))
deg_obs <- NULL

for (dd in draws) {
  lab <- basename(dd)
  t <- read_internal(file.path(dd, "targets.csv"))
  ids <- as.character(t$node_id)
  if (is.null(core_ids)) core_ids <- ids
  if ("label" %in% names(t)) labels[ids] <- t$label
  pick <- function(col) setNames(t[[col]], ids)[core_ids]
  ioi_cols[[lab]]  <- as.numeric(pick("IOI"))
  osi_cols[[lab]]  <- if ("OSI" %in% names(t)) as.numeric(pick("OSI")) else NA
  flag_cols[[lab]] <- if ("above_tau" %in% names(t)) as.logical(pick("above_tau")) else NA

  na_path <- file.path(dd, "node_attributes.csv")
  if (file.exists(na_path)) {
    na <- read.csv(na_path, stringsAsFactors = FALSE)
    peri_size[lab] <- sum(!(as.character(na$id) %in% core_ids))
  }
  if (is.null(deg_obs) && .has_igraph) {
    ap <- file.path(dd, "adj_social.csv")
    if (file.exists(ap)) {
      A <- as.matrix(read.csv(ap, row.names = 1, check.names = FALSE))
      common <- intersect(core_ids, rownames(A))
      if (length(common) > 1) {
        g <- igraph::graph_from_adjacency_matrix((A[common, common] > 0) * 1,
               mode = "max", diag = FALSE)
        deg_obs <- setNames(igraph::degree(g), common)[core_ids]
      }
    }
  }
}
IOI  <- do.call(cbind, ioi_cols);  rownames(IOI)  <- core_ids
OSI  <- do.call(cbind, osi_cols);  rownames(OSI)  <- core_ids
FLAG <- do.call(cbind, flag_cols); rownames(FLAG) <- core_ids
n_officers <- length(core_ids); n_draws <- length(draws)

# line of inquiry: the IOI level that separates flagged from unflagged reads
allI <- as.vector(IOI); allF <- as.vector(FLAG)
tau <- if (any(allF, na.rm = TRUE) && any(!allF, na.rm = TRUE))
  mean(c(max(allI[!allF], na.rm = TRUE), min(allI[allF], na.rm = TRUE))) else 1.1
rng1 <- function(v) max(v) - min(v)
officer <- data.frame(
  node_id = core_ids, name = ifelse(is.na(labels[core_ids]), core_ids, labels[core_ids]),
  ioi_median = apply(IOI, 1, median), ioi_sd = apply(IOI, 1, sd),
  ioi_lo = apply(IOI, 1, min), ioi_hi = apply(IOI, 1, max),
  ioi_q1 = apply(IOI, 1, quantile, 0.1), ioi_q3 = apply(IOI, 1, quantile, 0.9),
  ioi_range = apply(IOI, 1, rng1),
  flag_frac = apply(FLAG, 1, function(v) mean(v, na.rm = TRUE)),
  stringsAsFactors = FALSE)
officer$flagged <- officer$flag_frac > 0
if (!is.null(deg_obs)) officer$degree <- as.numeric(deg_obs[core_ids])

# observed (periphery-free) read: the Book Network baseline, scored before any
# periphery was added. The forest dot is this observed read; the bars are the
# plausible-periphery distribution; the shift is how far the periphery moves it.
base_t <- tryCatch(read_internal(file.path(ROOT, "ABC Calibration tests", "Book Network", "targets.csv")),
                   error = function(e) NULL)
has_obs <- !is.null(base_t) && all(c("node_id", "IOI") %in% names(base_t))
if (has_obs) {
  obs <- setNames(base_t$IOI, as.character(base_t$node_id))
  officer$ioi_observed <- as.numeric(obs[core_ids])
  officer$shift <- officer$ioi_median - officer$ioi_observed
}
n_down <- if (has_obs) sum(officer$shift < 0, na.rm = TRUE) else NA
n_up   <- if (has_obs) sum(officer$shift > 0, na.rm = TRUE) else NA
med_shift <- if (has_obs) median(officer$shift, na.rm = TRUE) else NA

# per-draw movement = mean over officers of |IOI(draw) - officer across-draw median|
offmed <- apply(IOI, 1, median)
move   <- colMeans(abs(IOI - offmed))
pv <- data.frame(draw = colnames(IOI), periphery = as.numeric(peri_size[colnames(IOI)]),
                 movement = as.numeric(move[colnames(IOI)]), stringsAsFactors = FALSE)
ps_r <- rho(pv$periphery, pv$movement); ps_p <- perm_p(pv$periphery, pv$movement)
ps_ci <- boot_ci(pv$periphery, pv$movement)
if (!is.null(deg_obs)) {
  dg_r <- rho(officer$degree, officer$ioi_sd); dg_p <- perm_p(officer$degree, officer$ioi_sd)
  dg_ci <- boot_ci(officer$degree, officer$ioi_sd)
}
n_flip <- sum(officer$flagged & officer$flag_frac < 1, na.rm = TRUE)
fd <- officer
fd$ioi_dot <- if (has_obs) fd$ioi_observed else fd$ioi_median
fd <- fd[order(fd$ioi_dot), ]; fd$rank <- seq_len(nrow(fd))
fd$obs_flag <- fd$ioi_dot >= tau
fd$rise <- if (has_obs) !is.na(fd$shift) & fd$shift > 0 else FALSE
fd$crosses <- fd$ioi_hi >= tau                 # plausible margin reaches the line of inquiry
fd$spike <- (fd$ioi_hi - fd$ioi_q3) > 0.25     # a large single-network spike (outlier draw)
labels_show <- subset(fd, obs_flag | rise | crosses | spike)
ggplot(fd, aes(rank)) +
  annotate("rect", xmin = -Inf, xmax = Inf, ymin = tau, ymax = Inf,
           fill = ts_red, alpha = 0.07) +
  geom_hline(yintercept = tau, colour = ts_red, linetype = "dashed") +
  annotate("text", x = 1, y = tau, label = sprintf("line of inquiry (IOI %.2f)", tau),
           colour = ts_red, hjust = 0, vjust = -0.6, size = 3.3) +
  geom_linerange(aes(ymin = ioi_lo, ymax = ioi_hi), colour = ts_stone, linewidth = 0.4) +
  geom_linerange(aes(ymin = ioi_q1, ymax = ioi_q3), colour = ts_gold, linewidth = 1.8,
                 alpha = 0.5) +
  geom_point(aes(y = ioi_median), colour = ts_gold, shape = 95, size = 4) +
  geom_point(aes(y = ioi_dot, colour = obs_flag), size = 2.4) +
  scale_colour_manual(values = c(`FALSE` = ts_white, `TRUE` = ts_red),
                      labels = c("observed read below the line", "observed read above the line")) +
  ggrepel::geom_text_repel(data = labels_show, aes(y = ioi_dot, label = name), colour = ts_text,
                           size = 3, box.padding = 0.5, segment.colour = ts_stone, max.overlaps = 20) +
  labs(title = "Each officer's IOI: observed read vs plausible-periphery distribution",
       subtitle = sprintf("%d officers; dot = observed read, bar = plausible-periphery margin, gold dash = periphery median",
                          n_officers),
       x = "officers (sorted by observed IOI)", y = "IOI") +
  theme_tessera()
ggplot(officer, aes(shift)) +
  geom_histogram(bins = 18, fill = ts_gold, colour = ts_dark) +
  geom_vline(xintercept = 0, colour = ts_stone, linetype = "dashed") +
  labs(title = "How the unseen periphery shifts the observed read",
       subtitle = "periphery median minus observed read, per officer (left of 0 = the periphery lowers the score)",
       x = "shift in IOI (periphery median - observed read)", y = "officers") +
  theme_tessera()
skewness <- function(x) { x <- x[is.finite(x)]; m <- mean(x); s <- sd(x)
  if (length(x) < 3 || is.na(s) || s == 0) return(0); mean((x - m)^3) / s^3 }
nan0 <- function(v) ifelse(is.nan(v) | is.infinite(v), NA, v)
# fingerprint of the grown (Encounter) periphery subgraph + core attachment
fp_sub <- function(adj_path, na_path) {
  if (!file.exists(adj_path) || !file.exists(na_path)) return(NULL)
  na <- read.csv(na_path, stringsAsFactors = FALSE)
  if (!all(c("id", "role") %in% names(na))) return(NULL)
  A <- as.matrix(read.csv(adj_path, row.names = 1, check.names = FALSE)); A <- (A > 0) * 1; diag(A) <- 0
  ids <- rownames(A)
  enc <- intersect(as.character(na$id[na$role == "Encounter"]), ids)
  intern <- intersect(as.character(na$id[na$boundary == "internal"]), ids)
  if (length(enc) < 5) return(NULL)
  if (.has_igraph) {
    g <- igraph::graph_from_adjacency_matrix(A[enc, enc, drop = FALSE], mode = "max", diag = FALSE)
    deg <- igraph::degree(g); cmp <- igraph::components(g); n <- length(enc)
    return(c(density = igraph::edge_density(g),
      degree_cv = if (mean(deg) > 0) sd(deg) / mean(deg) else 0, degree_skew = skewness(deg),
      mean_clustering = nan0(igraph::transitivity(g, type = "localaverage")),
      transitivity = nan0(igraph::transitivity(g, type = "global")),
      largest_comp_frac = max(cmp$csize) / n, n_components_norm = cmp$no / n,
      attach = if (length(intern)) sum(A[intern, enc]) / length(intern) else NA))
  }
  NULL
}
DIVKEYS <- c(density = "density", degree_cv = "degree spread (CV)", degree_skew = "degree skew",
             mean_clustering = "clustering", transitivity = "transitivity",
             largest_comp_frac = "largest component", n_components_norm = "fragmentation",
             attach = "core attachment")
collect <- function(dirs) do.call(rbind, Filter(Negate(is.null), lapply(dirs, function(d)
  fp_sub(file.path(d, "adj_social.csv"), file.path(d, "node_attributes.csv")))))
ref_dirs <- list.dirs(file.path(ROOT, "validation_networks"), recursive = FALSE, full.names = TRUE)
ref_dirs <- ref_dirs[grepl("/[0-9]+$", ref_dirs)]
test_fp <- collect(draws); ref_fp <- collect(ref_dirs)
has_div <- !is.null(test_fp) && !is.null(ref_fp) && nrow(test_fp) > 2 && nrow(ref_fp) > 2
if (has_div) {
  cover <- sapply(names(DIVKEYS), function(k) {
    rw <- diff(range(ref_fp[, k], na.rm = TRUE))
    if (!is.finite(rw) || rw <= 0) NA else diff(range(test_fp[, k], na.rm = TRUE)) / rw })
  struct_cov <- median(cover[setdiff(names(DIVKEYS), "attach")], na.rm = TRUE)
  attach_cov <- cover["attach"]
}
divlong <- if (has_div) do.call(rbind, lapply(names(DIVKEYS), function(k) {
  rlo <- min(ref_fp[, k], na.rm = TRUE); w <- diff(range(ref_fp[, k], na.rm = TRUE))
  data.frame(metric = unname(DIVKEYS[k]),
             norm = if (is.finite(w) && w > 0) (test_fp[, k] - rlo) / w else rep(0.5, nrow(test_fp)))
})) else data.frame(metric = character(), norm = numeric())
if (nrow(divlong)) divlong$metric <- factor(divlong$metric, levels = rev(unname(DIVKEYS)))

ggplot(divlong, aes(norm, metric)) +
  annotate("rect", xmin = 0, xmax = 1, ymin = -Inf, ymax = Inf, fill = ts_green, alpha = 0.13) +
  geom_vline(xintercept = c(0, 1), linetype = "dashed", colour = ts_green) +
  geom_jitter(height = 0.18, width = 0, colour = ts_gold, alpha = 0.7, size = 1.6) +
  labs(title = "Do the periphery draws span the model's structural range?",
       subtitle = "each row normalised to the model's unconstrained range (green = [0,1]); dots are the periphery draws",
       x = "position within the model's unconstrained range", y = NULL) +
  theme_tessera()
top <- head(officer[order(-officer$ioi_sd), ], 8)
knitr::kable(data.frame(
  Officer = top$name,
  `Median IOI` = sprintf("%.2f", top$ioi_median),
  `Margin (min to max)` = sprintf("%.2f to %.2f", top$ioi_lo, top$ioi_hi),
  `Margin SD` = sprintf("%.3f", top$ioi_sd),
  `Crosses line of inquiry` = ifelse(top$flagged, "yes, in some draws", "no"),
  check.names = FALSE, row.names = NULL))
ggplot(pv, aes(periphery, movement)) +
  geom_smooth(method = "lm", formula = y ~ x, colour = ts_red,
              fill = ts_stone, alpha = 0.18, linewidth = 0.8) +
  geom_point(colour = ts_gold, size = 2.4) +
  labs(title = "Does a larger unseen periphery move the known scores?",
       subtitle = sprintf("Spearman %.2f  (permutation p = %.3f, bootstrap 95%% CI [%.2f, %.2f])",
                          ps_r, ps_p, ps_ci[1], ps_ci[2]),
       caption = "A weak or absent relationship is the good result: the read is not hostage to how much remains uncollected.",
       x = "periphery added (nodes)", y = "mean |IOI movement| of the core") +
  theme_tessera()
ggplot(officer, aes(degree, ioi_sd)) +
  geom_smooth(method = "lm", formula = y ~ x, colour = ts_red,
              fill = ts_stone, alpha = 0.18, linewidth = 0.8) +
  geom_point(colour = ts_gold, size = 2.4) +
  labs(title = "Is a better-observed officer's read tighter?",
       subtitle = sprintf("Spearman %.2f  (permutation p = %.3f, bootstrap 95%% CI [%.2f, %.2f])",
                          dg_r, dg_p, dg_ci[1], dg_ci[2]),
       x = "observed degree (core-core ties)", y = "IOI margin (SD across draws)") +
  theme_tessera()