R

R source for the quadrant plots in the comparative review. Data is embedded in the script. Save as snapshot-comparison.R and run using Rscript snapshot-comparison.R. # Medical Snapshot System: Quadrant Analysis # # Two scatter plots positioning 26 health data systems on research mechanics vs. ethics axes. # # Supporting exhaustive review at https://shearer.org/research/medical-observer-systems-review.md and # the overview of the Snapshot proposal at https://shearer.org/research/medical-snapshot-system.md # # and various works by Dan Shearer 2007-2026 # # Output: combined snapshot_quadrant.pdf and snapshot_quadrant.png # also snapshot_quadrant_p1.png and _p2.png separated out # # Dependencies: tidyverse, ggrepel, patchwork # install.packages(c("tidyverse", "ggrepel", "patchwork")) options(repos = c(CRAN = "https://cran.r-project.org")) if (!requireNamespace("ggrepel", quietly = TRUE)) install.packages("ggrepel") if (!requireNamespace("patchwork", quietly = TRUE)) install.packages("patchwork") library(tidyverse) library(ggrepel) library(patchwork) # -- 1. Data ------------------------------------------------------------------ # mech : research mechanics score A1-B7 (max 7) # core : core participant ethics D13,F16,C8-C10,D11 (max 6) # voluntary consent + public data release + individual clinical benefit # full : full governance ethics C8-F18 (max 11) # adds fiduciary duty, state exclusion, multi-jurisdictional, payment # category : display group # label : display name (NA = unlabelled in plot) systems <- tribble( ~id, ~label, ~mech, ~core, ~full, ~category, # -- isolated / labelled points --------------------------------------------- # Evidence tiers: A = Chinese govt source, B = Citizen Lab/HRW primary doc, # C = HRW interpretive inference only. ASPI excluded entirely. # "Physicals for All": mechanics (A1-B7) A/B-confirmed; D12+F17 inversions # A-confirmed via Article 16, 2019 Human Genetic Resources Regulations; # D13 inversion C-only (single HRW interview, culturally contested). # MPS database: A2+D13 inversions B-confirmed via Citizen Lab. # Composite scores (core, full) are unchanged from pre-exclusion values # because all inversions count zero regardless of confidence tier. "snapshot", "Medical Snapshot", 7.0, 6.0, 11.0, "Target", "physicals", "Physicals for All", 7.0, 0.0, 0.0, "Coercive", "dodsr", "DoD Serum Repository", 6.0, 2.0, 2.0, "Military", "tuskegee", "Tuskegee", 2.0, 0.0, 0.0, "Coercive", "nz", "NZ Experiment", 1.0, 0.0, 0.0, "Coercive", "ndnad", "NDNAD / CODIS", 3.0, 0.0, 0.0, "Coercive", "decode", "deCODE", 4.0, 0.0, 1.0, "Coercive", "guthrie", "Guthrie Card", 3.5, 2.0, 2.0, "Other", # -- research biobank cluster (exact scores; jitter applied in geom) -------- "epic", NA, 5.5, 2.0, 2.0, "Research", "ckb", NA, 5.0, 2.0, 2.0, "Research", "ukbb", NA, 5.0, 2.0, 2.0, "Research", "taizhou", NA, 5.0, 2.0, 2.0, "Research", "cnhbm", NA, 5.0, 1.0, 1.0, "Research", "framingham", NA, 4.0, 2.0, 2.0, "Research", "whitehall", NA, 4.0, 2.0, 2.0, "Research", "nurses", NA, 4.0, 2.0, 2.0, "Research", "alspac", NA, 4.0, 2.0, 2.0, "Research", "bbjapan", NA, 4.0, 2.0, 2.0, "Research", "allofus", NA, 4.0, 2.0, 2.0, "Research", "genscot", NA, 3.5, 2.0, 2.0, "Research", "estonian", NA, 3.0, 2.0, 2.0, "Research", "finngen", NA, 3.0, 1.0, 2.0, "Research", "ofh", NA, 3.0, 1.0, 1.0, "Research", "majengo", NA, 2.5, 0.5, 0.5, "Other", # -- surveillance ----------------------------------------------------------- "cngb", NA, 4.0, 0.0, 0.0, "Surveillance", "mps", NA, 3.0, 0.0, 0.0, "Surveillance" ) %>% mutate( category = factor(category, levels = c("Target","Research","Coercive", "Military","Surveillance","Other")), labelled = !is.na(label) ) # -- 2. Aesthetics ------------------------------------------------------------ pal <- c( "Target" = "#16a34a", "Research" = "#2563eb", "Coercive" = "#dc2626", "Military" = "#7c3aed", "Surveillance" = "#d97706", "Other" = "#6b7280" ) shp <- c( "Target" = 23, # diamond (filled) "Research" = 21, # circle (filled) "Coercive" = 24, # triangle up (filled) "Military" = 22, # square (filled) "Surveillance" = 25, # triangle down (filled) "Other" = 21 # circle (filled) ) base_theme <- theme_minimal(base_size = 13) + theme( legend.position = "bottom", legend.title = element_blank(), legend.key.size = unit(0.45, "cm"), legend.text = element_text(size = 9), panel.grid.major = element_line(colour = "grey92", linewidth = 0.35), panel.grid.minor = element_blank(), axis.title = element_text(size = 10, colour = "grey40"), axis.text = element_text(size = 9, colour = "grey50"), plot.title = element_text(size = 11, face = "plain", margin = margin(b = 2)), plot.subtitle = element_text(size = 9, colour = "grey40", lineheight = 1.3, margin = margin(b = 6)), plot.margin = margin(6, 12, 6, 6) ) # -- 3. Plot function --------------------------------------------------------- make_quad <- function(dat, y_col, y_max, q_y, y_label, title, subtitle, x_max = 7.8, gap_bracket = FALSE) { y_step <- if (y_max == 6) 1 else 2 p <- ggplot(dat, aes(x = mech, y = .data[[y_col]], colour = category, fill = category, shape = category)) + # Quadrant shading --------------------------------------------------------- annotate("rect", xmin = 3.5, xmax = Inf, ymin = -Inf, ymax = q_y, fill = "#fef2f2", alpha = 0.6) + annotate("rect", xmin = 3.5, xmax = Inf, ymin = q_y, ymax = Inf, fill = "#eff6ff", alpha = 0.28) + # Research-biobank cluster box -------------------------------------------- annotate("rect", xmin = 3.25, xmax = 5.75, ymin = 1.15, ymax = 2.95, fill = "#dbeafe", colour = "#93c5fd", alpha = 0.4, linewidth = 0.45) + annotate("text", x = 4.5, y = 3.15, label = "research biobanks", size = 3, colour = "#1d4ed8", hjust = 0.5) + # Quadrant dividers ------------------------------------------------------- geom_vline(xintercept = 3.5, linetype = "dashed", colour = "grey55", linewidth = 0.45) + geom_hline(yintercept = q_y, linetype = "dashed", colour = "grey55", linewidth = 0.45) + # Points: jitter unlabelled to reveal cluster density -------------------- geom_jitter(data = filter(dat, !labelled), position = position_jitter(width = 0.13, height = 0.08, seed = 42), size = 2.2, alpha = 0.8, stroke = 0.4) + # Points: exact positions for labelled ------------------------------------ geom_point(data = filter(dat, labelled), size = 3.5, stroke = 0.65) + # Labels (ggrepel handles overlap) ---------------------------------------- geom_label_repel( data = filter(dat, labelled), aes(label = label), colour = "grey15", fill = "white", size = 3.5, label.size = 0.3, label.padding = unit(0.20, "lines"), box.padding = unit(0.6, "lines"), point.padding = unit(0.4, "lines"), min.segment.length = 0.2, show.legend = FALSE ) + # Scales ------------------------------------------------------------------ scale_colour_manual(values = pal, drop = FALSE) + scale_fill_manual(values = pal, drop = FALSE) + scale_shape_manual(values = shp, drop = FALSE) + scale_x_continuous(limits = c(-0.2, x_max), breaks = 0:7, expand = expansion(0)) + scale_y_continuous(limits = c(-0.6, y_max + 1.6), breaks = seq(0, y_max, y_step), expand = expansion(0)) + labs(x = "Research mechanics (0 - 7)", y = y_label, title = title, subtitle = subtitle, colour = NULL, fill = NULL, shape = NULL) + base_theme # Bracket showing unclaimed gap (plot 2 only) ------------------------------ if (gap_bracket) { p <- p + annotate("segment", x = 7.3, xend = 7.3, y = 2.95, yend = 10.9, colour = "grey50", linewidth = 0.55, arrow = arrow(ends = "both", type = "open", length = unit(0.12, "cm"))) + annotate("text", x = 7.42, y = 7.0, label = "9 unachieved\nfeatures", size = 3.2, colour = "grey40", hjust = 0, lineheight = 1.2) } p } # -- 4. Build plots ----------------------------------------------------------- p1 <- make_quad( dat = systems, y_col = "core", y_max = 6, q_y = 1, y_label = "Core participant ethics (0 - 6)", title = "Plot 1 -- core participant ethics", subtitle = paste0( "Voluntary consent + public data release + individual clinical benefit.\n", "Research biobanks and DoD Serum Repository reach score 2 by different routes." ) ) p2 <- make_quad( dat = systems, y_col = "full", y_max = 11, q_y = 1, y_label = "Full governance ethics (0 - 11)", title = "Plot 2 -- full governance ethics", subtitle = paste0( "Adds fiduciary duty, state-access exclusion, multi-jurisdictional\n", "architecture, and payment. Research biobanks barely move." ), x_max = 8.1, gap_bracket = TRUE ) # -- 5. Combine and save ------------------------------------------------------ combined <- (p1 | p2) + plot_layout(guides = "collect") & theme(legend.position = "bottom") ggsave("snapshot_quadrant.pdf", combined, width = 18, height = 8, device = cairo_pdf) ggsave("snapshot_quadrant.png", combined, width = 18, height = 8, dpi = 300, bg = "white") ggsave("snapshot_quadrant_p1.pdf", p1, width = 9, height = 8, device = cairo_pdf) ggsave("snapshot_quadrant_p1.png", p1, width = 9, height = 8, dpi = 300, bg = "white") ggsave("snapshot_quadrant_p2.pdf", p2, width = 9, height = 8, device = cairo_pdf) ggsave("snapshot_quadrant_p2.png", p2, width = 9, height = 8, dpi = 300, bg = "white") message("Saved: combined, p1, and p2 as PDF and PNG")