Chapter 8: Data Modeling, AI, and Machine Learning in Biomedical Image Analysis

Overview, Motivation, and Learning Objectives

Relevance to biomedical physics curriculum

The preceding BPAD2 chapters explain how physical interactions become medical images. Photons are attenuated, nuclear spins precess and relax, pressure waves propagate, detectors sample signals, and reconstruction algorithms transform those signals into spatial arrays. Filtering, registration, and segmentation then convert images into measurements. The final scientific step is to decide what those measurements imply about disease, treatment, physiology, or future outcome.

That step is not separate from biomedical physics. A predictive model inherits every assumption and uncertainty introduced upstream:

\[\text{patient} \longrightarrow \text{physical signal} \longrightarrow \text{sampled data} \longrightarrow \text{reconstructed image} \longrightarrow\\ \longrightarrow \text{ROI or representation} \longrightarrow \text{prediction or decision}.\]

A change in dose, field strength, pulse sequence, reconstruction kernel, voxel spacing, contrast timing, segmentation boundary, or reference standard can alter the numerical input to a model. Medical-image AI must therefore be understood as a measurement-and-inference system, not merely as a classifier attached to an image.

Central principle. The modeling begins at study design and data acquisition, not at the first line of machine-learning code. Generalization depends on the stability of the complete chain from physics to decision.

This chapter integrates three complementary strands of BPAD2:

the mathematical foundations of Chapter 1, including calculus, linear algebra, probability, optimization, convolution, Fourier analysis, differential equations, and error propagation;
the image-processing and segmentation concepts developed in the modality chapters; and
the kidney imaging-clinical case study, which links clinical metadata, volumetric CT, expert reference masks, imaging-derived biomarkers, and patient outcomes.

Driving motivational challenge: The chapter uses a kidney-tumor problem as a longitudinal case study. We ask how preoperative clinical information and contrast-enhanced CT can support five different tasks:

segmentation: delineate kidney and tumor voxels;
diagnosis or characterization: estimate whether a mass is malignant;
regression: predict a continuous outcome such as postoperative decline in estimated glomerular filtration rate (eGFR);
prognosis: model time to death or another censored event; and
decision support: determine whether a prediction changes management at an acceptable balance of benefit and harm.

These are not interchangeable tasks. They have different targets, loss functions, sampling units, performance measures, and evidentiary requirements.

Kidney case-study

This kidney case-study connects spreadsheet metadata to 3D NIfTI volumes and semantic masks. Two distinctions are made explicit here for scientific consistency.

The publicly released KiTS19 image volumes are contrast-enhanced abdominal computed tomography (CT) scans (rather than MRI volumes).
KiTS19 and KiTS21 are related but distinct challenge cohorts. The 210 publicly released KiTS19 training cases, their CT images, expert reference segmentations, clinical context, and surgical outcomes form the classic public teaching workflow. Later KiTS cohorts should not be silently merged with KiTS19 descriptions or metadata.

The executable core uses the real, publicly released KiTS19 cohort: the 210 training cases with their clinical records, and the corresponding expert reference segmentations. Nothing in the analytic spine of this chapter is simulated. Where a full CT volume is too large to download by default, the chapter says so explicitly and names the source it used instead.

This BPAD/SOCR case-study is focused on understanding clinical data (spreadsheets), imaging data (MRI), and extraction of imaging-derived biomarkers (morphometric measures). The joint clinical and imaging data can be used for prediction, classification, segmentation, modeling, and forecasting of kidney stones and tumors using imaging and clinical data.

library("tidyverse")
library(plotly)

This kidney case-study can be used for building some simple models (e.g., correlational or linear-models using the meta-data, or imaging models computing the size, volume, diameter, surface area etc. of the kidney mask volumes, which are small, see attached 3D NII.gz kidney stone segmentation-mask volume).

Technical Details

URL
The KiTS21 cohort includes 210 patients who underwent partial or radical nephrectomy for suspected renal malignancy between 2010 and 2020 at M Health Fairview or Cleveland Clinic medical center.
Meta-data: (.csv), includes the following data elements: case_id, age_at_nephrectomy, gender, body_mass_index, comorbidities/myocardial_infarction, comorbidities/congestive_heart_failure, comorbidities/peripheral_vascular_disease, comorbidities/cerebrovascular_disease, comorbidities/dementia, comorbidities/copd, comorbidities/connective_tissue_disease, comorbidities/peptic_ulcer_disease, comorbidities/uncomplicated_diabetes_mellitus, comorbidities/diabetes_mellitus_with_end_organ_damage, comorbidities/chronic_kidney_disease, comorbidities/hemiplegia_from_stroke, comorbidities/leukemia, comorbidities/malignant_lymphoma, comorbidities/localized_solid_tumor, comorbidities/metastatic_solid_tumor, comorbidities/mild_liver_disease, comorbidities/moderate_to_severe_liver_disease, comorbidities/aids, smoking_history, age_when_quit_smoking, pack_years, chewing_tobacco_use, alcohol_use, intraoperative_complications/blood_transfusion, intraoperative_complications/injury_to_surrounding_organ, intraoperative_complications/cardiac_event, hospitalization, ischemia_time, radiographic_size, pathologic_size, malignant, pathology_t_stage, pathology_n_stage, pathology_m_stage, tumor_histologic_subtype, tumor_necrosis, tumor_isup_grade, clavien_surgical_complications, er_visit, readmission, estimated_blood_loss, surgery_type, surgical_procedure, surgical_approach, operative_time, cytoreductive, positive_resection_margins, last_preop_egfr/value, last_preop_egfr/days_before_nephrectomy, first_postop_egfr/value, first_postop_egfr/days_before_nephrectomy, last_postop_egfr/value, last_postop_egfr/days_before_nephrectomy, vital_status, vital_days_after_surgery, voxel_spacing/x_spacing, voxel_spacing/y_spacing, voxel_spacing/z_spacing
Imaging Data:
- Raw MRI images, e.g., volume case 00001. Note that these are very large 3D (solid) volumes, i.e., tensors of approximate dimensions $500^3$ stored in *.nii.gz format, which are very difficult to manipulate and visualize real-time. We’ll demonstrate interactive use by subsampling the 3D volumes to facilitate quick and effective navigation, however, in real studies, working with specialized software and high-resolution volumes is advantageous.
- Imaging MASKS data are available in NII.gz format on GitHub e.g., mask case 00001. The masks can be easily displayed using the SOCR Brain Viewer. Note that each mask (Kidney_mask_3D_vol, segmentation.nii.gz) has 3 intensity levels - background (0), kidney-mask (1), and tumor-mask (2).

Meta-Data Import: The data can be imported from the clinical meta-data website, which is available in a .csv file format on Canvas.

Mathematical bridges from Chapter 1

Chapter 1 foundation	Role in Chapter 8	Biomedical-imaging example
Vectors, matrices, tensors	Patients-by-features matrices and voxel arrays	$X\in\mathbb{R}^{n\times p}$; CT volume $I\in\mathbb{R}^{n_x\times n_y\times n_z}$
Eigenvalues and SVD	PCA, low-rank representations, graph Laplacians	Compress correlated radiomic features
Probability and Bayes’ theorem	Likelihood, posterior risk, prevalence dependence	Convert sensitivity and specificity into post-test probability
Derivatives and optimization	Gradient descent and backpropagation	Train regression models and neural networks
Convolution and Fourier analysis	Learned spatial filters in CNNs	Detect edges, textures, organs, and tumors
ODEs and nonlinear models	Longitudinal imaging biomarkers	Estimate tumor growth rate and carrying capacity
Error propagation	Feature robustness and predictive uncertainty	Quantify the effect of a one-voxel boundary perturbation
Sampling and aliasing	Resolution, resampling, and domain shift	Explain why voxel spacing changes texture features
Noise models and SNR	Likelihoods, augmentation, robustness	Contrast CT, PET, and MRI measurement variability

Learning objectives

By the end of this chapter, the reader should be able to:

formulate a biomedical-imaging question as a prediction, estimation, segmentation, clustering, or causal task;
identify patient, examination, lesion, slice, and voxel levels in a hierarchical dataset;
express supervised learning as regularized empirical risk minimization;
derive and interpret squared-error, cross-entropy, hinge, and Dice-type losses;
explain the bias-variance tradeoff and roles of capacity, regularization, sample size, and measurement noise;
construct a leakage-free train/tune/test workflow with patient-level grouping and nested resampling;
import and document clinical metadata while preserving units, missingness, censoring, and provenance;
compute physically meaningful morphometric and first-order radiomic features from a 3D image and mask;
connect PCA to singular value decomposition and distinguish dimensionality reduction from feature selection;
fit and evaluate linear, logistic, penalized, nearest-neighbor, tree-based, and kernel models;
recognize when a censored outcome requires survival methods rather than ordinary logistic regression;
explain the relation among convolution, activation functions, backpropagation, CNNs, and U-Net;
evaluate classification, regression, survival, and segmentation using discrimination, calibration, uncertainty, and utility;
diagnose scanner, site, population, and workflow shifts and design an external-testing strategy;
assess interpretability, fairness, privacy, reproducibility, human factors, and monitoring; and
report an imaging-AI study using current radiomics, prediction-model, and medical-imaging guidance;
read a NIfTI volume directly from its byte-level header and convert voxel counts into physical volumes; and
recognize real data pathologies – truncated laboratory values, semantic string sentinels, structurally informative missingness, and protocol heterogeneity – and choose a defensible analytic response to each.

A two-track reading plan

The core track includes Sections 1–7, the kidney case study, classical prediction, evaluation, and reproducibility. The advanced track includes copulas, survival analysis, spectral methods, deep learning, conformal prediction, harmonization, and deployment. All advanced sections remain connected to the same kidney problem so that the chapter develops depth rather than becoming a catalog of algorithms.

Computational aspects

This chapter is designed as self-contained executable, modifiable, and effective end-to-end workflow. Each result, figure and output below is produced by this pipeline workflow, from data that is freely accessible. To compile the Rmd notebook, run the code chunk how-to-run in interactive mode (do not update the setting eval=FALSE).

Requirements. A recent R installation. The analytic core uses only base R plus jsonlite to read the released metadata. Optional sections use survival, glmnet, randomForest, e1071, and pROC, each is guarded by has_pkg(), so missing packages degrade the chapter gracefully rather than stopping the knit.

Data. The clinical metadata is a single ~0.5 MB file. Each reference segmentation is ~0.8 MB, and the chapter processes bpad.n_mask_cases of them (default 30, about two to four minutes on first run). Everything is cached in bpad.cache_dir, so later knits are fast.

Option	Default	What it controls
`bpad.cache_dir`	session temp dir	Where downloads are cached. Set to a persistent folder to download once.
`bpad.allow_network`	`TRUE`	Set `FALSE` to run purely from an existing cache.
`bpad.n_mask_cases`	`30`	How many real segmentation volumes to process into imaging features.
`bpad.download_ct`	`FALSE`	Fetch a full released CT volume for Hounsfield-unit and texture work (large).
`bpad.local_ct`	`""`	Path to a NIfTI volume you already have.
`bpad.run_heavy`	`FALSE`	Enable the spectral-segmentation eigendecomposition.

## Example: cache persistently, process more cases, and use a local CT volume.
options(
  bpad.cache_dir    = "~/bpad_cache",
  bpad.n_mask_cases = 60,
  bpad.download_canvas_mri = TRUE,
  bpad.downsample_factor = 4,
  bpad.download_ct = TRUE,
  bpad.local_ct     = "~/data/case_00000/imaging.nii.gz"
)
rmarkdown::render("BPAD2_Chapter08_DataModeling_AI_ML.Rmd", output_format="html_document")
# rmarkdown::render("BPAD2_Chapter08_DataModeling_AI_ML.Rmd", output_format="word_document")

Learning Module. Each major section ends with a boxed prompt. Boxes marked Try it yourself ask you to change code and observe what moves. Boxes marked Checkpoint ask a question you should be able to answer before continuing. The most valuable exercises are the ones that make a result get worse in a predictable way, because that is how you learn which assumption was carrying the result.

Expectations. Real cohorts do not produce tidy figures. Roughly nine of every ten resected masses here are malignant, only 21 deaths are observed, laboratory values are truncated at the top of their reportable range, and slice thickness varies tenfold. Discrimination statistics are correspondingly modest. Resist the temptation to “fix” this by tuning until the numbers look publishable – diagnosing why a real dataset resists a method is the actual skill this chapter teaches.

Running Interactive Demonstrations with `RShiny` Apps

Many demonstrations in this BPAD Chapter use interactive RShiny apps. In principle, RShiny apps require a two-way connection. Frontend client web browser sends user input to a backend active R server, like Shiny Server or Posit Connect. The client sends the server instructions and the server runs R code and returns output (like plots) back to the browser.

Alternatively, learners can utilize shinylive package to eliminate the R server completely by packaging a tiny WebAssembly version of R (webR) alongside the RShiny code provided in these examples directly into the HTML document.

In BPAD, we avoid this approach to reduce the size of the BPAD chapters and minimize complexity of the resulting master self-contained and portable HTML pages. However, readers are encouraged to experiment with this option with smaller sections to compile HTML files that embed an RShiny into the page directly. In this case, the browser silently downloads the WebAssembly engine (webR) into local browser memory. The browser executes R and the Shiny app locally on the client’s computer inside the browser process. This provides a fully functional, live Shiny app without installing R, running RStudio, or hosting a backend server! However, this approach has scalability cnstraints.

Method A: Embedding via `Quarto`

Using Quarto (.qmd), the modern successor to R Markdown that uses almost identical syntax, provides an official Extension that handles shinylive seamlessly.

Setup in Terminal: In RStudio project directory, open the terminal (RStudio Terminal tab) and run this bash command

quarto add quarto-ext/shinylive

Edit, copy-paste Rmd code-chunks into a Quarto (.qmd) document: Use the shinylive-r block header and set #| standalone: true. Below is an example using one of the RShiny app demos shown later in this BPAD Chapter 8.

When rendered with Quarto, the source BPAD_ChapXSecYAppZ.qmd builds a standalone HTML file where the Shiny app runs locally inside the user’s browser.

Method B: Embedding in Standard `R` Markdown (.Rmd) via `iframe`

A more classical .Rmd approach relies on exporting the specific BPAD RShiny app as a static bundle using the {shinylive} R package and embed it via an iframe.

Copy, Paste and Save the app Rmd code-chunk into a separate file. Create a folder named BPAD_ChapXSecYAppZ and place the Shiny application inside an app.R file.
Convert the app to a static Shinylive directory. In the R console, run:

Install shinylive if needed

install.packages(“shinylive”) # Export app.R into a WebAssembly static site directory shinylive::export(appdir = “my_app”, destdir = “exported_app”)

Embed the output in the .Rmd file. Inside the R Markdown notebook, embed the generated exported_app folder using HTML:

\<iframe src="exported_app/index.html" width="100%" height="700px" style="border:none;"\> \</iframe\>

Important Caveats with WebAssembly / ShinyliveInitial:

Load Time. The very first time a user opens the page, the browser has to download the WebAssembly engine (webR) and R packages (shiny, ggplot2). This usually takes 5–10 seconds on first load (subsequent visits are fast due to browser caching).
Data Availability: Because the code runs entirely in the browser, any data used (like kidney_model) must either be generated inside the app script or explicitly bundled as a file alongside the app.
CORS Restrictions: For local testing on a computer without a web server, browsers may block loading WebAssembly files over the file://... protocol. View the output using RStudio’s previewer or run httpuv::runStaticServer("exported_app/") locally to test.

1. From Physical Measurement to a Learning Problem

1.1 A compositional model of the imaging-AI chain

Let $S$ denote an underlying biological state, $A$ acquisition settings, $N$ measurement noise, $R$ reconstruction, $P$ preprocessing, $G$ segmentation or representation, and $f$ a prediction rule. A compact pipeline is

\[\underbrace{Y^{\ast}=f_{\theta}\{G[P(R(S,A,N))]\}}_{\text{schematic prediction framework}}.\]

More explicitly, an observed image can be written

\[ I=\mathcal{R}\{\mathcal{A}(S;A)+N\}, \]

features as

\[ z=g(I,M;\psi), \]

and prediction as

\[ \widehat y=f_{\theta}(z,x_c), \]

where $M$ is a mask, $x_c$ is clinical information, and $\psi$ collects feature-extraction choices. The fitted model therefore depends on both $\theta$ and all upstream operations.

A useful error decomposition is

\[ \widehat y-y = \underbrace{\Delta_{\mathrm{acq}}}_{\text{acquisition}} + \underbrace{\Delta_{\mathrm{recon}}}_{\text{reconstruction}} + \underbrace{\Delta_{\mathrm{seg}}}_{\text{segmentation}} + \underbrace{\Delta_{\mathrm{model}}}_{\text{statistical model}} + \underbrace{\Delta_{\mathrm{shift}}}_{\text{deployment shift}} + \underbrace{\epsilon}_{\text{residual noise}}. \]

These terms need not be additive or independent and the error-decomposition is a reasoning device that prevents all uncertainty from being attributed to the final algorithm.

1.2 Units of observation and hierarchical dependence

If $i$ indexes patients, $j$ examinations, $k$ lesions, and $v$ voxels, an observation may be written $I_{ijkv}$. Voxels from the same lesion are more alike than voxels from different patients. Slices from one examination share anatomy and acquisition. Treating all slices or patches as independent inflates nominal sample size.

Leakage warning. If slices from one patient are divided between training and testing sets, the model is tested on anatomy and acquisition characteristics it has already seen. Split at the highest relevant independent unit, usually the patient and sometimes the site or time period.

1.3 Prediction target, intended use, and action

A target must be attached to a time point. Preoperative pathology prediction cannot use postoperative variables. A risk model must specify its horizon. A segmentation model must specify its label ontology. A decision-support model must specify the action it is intended to inform.

A strong intended-use statement contains population, time point, inputs, output, horizon, user, and action. Model evaluation is incomplete if any of these are undefined.

1.4 Supervised, unsupervised, semi-supervised, and self-supervised learning

In supervised learning, paired inputs and labels $\{(x_i,y_i)\}_{i=1}^{n}$ estimate a mapping from $X$ to $Y$. Classification, regression, survival prediction, detection, and segmentation are supervised tasks.

In unsupervised learning, the model sees $X$ without target labels. PCA, clustering, density estimation, and many anomaly-detection methods are examples.

In semi-supervised learning, a small labeled set is combined with a larger unlabeled set. In self-supervised learning, targets are constructed from the data, for example by reconstructing masked patches or contrasting related views, before task-specific fine-tuning.

1.5 Mechanistic, statistical, predictive, and causal models

A mechanistic model encodes physical or biological structure, such as radioactive decay or logistic tumor growth. A statistical model describes associations and uncertainty. A predictive model is optimized for future outcomes. A causal model targets the effect of intervention under explicit assumptions.

These goals can overlap but are not synonyms. A feature may predict because it records a downstream treatment consequence. That does not make it a valid baseline confounder. Conversely, a causal estimate can be scientifically important without maximizing individual prediction accuracy.

Prediction versus causation. Predicting who receives radical nephrectomy is not the same as estimating whether assigning radical nephrectomy changes outcome. The second question requires causal design and assumptions beyond ordinary supervised learning.

2. Mathematical Foundations of Statistical Learning

2.1 Design matrices and parameterized prediction rules

For $n$ patients and $p$ predictors,

\[ X= \begin{bmatrix} 1 & x_{11} & \cdots & x_{1p}\\ 1 & x_{21} & \cdots & x_{2p}\\ \vdots & \vdots & \ddots & \vdots\\ 1 & x_{n1} & \cdots & x_{np} \end{bmatrix} \in\mathbb{R}^{n\times(p+1)}, \qquad Y=\begin{bmatrix}y_1&\cdots&y_n\end{bmatrix}^{\mathsf T}. \]

A linear predictor is $\eta=X\beta$. Regression uses $\widehat Y=X\widehat\beta$. Logistic regression converts a predictor $\eta_i$ to a probability through

\[ \sigma(\eta_i)=\frac{1}{1+e^{-\eta_i}}. \]

An image is itself a tensor, so a neural network can be viewed as a parameterized sequence of tensor transformations that ultimately produces a score, probability, or mask.

2.2 Empirical risk minimization

To fit a model, many algorithms solve the following optimization problem

\[ \widehat\theta = \arg\min_{\theta} \left[ \underbrace{\frac{1}{n}\sum_{i=1}^{n} \ell\{y_i,f_{\theta}(x_i)\}}_{\text{fidelity term}} + \lambda\underbrace{\Omega(\theta)}_{\text{smoothing regularization}} \right]. \]

The first term (fidelity) measures misfit through loss $\ell$. The second term (regularization) is a smoothing penalty. The tuning parameter $\lambda\ge0$ controls model complexity.

Task/model	Loss	Typical penalty
Linear regression	$(y-\widehat y)^2$	none, ridge, lasso
Logistic regression	binary cross-entropy	none, ridge, lasso
SVM	hinge loss	squared norm
Neural classifier	cross-entropy	weight decay, augmentation
Segmentation network	cross-entropy, Dice, or both	weight decay, augmentation

2.3 Least squares, likelihood, and matrix geometry

For

\[ Y=X\beta+\varepsilon, \qquad \varepsilon\sim\mathcal{N}(0,\sigma^2I), \]

least squares minimizes $Q(\beta)=\lVert Y-X\beta\rVert_2^2$. Differentiation gives

\[ X^{\mathsf T}X\widehat\beta=X^{\mathsf T}Y. \]

When $X^{\mathsf T}X$ is invertible,

\[ \widehat\beta=(X^{\mathsf T}X)^{-1}X^{\mathsf T}Y. \]

Geometrically, $X\widehat\beta$ is the projection of $Y$ onto the column space of $X$. Numerically, QR decomposition or SVD is preferable to direct inversion, especially for correlated radiomic features.

When dealing with radiomic features, such as texture, shape, and intensity metrics extracted from medical images, we often encounter heavy multicollinearity (high correlation between features).

Using direct matrix inversion in these scenarios leads to severe numerical instability. Methods like QR Decomposition and Singular Value Decomposition (SVD) are preferred because they bypass the mathematical and computational pitfalls of direct inversion.

The Core Problem: (Direct Inversion & Ill-Conditioned Data) In linear models or feature transformations (e.g., least squares regression solving $X\beta = y$), direct inversion relies on calculating \[\beta = (X^T X)^{-1} X^T y.\] When radiomic features are highly correlated (i) Near-Singularity: Columns of the feature matrix $X$ are nearly linearly dependent, making $X^T X$ non-invertible or close to non-invertible; and (ii) Exploding Condition Number: The condition number $\kappa(X)$ measures how sensitive a matrix is to numerical noise.

The cross-product $X^T X$ squares the condition number \[\kappa(X^T X) = \kappa(X)^2.\] This leads to noise amplification. Inverting an ill-conditioned $X^T X$ magnifies tiny floating-point errors or image noise exponentially, causing coefficient estimates ($\beta$) to explode or fluctuate wildly.

QR decomposition is a better alternative, as it factors the feature matrix $X$ into an orthogonal matrix $Q$ and an upper triangular matrix $R$, $X = QR$.

The key advantage of QR is that it avoids $X^T X$ entirely. By working directly with $X$, QR avoids squaring the condition number. It also provides orthogonal stability, as $Q$ is orthogonal ($Q^T Q = I$), multiplying by $Q$ preserves vector lengths and does not amplify numerical floating-point errors.

This supports efficient back-substitution where the problem reduces to solving $R\beta = Q^T y$, which is solved cleanly via back-substitution without ever calculating a matrix inverse.

SVD is the factorizes the matrix $X$ into two orthogonal matrices $U$ and $V$, and a diagonal matrix $\Sigma$ containing the singular values ($\sigma_i$), $X = U \Sigma V^T$. Its advantage is exposing the small singular values. Highly correlated radiomic features show up as near-zero singular values ($\sigma_i \approx 0$) in $\Sigma$. This supports safe matrix pseudo-inversion, as direct inversion requires calculating $1/\sigma_i$. If $\sigma_i \approx 0$, $1/\sigma_i$, which explodes to infinity. SVD allows computing the Moore-Penrose pseudo-inverse, $X^+$, by zeroing out singular values below a chosen threshold \[\frac{1}{\sigma_i} \rightarrow 0 \quad \text{if } \sigma_i < \epsilon.\] Truncated SVD effectively acts as Principal Component Analysis (PCA), stripping out redundant, highly correlated feature dimensions while retaining the core signal.

2.4 Logistic regression and cross-entropy

For $Y_i\in\{0,1\}$,

\[ P(Y_i=1\mid x_i)=p_i=\sigma(x_i^{\mathsf T}\beta). \]

The Bernoulli likelihood is

\[ L(\beta)=\prod_i p_i^{y_i}(1-p_i)^{1-y_i}, \]

and negative log-likelihood is

\[ -\log L(\beta) =-\sum_i\left[y_i\log p_i+(1-y_i)\log(1-p_i)\right]. \]

A coefficient is a conditional log-odds change per unit predictor increase. It is not a causal effect without additional design assumptions.

Logistic growth is not logistic regression. Both use a sigmoid-shaped function, but logistic growth is a dynamical model for a bounded quantity, while logistic regression is a probability model for a binary outcome.

2.5 Regularization: ridge, lasso, and elastic net

Ridge uses $\Omega(\beta)=\lVert\beta\rVert_2^2$ and stabilizes correlated predictors. Lasso uses $\Omega(\beta)=\lVert\beta\rVert_1$ and can set coefficients exactly to zero. Elastic net combines both.

Regularization is part of fitting. Penalty strength must be selected inside resampling. Choosing $\lambda$ using the complete dataset and then reporting cross-validated performance leaks information.

2.6 Optimization and gradient descent

For differentiable risk $J(\theta)$,

\[ \theta^{(m+1)}= \theta^{(m)}-\alpha_m\nabla_{\theta}J\{\theta^{(m)}\}. \]

For a composition $f=f_L\circ\cdots\circ f_1$, backpropagation applies the chain rule:

\[ \frac{\partial f}{\partial\theta_{\ell}} = \frac{\partial f_L}{\partial h_{L-1}} \cdots \frac{\partial h_{\ell+1}}{\partial h_{\ell}} \frac{\partial h_{\ell}}{\partial\theta_{\ell}}. \]

2.7 Bias, variance, and irreducible noise

For squared-error prediction,

\[ \mathbb{E}\{(Y-\widehat f(x))^2\} = \sigma^2+ \operatorname{Bias}\{\widehat f(x)\}^2+ \operatorname{Var}\{\widehat f(x)\}. \]

set.seed(8)
true_f <- function(x) sin(2 * pi * x)
x_train_demo <- sort(runif(45))
y_train_demo <- true_f(x_train_demo) + rnorm(length(x_train_demo), sd = 0.30)
x_test_demo <- seq(0, 1, length.out = 400)
y_test_demo <- true_f(x_test_demo)

degrees <- 1:14
train_mse <- test_mse <- numeric(length(degrees))
for (j in seq_along(degrees)) {
  fit <- lm(y_train_demo ~ poly(x_train_demo, degree = degrees[j], raw = TRUE))
  train_mse[j] <- mean(residuals(fit)^2)
  pred <- predict(fit, newdata = data.frame(x_train_demo = x_test_demo))
  test_mse[j] <- mean((y_test_demo - pred)^2)
}
plot(degrees, train_mse, type = "b", pch = 16,
     xlab = "Polynomial degree", ylab = "Mean squared error",
     main = "Training error can fall while generalization error rises")
lines(degrees, test_mse, type = "b", pch = 1, lty = 2)
legend("topright", legend = c("training", "noise-free test grid"),
       lty = c(1, 2), pch = c(16, 1), bty = "n")

The total expected prediction error (Mean Squared Error) of a statistical model $\widehat{f}(x)$ at a specific point $x$ can be decomposed into three additive components

\[\mathbb{E}\left\{\left(Y-\widehat{f}(x)\right)^2\right\} = \sigma^2 + \operatorname{Bias}\left\{\widehat{f}(x)\right\}^2 + \operatorname{Var}\left\{\widehat{f}(x)\right\}\]

The bias squared \[\operatorname{Bias}\{\widehat f(x)\}^2 = \left(\mathbb{E}[\widehat{f}(x)] - f(x)\right)^2\] represents the systemic error introduced by approximating a real-world, complex relationship with a simplified model. High bias indicates underfitting.

The variance \[\operatorname{Var}\{\widehat f(x)\} = \mathbb{E}\left[\left(\widehat{f}(x) - \mathbb{E}[\widehat{f}(x)]\right)^2\right]\] is the amount by which the prediction $\widehat{f}(x)$ fluctuates if trained on a different dataset drawn from the same distribution. High variance indicates overfitting.

Finally, the irreducible noise $\sigma^2$ is the variance of the inherent noise in the target variable $Y = f(x) + \epsilon$ (where $\epsilon \sim \mathcal{N}(0, \sigma^2)$). It sets a fundamental lower bound on expected error that no model can overcome.

Trade-off Dynamics. The R simulation empirically demonstrates the Bias-Variance Trade-off using polynomial regression fits of increasing degrees ($d = 1$ to $14$) evaluated on a noisy sine wave $f(x) = \sin(2\pi x)$.

Low Complexity (Underfitting, e.g., $d = 1, 2$) goes with High Bias and Low Variance, as both training MSE and test MSE are high because a linear model cannot capture the non-linear curvature of the sine wave.

Optimal Complexity (e.g., $d \approx 3, 4$) reflects Balanced Bias and Variance, where Test MSE hits a global minimum near the optimal model capacity that closely mirrors the true generating process $f(x)$.

High Complexity (Overfitting, e.g., $d \ge 10$) corresponds to Low Bias and High Variance, as polynomial degree grows, the model overfits to the random Gaussian noise ($\sigma = 0.30$) in the small training sample ($N = 45$). The result is a training MSE that drops monotonically toward zero, while test MSE (generalization error) dramatically diverges upwards.

2.8 Bayes’ theorem, prevalence, and clinical interpretation

If prevalence is $\pi$, sensitivity $Se$, and specificity $Sp$,

\[ P(D\mid +)= \frac{Se\pi}{Se\pi+(1-Sp)(1-\pi)}. \]

ppv <- function(prevalence, sensitivity, specificity) {
  sensitivity * prevalence /
    (sensitivity * prevalence + (1 - specificity) * (1 - prevalence))
}
prev <- seq(0.005, 0.80, length.out = 300)
plot(prev, ppv(prev, 0.90, 0.85), type = "l", lwd = 2, ylim = c(0, 1),
     xlab = "Disease prevalence", ylab = "Positive predictive value",
     main = "Post-test probability depends on deployment prevalence")

We can apply the Bayes’ Theorem to diagnostic testing to convert a test’s fixed intrinsic characteristics (sensitivity and specificity) into a clinical decision-making metric (i) the Positive Predictive Value (PPV), $P(D \mid +)$ \[\text{PPV} = P(D \mid +) = \frac{Se \cdot \pi}{Se \cdot \pi + (1 - Sp)(1 - \pi)}\] Prior Probability ($\pi$) - suppose the disease prevalence in the target population before running the test is $P(D)$. The two likelihoods are

Sensitivity ($Se = P(+\mid D)$): True Positive Rate representing the probability of a positive test given the patient has the disease, and
Specificity ($Sp = P(-\mid \text{not } D)$): True Negative Rate is the complement, $(1 - Sp) = P(+\mid \text{not } D)$, and represents the False Positive Rate.

The Posterior Probability ($P(D \mid +)$) is the updated probability that a patient actually has the disease given a positive test result.

The clinical interpretation of the plot above shows PPV against disease prevalence ($\pi \in [0.005, 0.80]$) for a test with fixed $90\%$ sensitivity ($Se = 0.90$) and $85\%$ specificity ($Sp = 0.85$). It highlights a fundamental diagnostic reality that a test’s predictive power depends heavily on the context in which it is deployed.

When prevalence $\pi$ is low (e.g., $1\%$), even a reasonably accurate test yields a low PPV (around $5.7\%$), since the vast majority of the population is healthy. Therefore, the absolute number of false positives generated by the $(1 - Sp)$ rate heavily outnumbers the true positives generated by $Se$.
When prevalence is high (e.g., testing symptomatic patients in a high-risk cohort), PPV rises non-linearly toward $1.0$. At $50\%$ prevalence, the same test yields a PPV of $85.7\%$.
Thus, diagnostic test results cannot be interpreted in a vacuum. A positive result in a rare-disease screening environment requires confirmation via secondary testing to rule out false positives, whereas the exact same positive result in a high-risk clinical context carries strong diagnostic weight.

2.9 Measurement error and uncertainty propagation

Suppose $X^{\ast}=X+\delta$. Random measurement error can attenuate coefficients and destabilize feature selection. For differentiable $g(U)$,

\[ \operatorname{Var}\{g(U)\} \approx \nabla g(\mu_U)^{\mathsf T}\Sigma_U\nabla g(\mu_U). \]

For nonlinear pipelines or discrete masks, Monte Carlo perturbation is often more transparent: perturb plausible acquisition or segmentation inputs, recompute features and predictions, and summarize their distribution.

A model-coefficient confidence interval usually conditions on measured features as if they were exact. Robust imaging AI must also study voxel spacing, intensity calibration, ROI boundaries, and protocol variability.

In imaging and radiomics, observed variables ($X^*$) are rarely exact representations of the underlying biology ($X$). Instead, they are subject to additive random measurement noise ($\delta$)

\[X^* = X + \delta, \quad \mathbb{E}[\delta] = 0, \quad \operatorname{Var}(\delta) = \sigma^2_\delta\]

Attenuation Bias: In standard regression, classical measurement error in features shrinks estimated coefficients toward zero (attenuation), leading to an underestimation of effect sizes.
Feature Selection Instability: Small noise perturbations near decision boundaries cause algorithms like LASSO or step-wise selection to inconsistently select different sets of collinear radiomic features across repeated scans.Methods for Uncertainty Propagation.

When inputs ($U$) are subject to variation with covariance $\Sigma_U$, uncertainty propagates through downstream feature calculations or model predictions $g(U)$ via two main paradigms

Analytical Propagation: The Delta MethodFor smooth, differentiable pipelines $g(U)$, a first-order Taylor expansion around the mean vector $\mu_U$ provides a fast, analytical approximation of the output variance

\[\operatorname{Var}\{g(U)\} \approx \nabla g(\mu_U)^{\mathsf T}\Sigma_U\nabla g(\mu_U)\]

Gradient ($\nabla g(\mu_U)$): Represents the vector of partial derivatives of $g$ evaluated at the mean, scaling how strongly variance in each input dimension impacts the output. It fails for non-differentiable operations (e.g., discrete thresholding, binary segmentation masks, non-linear tree-based models).
Empirical Propagation (Monte Carlo Perturbation). When $g(U)$ is non-differentiable or mathematically intractable, Monte Carlo sampling empirically estimates output uncertainty. It samples $K$ realizations $U^{(k)} \sim \mathcal{P}(U)$ by injecting plausible domain-specific noise into raw acquisition inputs (e.g., jittering ROI boundaries, applying small intensity variations, re-sampling voxel grids). then, it passes each perturbed input through the full pipeline, $Y^{(k)} = g(U^{(k)})$ and computes empirical summary statistics (e.g., standard deviation, percentiles) over $\{Y^{(1)}, \dots, Y^{(K)}\}$ to construct robust prediction intervals.

While standard statistical models generate confidence intervals assuming feature values are fixed constants without error, in imaging AI, this assumption leads to overconfident predictions. Accounting for variability in voxel spacing, intensity calibration, and segmentation boundaries (ROIs), via Monte Carlo or delta method propagation, ensures that confidence intervals accurately reflect total system uncertainty and preventing models from failing when deployed across different scanners or clinical protocols.

2.10 Imaging noise models, likelihoods, SNR, and CNR

A Gaussian measurement model is

\[X=\mu+\epsilon, \qquad \epsilon\sim\mathcal{N}(0,\sigma^2).\]

(Poisson) emission counts are linked to

\[N\sim\mathrm{Poisson}(\lambda), \qquad \mathbb{E}(N)=\operatorname{Var}(N)=\lambda.\]

Magnitude MRI is classically approximated by Rician behavior, especially at low signal. Reconstruction and filtering create correlations and can alter these elementary distributions.

\[ \mathrm{SNR}=\frac{\mu_{\mathrm{signal}}}{\sigma_{\mathrm{noise}}}, \qquad \mathrm{CNR}=\frac{|\mu_1-\mu_2|}{\sigma_{\mathrm{noise}}}. \]

set.seed(18)
n_noise <- 5000
true_signal <- 25
gaussian_measurement <- true_signal + rnorm(n_noise, sd = 5)
poisson_measurement <- rpois(n_noise, lambda = true_signal)
complex_real <- true_signal + rnorm(n_noise, sd = 5)
complex_imag <- rnorm(n_noise, sd = 5)
rician_magnitude <- sqrt(complex_real^2 + complex_imag^2)
op <- par(mfrow = c(1, 3))
hist(gaussian_measurement, breaks = 40, main = "Gaussian model",
     xlab = "Measured value", probability = TRUE)
hist(poisson_measurement, breaks = 35, main = "Poisson counts",
     xlab = "Count", probability = TRUE)
hist(rician_magnitude, breaks = 40, main = "MRI magnitude model",
     xlab = "Magnitude", probability = TRUE)

par(op)

Noise augmentation should match plausible acquisition changes. Arbitrary independent Gaussian noise is not a universal robustness test.

Raw imaging data deviates significantly from standard independent and identically distributed (i.i.d.) Gaussian assumptions. The physics of image formation dictates the statistical distribution of noise in each modality, which directly governs the likelihood functions used in model training and reconstruction.

Fundamental Noise Models

Gaussian Model ($X \sim \mathcal{N}(\mu, \sigma^2)$): Approximates thermal and electronic amplifier noise in modalities like CT and standard optical imaging. Properties include symmetric and signal-independent (constant variance $\sigma^2$ regardless of signal mean $\mu$).
Poisson Model ($N \sim \mathrm{Poisson}(\lambda)$): Captures quantum shot noise in photon-counting modalities like PET, SPECT, and low-dose X-ray/CT. It’s properties include signal-dependent, where $\mathbb{E}(N) = \operatorname{Var}(N) = \lambda$. As photon counts drop, relative noise increases ($1/\sqrt{\lambda}$), breaking additive noise assumptions.
Rician Model: Arises in magnitude MRI, where raw complex $k$-space data with independent Gaussian noise in real and imaginary channels ($S_{\text{real}}, S_{\text{imag}}$) is converted into magnitude images: $M = \sqrt{S_{\text{real}}^2 + S_{\text{imag}}^2}$. At high signal-to-noise ratios, it approximates a Gaussian distribution. At low signal levels (near background), it becomes heavily skewed and non-zero-mean, introducing systematic intensity bias.

Image Quality Metrics (SNR and CNR) to quantify noise dynamics requires standardized signal metrics

\[\mathrm{SNR} = \frac{\mu_{\mathrm{signal}}}{\sigma_{\mathrm{noise}}}, \qquad \mathrm{CNR} = \frac{\vert{}\mu_1 - \mu_2\vert{}}{\sigma_{\mathrm{noise}}}\]

Signal-to-Noise Ratio (SNR): Measures baseline signal clarity relative to background noise variability ($\sigma_{\mathrm{noise}}$).
Contrast-to-Noise Ratio (CNR): Evaluates the statistical separability of two distinct tissue regions ($\mu_1$ and $\mu_2$), directly impacting downstream tasks like ROI segmentation and lesion detection.

The above R simulation of $5,000$ measurement realizations across all three noise regimes initialized at the same baseline signal level ($\mu = 25, \sigma = 5, \lambda = 25$):

Gaussian Plot: Shows a classic symmetric, bell-shaped distribution centered precisely at $25$.
Poisson Plot: Reflects discrete integer counts with signal-dependent variance.
Rician Magnitude Plot: Demonstrates right-skewness and an upward shift in mean intensity caused by taking the magnitude of complex Gaussian components.

Arbitrary independent Gaussian noise is not a universal robustness test. Image reconstruction pipelines, inverse fast Fourier transforms (iFFT), and spatial filtering introduce spatial noise correlations (colored noise). Evaluating or training vision AI using simple additive Gaussian noise ($I + \epsilon$) fails to simulate physics-grounded acquisition variability (such as low-photon PET regimes or low-field MRI magnitude bias), leading to unrealistic estimates of model robustness.

2.11 Basis expansions, transformations, and nonlinear relationships

A linear model can represent nonlinear dependence through a basis:

\[ f(x)=\beta_0+\beta_1x+\cdots+\beta_mx^m. \]

If $y=Ae^{bx}$, then $\log y=\log A+bx$. Polynomial terms, splines, interactions, logarithms, and physically motivated transformations can improve fit, but they change scale and error assumptions. Complexity must be tuned inside resampling, and extrapolation must remain physically plausible.

Try it yourself (Section 2). The bias-variance and prevalence demonstrations above use closed-form mathematics. Now anchor them in the real cohort. The malignancy prevalence in this surgical series is about 0.91. Using Bayes’ theorem, compute the positive predictive value of a test with sensitivity 0.80 and specificity 0.80 at that prevalence, and again at a screening prevalence of 0.10. Which quantity changed more, PPV or AUC? Explain why a paper reporting only AUC could mislead a clinician deciding whether to operate.

Hint:

Global Polynomials vs. Local Basis Expansions (Splines): A global polynomial, $f(x) = \sum \beta_j x^j$, a primary example of a basis expansion, suffer from Runge’s phenomenon (wild oscillations at domain boundaries) and non-local influence (a change in data on one end alters predictions everywhere). Consider contrasting global polynomials with splines (e.g., natural cubic splines or B-splines), which use localized piecewise polynomial bases separated by knots to enforce smoothness without catastrophic boundary behavior.
Impact of Log Transformations on Error Structure: The log transformations change scale and error assumptions but also the target variable ($Y$) shifts the model from an additive noise model to a multiplicative noise model

\[\log Y = \mathbf{X}\beta + \epsilon \quad \implies \quad \\ Y = e^{\mathbf{X}\beta} \cdot e^\epsilon, \quad \epsilon \sim \mathcal{N}(0, \sigma^2).\]

Exponentiating predictions back to the original scale introduces a bias in the mean estimation because $\mathbb{E}[e^\epsilon] = e^{\sigma^2 / 2} \neq 1$. Re-scaling requires a variance correction factor

\[\widehat{Y}_{\text{mean}} = e^{\mathbf{X}\widehat{\beta}} \cdot e^{\sigma^2/2}.\]

Data Leakage in Basis Tuning: Complexity must be tuned inside resampling is a critical rule. Selecting spline knot locations, polynomial degrees, or power transformations (e.g., Box-Cox $\lambda$) using the full dataset causes data leakage, results in overly optimistic cross-validation performance. These hyperparameter selection steps must be nested entirely within each training fold.

This mathematical hint offers ideas on how to address the above calculation. For a test with $Se = 0.80$ and $Sp = 0.80$:Surgical Series Cohort ($\pi = 0.91$)

\[\text{PPV} = \frac{0.80 \times 0.91}{(0.80 \times 0.91) + (1 - 0.80)(1 - 0.91)} = \frac{0.728}{0.728 + 0.018} \approx \mathbf{97.6\%}\] Screening Cohort ($\pi = 0.10$)

\[\text{PPV} = \frac{0.80 \times 0.10}{(0.80 \times 0.10) + (1 - 0.80)(1 - 0.10)} = \frac{0.080}{0.080 + 0.180} \approx \mathbf{30.8\%}\] Why reporting only AUC misleads clinicians? Metric:

Metric	High Prevalence ($\pi = 0.91$)	Low Prevalence ($\pi = 0.10$)	Shift
PPV	97.6%	30.8%	-66.8%
AUC	Unchanged	Unchanged	0%

Which changed more? PPV changed dramatically (dropping by over $66\%$), whereas AUC did not change at all. Why AUC is misleading? The Area Under the ROC Curve (AUC) is calculated directly from Sensitivity ($Se$) and Specificity ($Sp$), making it mathematically prevalence-invariant. The clinical impact is that a high AUC (e.g., $0.88$) calculated in a high-risk surgical series ($\pi = 0.91$) implies excellent discrimination. However, if a surgeon uses that model in a low-prevalence screening population ($\pi = 0.10$), a positive test result drops from a $97.6\%$ probability of malignancy down to $30.8\%$. Reporting only AUC hides this collapse, risking unnecessary invasive surgeries on false-positive patients.

3. Study Design Before Model Fitting

A biomedical AI study should be designed backward from its intended use rather than forward from an available data set. Here is a basic guiding principle

In [target population], at [decision time], use [available predictors] to estimate [target] over [time horizon] in order to support [clinical or scientific action].

For the running example in this chapter, one possible specification is:

In adults undergoing evaluation of a renal mass, use preoperative contrast-enhanced CT and routinely available clinical variables to estimate malignant pathology before surgery, thereby supporting inter-professional clinical-care planning and patient counseling.

This sentence fixes the population, time origin, permissible inputs, outcome, and proposed use. It also immediately rules out postoperative pathology variables from a preoperative prediction model.

The SOCR Comprehensive Power Analysis Guide provides additional technical details on how to design a reliable protocol of a falsifiable research study.

3.1 Define the estimand, target population, and unit of analysis

The prediction target is not merely a column name. It includes the outcome definition, measurement procedure, time horizon, and population. Let $D$ denote the development distribution and $T$ the deployment distribution. The quantity of practical interest is often

\[ R_T(f)=\mathbb{E}_{(X,Y)\sim T}\{L[Y,f(X)]\}, \]

whereas ordinary training minimizes an estimate of $R_D(f)$. A model can perform well under $D$ and fail under $T$ if scanners, sites, prevalence, patient mix, annotation practice, or workflow changes.

The unit of analysis must match the independent sampling unit:

Data structure	Natural unit for splitting	Why
One scan per patient	Patient	Prevents the same person from entering multiple partitions
Multiple scans per patient	Patient	Longitudinal images are strongly dependent
Multiple lesions per patient	Patient, sometimes with lesion-level modeling	Lesions share biology and acquisition
Multiple slices or patches per volume	Patient or volume	Slice-level splitting produces severe leakage
Multiple sites	Site-aware patient split	Needed to assess geographic and technical transportability
Repeated readers	Patient plus reader-aware analysis	Predictions and labels may be reader-correlated

A slice-level sample size of $100,000$ does not imply $100,000$ independent observations if those slices came from 200 patients. The effective sample size is governed by the highest-level independent unit and the intraclass correlation (ICC).

3.2 Outcome and reference-standard design

The reference standard should be defined before inspecting model results. Examples of clinically-relevant outcomes include surgical pathology, biopsy, expert consensus, longitudinal clinical adjudication, or a quantitative laboratory measurement. Each has error. If the observed label $Y$ is a noisy version of a latent state $Y^\ast$, then

\[ P(Y\neq Y^\ast)>0, \]

and measured model performance is bounded by label quality. Differential label error is particularly dangerous: pathology may be available preferentially in suspicious lesions, and long-term follow-up may be incomplete in low-risk patients.

A rigorous protocol records:

who established the label and whether they were blinded to model inputs;
the time interval between imaging and reference measurement;
how indeterminate cases were handled;
inter-reader or inter-rater reliability when labels are subjective;
whether the same information appears in both predictors and the label definition.

For segmentation, the reference is a spatial object rather than a scalar. Consensus masks, multiple annotators, and uncertainty bands may be more honest than a single supposedly exact boundary.

3.3 Missing data and informative observation

Let $R_j=1$ indicate that feature $X_j$ is observed. Classical mechanisms are:

MCAR (missing completely at random): $R_j\perp (X,Y)$;
MAR (missing at random): $R_j\perp X_j\mid X_{-j},Y$;
MNAR (missing not at random): missingness still depends on the unobserved value after conditioning.

Complete-case analysis is generally valid only under restrictive conditions. Mean imputation performed before splitting is also invalid because it leaks test-distribution information. A defensible workflow fits imputation parameters on each training resample and applies them without refitting to its validation fold.

Missingness itself may be informative. For instance, an advanced imaging sequence may be omitted because a patient cannot tolerate a long examination. Missingness indicators can improve prediction, but they may encode local workflow rather than biology and therefore require transportability testing.

Caution: absence is not a biological zero. A missing laboratory value, an unperformed sequence, and a measured value of zero are different states. Preserve that distinction in both data dictionaries and code.

DSPA Chapter 2 provides technical detals and examples of missing data and imputation strategies.

3.4 Censoring, truncation, and competing events

For prognosis, let $T$ be event time and $C$ censoring time. We observe

\[ \widetilde T=\min(T,C), \qquad \delta=\mathbb{I}(T\le C). \]

A binary variable such as vital_status discards follow-up duration and usually treats censored patients incorrectly. Kaplan–Meier, Cox, parametric survival, competing-risk, or other time-to-event models should be used when follow-up is incomplete. Their assumptions must also be examined: standard methods commonly require independent censoring conditional on modeled covariates.

Left truncation arises when participants enter a risk set after the biological time origin. Competing events arise when one event changes or prevents the occurrence of another. For example, non-cancer death can compete with recurrence. The target must distinguish cause-specific hazard, subdistribution risk, and all-cause event probability.

The Non-Informative / Independent Censoring Assumption. Standard methods require independent censoring conditional on modeled covariates. The mathematical assumption is that $T \perp C \mid \mathbf{X}$. If censoring is informative (e.g., patients drop out because their disease is worsening), standard Cox models or Kaplan–Meier estimators suffer from dependent censoring bias, systematically overestimating survival probabilities. Inverse probability of censoring weighting (IPCW) or joint modeling of longitudinal and survival data resolve these issues.

Left Truncation vs. Left Censoring (Immortal Time Bias): The main clinical consequence of left truncation is immortal time bias. Left truncation means an individual is observed only if $T_i > V_i$, where $V_i$ is entry time. Ignoring left truncation,i.e., setting entry time to $0$, creates immortal time bias because subjects who die before entering the cohort are never observed. The risk sets must be adjusted to exclude individuals until $V_i$

\[Y_i(t) = \mathbb{I}(V_i < t \le \widetilde{T}_i).\]

Cause-Specific vs. Subdistribution Hazard: There is a difference between cause-specific hazard and subdistribution risk.

Cause-Specific Cox Model: Measures the instantaneous rate of the event among those still event-free \[\lambda_k(t) = \lim_{\Delta t \to 0} \frac{P(t \le T < t + \Delta t, D = k \mid T \ge t)}{\Delta t}.\] It’s best used for Etiological research / causal inference.
Fine-Gray Model (Subdistribution Hazard / CIF): Evaluates the Cumulative Incidence Function, keeping individuals who experienced competing events in the risk set \[\gamma_k(t) = \lim_{\Delta t \to 0} \frac{P(t \le T < t + \Delta t, D = k \mid T > t \cup (T \le t \cap D \neq k))}{\Delta t}\] Best used for: Clinical prognosis, risk prediction, and resource planning.

Using Complement of Kaplan–Meier ($1 - KM$) with Competing Risks: Researchers frequently use $1 - \text{KM}$ to estimate event rates when competing events exist. Using $1 - \text{KM}$ in the presence of competing events treats competing risks as ordinary censoring may overestimate the true event probability (often substantially). The Cumulative Incidence Function (CIF) estimator must be used instead.

Censoring, Truncation, and Competing Events: For prognostic modeling, let $T$ be the true event time and $C$ the censoring time. We observe the time $\widetilde T = \min(T,C)$ and event indicator $\delta = \mathbb{I}(T \le C)$.Converting time-to-event outcomes into binary endpoints (e.g., vital_status at 5 years) discards variable follow-up durations and misclassifies patients censored before the time threshold. Standard survival methods (Kaplan–Meier, Cox proportional hazards) account for incomplete follow-up but rely on conditionally independent censoring ($T \perp C \mid \mathbf{X}$). When censoring is informative (e.g., dropouts tied to disease progression), predictions suffer from selective attrition bias.

Left truncation (delayed entry) occurs when participants enter the observation period at entry time $V_i > 0$ after the biological origin (e.g., diagnosis). Naively resetting origin times to zero introduces immortal time bias; risk sets $Y_i(t) = \mathbb{I}(V_i < t \le \widetilde{T}_i)$ must be restricted to patients actively at risk at time $t$.Competing events ($D \in \{1, 2, \dots, K\}$) prevent the primary event of interest from occurring (e.g., non-cancer death before recurrence). In their presence, Naive $1 - \text{Kaplan-Meier}$ curves treat competing events as ordinary uninformative censoring, overestimating event risk. Cause-specific hazard models evaluate disease etiology among event-free individuals. Fine–Gray subdistribution hazard models (or direct Cumulative Incidence Functions) retain competing event subjects in the risk set, making them necessary for accurate individual clinical prognosis and risk prediction.

3.5 Development, tuning, internal testing, and external testing

A strong design gives each data partition one role:

Partition	Permitted role	Forbidden role
Training folds	Fit model and preprocessing	Final performance claim
Validation/tuning folds	Select hyperparameters and thresholds	Repeatedly redesign study until favorable
Locked internal test	One-time assessment under the development setting	Feature selection or calibration fitting
External test	Assess a meaningfully different site/time/scanner/population	Any model revision followed by calling it untouched

For small data sets, nested cross-validation can replace a fixed tuning split. The outer loop estimates generalization, while the inner loop chooses hyperparameters. Repeated cross-validation measures resampling variability, but it does not manufacture new independent patients.

# 1. Helper functions for data partitioning
stratified_split <- function(y, proportion = 0.75, seed = 8) {
  stopifnot(length(y) >= 2, proportion > 0, proportion < 1)
  set.seed(seed)
  y_chr <- as.character(y)
  train <- unlist(lapply(split(seq_along(y_chr), y_chr), function(idx) {
    if (length(idx) == 1) return(idx)
    n_take <- min(length(idx) - 1, max(1, floor(proportion * length(idx))))
    sample(idx, n_take)
  }), use.names = FALSE)
  train <- sort(unique(train))
  list(train = train, test = setdiff(seq_along(y_chr), train))
}

make_stratified_folds <- function(y, v = 5, seed = 8) {
  stopifnot(v >= 2)
  set.seed(seed)
  y_chr <- as.character(y)
  fold_id <- integer(length(y_chr))
  for (lev in unique(y_chr)) {
    idx <- sample(which(y_chr == lev))
    fold_id[idx] <- rep(seq_len(v), length.out = length(idx))
  }
  fold_id
}

grouped_folds <- function(group, v = 5, seed = 8) {
  stopifnot(v >= 2)
  set.seed(seed)
  groups <- sample(unique(as.character(group)))
  group_fold <- setNames(rep(seq_len(v), length.out = length(groups)), groups)
  unname(group_fold[as.character(group)])
}

# 2. Simulation: Demonstrating Data Leakage vs. Strict Partitioning
set.seed(42)

# Generate synthetic radiomic dataset (N = 100, P = 500 noise features, true signal = FALSE)
N <- 100
P <- 500
X <- matrix(rnorm(N * P), nrow = N, ncol = P)
y <- factor(rbinom(N, size = 1, prob = 0.5))

# --- Scenario A: Leaky Tuning (Feature selection on ALL data prior to CV) ---
top_features_leaky <- order(apply(X, 2, 
                      function(col) abs(cor(col, as.numeric(y)))), decreasing = TRUE)
X_leaky <- X[, top_features_leaky]

outer_folds <- make_stratified_folds(y, v = 5, seed = 8)
acc_leaky <- numeric(5)

for (k in 1:5) {
  train_idx <- which(outer_folds != k)
  test_idx  <- which(outer_folds == k)
  
  # fit <- glm(y ~ ., data = data.frame(y = y[train_idx], X_leaky[train_idx, ]), family = "binomial")
  # preds <- predict(fit, newdata = data.frame(X_leaky[test_idx, ]), type = "response") > 0.5
  # acc_leaky[k] <- mean(preds == y[test_idx])

  # Ensure y is numeric 0 and 1 rather than a factor
  y_num <- as.numeric(as.character(y)) 
  
  # --- Corrected Evaluation inside the loop ---
  # 1. Fit GLM on numeric y
  fit <- glm(y_num ~ ., data = data.frame(y_num = y_num[train_idx], 
                                          X_leaky[train_idx, ]), family = "binomial")
  
  # 2. Compare predicted probabilities directly to numeric binary target
  preds <- as.numeric(predict(fit, newdata = data.frame(X_leaky[test_idx, ]), type = "response") > 0.5)
  acc_leaky[k] <- mean(preds == y_num[test_idx])
}

# --- Scenario B: Strict Nested CV (Feature selection strictly INSIDE training folds) ---
acc_nested <- numeric(5)

for (k in 1:5) {
  train_idx <- which(outer_folds != k)
  test_idx  <- which(outer_folds == k)
  
  # Feature selection strictly on training fold
  X_train <- X[train_idx, ]
  y_train <- y[train_idx]
  
  top_features_strict <- 
    order(apply(X_train, 2, function(col) abs(cor(col, as.numeric(y_train)))),
          decreasing = TRUE)
  
  # fit <- glm(y ~ ., data = data.frame(y = y_train, X_train[, top_features_strict]), family = "binomial")
  # preds <- predict(fit, newdata = data.frame(X[test_idx, top_features_strict]), type = "response") > 0.5
  # acc_nested[k] <- mean(preds == y[test_idx])
  
  # Ensure y is numeric 0 and 1 rather than a factor
  y_num <- as.numeric(as.character(y)) 
  
  # --- Corrected Evaluation inside the loop ---
  # 1. Fit GLM on numeric y
  fit <- glm(y_num ~ ., data = data.frame(y_num = y_num[train_idx], 
                                          X_leaky[train_idx, ]), family = "binomial")
  
  # 2. Compare predicted probabilities directly to numeric binary target
  preds <- as.numeric(predict(fit, newdata = data.frame(X_leaky[test_idx, ]), 
                              type = "response") > 0.5)
  acc_nested[k] <- mean(preds == y_num[test_idx])
}

# 3. Output Table Generation
results <- data.frame(
  Evaluation_Strategy = c("Leaky Preprocessing (Flawed)", "Nested CV (Strict Partitioning)", "True Noise Expectation"),
  Mean_Accuracy = c(mean(acc_leaky), mean(acc_nested), 0.50),
  Standard_Error = c(sd(acc_leaky)/sqrt(5), sd(acc_nested)/sqrt(5), 0.00)
)

knitr::kable(results, digits = 3, caption = "Simulation Results: Impact of Data Leakage vs. Strict Partitioning")

Table 1: Simulation Results: Impact of Data Leakage vs. Strict Partitioning
Evaluation_Strategy	Mean_Accuracy	Standard_Error
Leaky Preprocessing (Flawed)	0.57	0.051
Nested CV (Strict Partitioning)	0.57	0.051
True Noise Expectation	0.50	0.000

Data Leakage Overestimates Performance: In Scenario A (Leaky), performing feature selection across the entire dataset before cross-validation produces an artificially inflated mean accuracy (often $\approx 70–80\%$), despite the dataset containing pure random noise ($y \perp X$). This occurs because the validation folds leak information into the feature selection step.

Nested Cross-Validation Restores Ground Truth: In Scenario B (Nested CV), performing feature selection strictly inside each outer training fold correctly collapses the performance back to chance accuracy ($\approx 50\%$).

Methodological Imperative: To establish credible clinical utility, hyperparameter tuning, feature selection, and transformation scaling must be isolated inside the training folds or locked internal test sets—never applied globally prior to splitting.

3.6 Leakage: a pipeline property, not only a variable property

Data leakage occurs when information unavailable at the intended prediction time influences model fitting or evaluation. It can enter through preprocessing, feature extraction, labels, grouping, or workflow artifacts.

Leakage route	Example	Repair
Patient overlap	Different slices from one scan in train and test	Split by patient before patch generation
Temporal leakage	Future scan predicts an earlier event	Freeze the landmark time and feature window
Target leakage	Postoperative pathology predicts preoperative pathology	Enforce a prediction-time data dictionary
Preprocessing leakage	Scale/PCA/impute using the full cohort	Fit each operation only on training data
Feature-selection leakage	Rank features using all outcomes	Repeat selection inside each resample
Augmentation leakage	Augmented copies cross partitions	Split original patients first
Site proxy leakage	Burned-in text or scanner border identifies site	Remove artifacts and perform site-held-out tests
Duplicate leakage	Same public image appears under two identifiers	Hash files and inspect near duplicates
Annotation leakage	Mask created with knowledge of the outcome	Blind annotators or model the process explicitly

A useful audit question is: Could this value, transformation, or decision have been known for a genuinely new patient at the intended prediction time? If not, it cannot enter the model.

3.7 Sample size, events, dimensionality, and learning curves

There is no universal patients-per-feature rule. Required sample size depends on outcome prevalence, event count, model flexibility, signal strength, label noise, and desired precision. Nevertheless, several principles are robust:

the number of independent patients matters more than the number of voxels;
effective degrees of freedom should be small relative to available information;
survival models are constrained by the number of observed events, not only cohort size;
external validation must contain enough positive and negative cases to estimate clinically important metrics precisely;
learning curves can reveal whether performance is data-limited or representation-limited.

For an estimated proportion $\widehat p$ based on $m$ independent test cases, a rough standard error is

\[\operatorname{SE}(\widehat p)\approx \sqrt{\frac{\widehat p(1-\widehat p)}{m}},\]

but sensitivity, specificity, and predictive values use different denominators. A confidence interval based on ten positive cases is necessarily unstable, even when total sample size appears respectable.

Checkpoint (Section 3). Before any code runs, write down – in one sentence each – the estimand, the unit of analysis, the prediction time point, and the reference standard for the malignancy question in this chapter. Then list two variables in the KiTS record that you must not use as predictors, and say precisely why. (Answers appear implicitly in Section 4.2, but test yourself honestly.)

For a deeper exploration of sample-size estimation, see the SOCR Comprehensive Power Analysis Guide.

4. Running Case Study: Kidney Tumor CT, Clinical Data, and Outcomes

We will use a kidney imaging and clinical data set: real clinical metadata, real NIfTI reference segmentations, morphometry computed from those masks, dependence modeling, and survival analysis. Every table in this section is built from the released KiTS19 records, so the sample sizes, missingness, class balance, and effect sizes are the ones an investigator would actually face.

Clinical question. Can preoperative contrast-enhanced CT phenotype and routine clinical information estimate malignant pathology, quantify tumor burden, and support prognosis without conflating prediction time points?

4.1 Kidney CT Overview

Renal-mass analysis connects nearly every BPAD2 theme:

CT acquisition and Hounsfield-unit calibration;
3D geometry, voxel spacing, partial-volume effects, and resampling;
organ and tumor segmentation;
first-order, shape, and texture radiomics;
preoperative classification;
postoperative renal-function regression;
censored survival outcomes;
longitudinal growth and treatment decisions;
multi-site technical shift.

The public Kidney Tumor Segmentation Challenge data are CT data. KiTS19 contains 300 cases in its challenge cohort, with 210 publicly released training cases and 90 held-out test cases. Later KiTS releases are distinct cohorts and should not be silently concatenated. A real analysis must document the release, inclusion criteria, labels, license, and train/test restrictions.

4.2 Case-level data dictionary

The table below maps the actual fields in the released record onto the analysis names used in this chapter, together with the moment each becomes available. Availability, not convenience, decides what a model may use.

Domain	Released field	Analysis name	Available
Demographic	`age_at_nephrectomy`, `gender`, `body_mass_index`, `smoking_history`	same	Preoperative
Baseline renal function	`last_preop_egfr.value`, `comorbidities.chronic_kidney_disease`	`preop_egfr`, `chronic_kidney_disease`	Preoperative
Radiographic	`radiographic_size`	`radiographic_size_cm`	Preoperative CT
Imaging-derived	computed from `segmentation.nii.gz`	`tumor_volume_cm3`, `tumor_surface_cm2`, `tumor_sphericity`, …	Preoperative CT
Technical	`voxel_spacing.{x,y,z}_spacing`	`voxel_spacing_*_mm`, `acq_group`	At acquisition
Operative	`surgery_type`, `surgical_procedure`, `operative_time`, `estimated_blood_loss`, `ischemia_time`	`surgical_approach`, `surgery_type`, `operative_time_min`, `blood_loss_ml`	Intra-/postoperative
Pathologic	`malignant`, `pathology_t_stage`, `tumor_isup_grade`, `tumor_histologic_subtype`, `pathologic_size`	`malignancy_label`, …	Postoperative reference standard
Follow-up	`last_postop_egfr.value`, `vital_status`, `vital_days_after_surgery`	`postoperative_egfr`, `event_observed`, `followup_days`	Longitudinal

Two naming conventions are worth stating explicitly, because they are easy to get backwards. In the released record, surgery_type describes the access route (open, laparoscopic, robotic) while surgical_procedure describes the extent of resection (partial or radical nephrectomy). This chapter maps them to surgical_approach and surgery_type respectively, matching the usual clinical usage. Anyone joining these tables to another source must check this rather than assume it.

A preoperative malignancy model may use the first five rows only. Operative, pathologic, and follow-up variables are recorded after the prediction moment, so including them – even inadvertently, through a derived feature – is leakage rather than signal.

4.3 Loading the real KiTS19 cohort

## ---------------------------------------------------------------------------
## REAL DATA: the 210 publicly released KiTS19 training cases.
## Source: https://github.com/neheller/kits19  (data/kits.json)
## No authentication, no license click-through, ~0.5 MB.
## ---------------------------------------------------------------------------
KITS_METADATA_URL <-
  "https://raw.githubusercontent.com/neheller/kits19/master/data/kits.json"

## --- helpers that preserve real-world measurement pathologies -------------
## eGFR is reported by the laboratory as a number, as the *truncated* string
## ">=90" (values above the reportable range), or as "age<16" (not estimable).
## Silently coercing with as.numeric() would destroy this information.
egfr_value <- function(x) {
  if (is.null(x)) return(NA_real_)
  if (is.numeric(x)) return(as.numeric(x))
  if (is.character(x) && grepl("^>=", x)) return(as.numeric(sub("^>=", "", x)))
  NA_real_
}
egfr_is_truncated <- function(x) is.character(x) && grepl("^>=", x)
## Some numeric fields carry SEMANTIC string sentinels rather than numbers:
##   ischemia_time   = "not_applicable"        (no vascular clamping performed)
##   hospitalization = "died_before_discharge" (length of stay is undefined)
## Blind as.numeric() would turn both into NA and silently discard the meaning.
num_or_na <- function(x) {
  if (is.null(x)) return(NA_real_)
  if (is.numeric(x)) return(as.numeric(x))
  if (is.character(x)) {
    v <- suppressWarnings(as.numeric(x))   # numbers stored as strings parse here
    return(v)                              # true sentinels become NA, but are
  }                                        # flagged separately below
  NA_real_
}
sentinel_of <- function(x) if (is.character(x) &&
                               is.na(suppressWarnings(as.numeric(x)))) x else NA_character_
chr_or_na <- function(x) if (is.null(x)) NA_character_ else as.character(x)
lgl_or_na <- function(x) if (is.null(x)) NA else as.logical(x)

load_kits_cohort <- function() {
  path <- bpad_fetch(KITS_METADATA_URL, "kits.json", binary = FALSE)
  if (is.na(path) || !has_pkg("jsonlite")) return(NULL)
  raw <- try(jsonlite::fromJSON(path, simplifyDataFrame = FALSE), silent = TRUE)
  if (inherits(raw, "try-error")) return(NULL)

  do.call(rbind, lapply(raw, function(r) data.frame(
    case_id                = chr_or_na(r$case_id),
    age_at_nephrectomy     = num_or_na(r$age_at_nephrectomy),
    gender                 = chr_or_na(r$gender),
    body_mass_index        = num_or_na(r$body_mass_index),
    smoking_history        = chr_or_na(r$smoking_history),
    pack_years             = num_or_na(r$pack_years),
    alcohol_use            = chr_or_na(r$alcohol_use),
    chronic_kidney_disease = lgl_or_na(r$comorbidities$chronic_kidney_disease),
    diabetes_mellitus      = lgl_or_na(r$comorbidities$uncomplicated_diabetes_mellitus),
    hospitalization_days   = num_or_na(r$hospitalization),
    hospitalization_note   = sentinel_of(r$hospitalization),
    ischemia_time_min      = num_or_na(r$ischemia_time),
    ischemia_note          = sentinel_of(r$ischemia_time),
    radiographic_size_cm   = num_or_na(r$radiographic_size),
    pathologic_size_cm     = num_or_na(r$pathologic_size),
    malignant              = lgl_or_na(r$malignant),
    pathology_t_stage      = chr_or_na(r$pathology_t_stage),
    pathology_m_stage      = chr_or_na(r$pathology_m_stage),
    histologic_subtype     = chr_or_na(r$tumor_histologic_subtype),
    tumor_necrosis         = lgl_or_na(r$tumor_necrosis),
    tumor_isup_grade       = num_or_na(r$tumor_isup_grade),
    blood_loss_ml          = num_or_na(r$estimated_blood_loss),
    operative_approach_raw = chr_or_na(r$surgery_type),
    surgical_procedure_raw = chr_or_na(r$surgical_procedure),
    operative_time_min     = num_or_na(r$operative_time),
    positive_margins       = lgl_or_na(r$positive_resection_margins),
    preop_egfr             = egfr_value(r$last_preop_egfr$value),
    preop_egfr_truncated   = egfr_is_truncated(r$last_preop_egfr$value),
    postoperative_egfr     = egfr_value(r$last_postop_egfr$value),
    postop_egfr_truncated  = egfr_is_truncated(r$last_postop_egfr$value),
    vital_status_raw       = chr_or_na(r$vital_status),
    followup_days          = num_or_na(r$vital_days_after_surgery),
    voxel_spacing_x_mm     = num_or_na(r$voxel_spacing$x_spacing),
    voxel_spacing_y_mm     = num_or_na(r$voxel_spacing$y_spacing),
    voxel_spacing_z_mm     = num_or_na(r$voxel_spacing$z_spacing),
    stringsAsFactors       = FALSE
  )))
}

kidney <- load_kits_cohort()

if (is.null(kidney)) {
  stop(
    "The real KiTS19 metadata could not be retrieved.\n",
    "  * check network access, or\n",
    "  * download data/kits.json from https://github.com/neheller/kits19 and place it in\n",
    "    ", bpad_cache_dir, "\n",
    "  * the 'jsonlite' package is required to parse it.\n",
    "This chapter is deliberately built on real data. Alternatively, synthetic substitute data may also be used."
  )
}

## --- derived analysis variables (explicit, documented, reversible) --------
kidney$malignancy_label <- factor(
  ifelse(kidney$malignant, "malignant", "benign"),
  levels = c("benign", "malignant")
)
## KiTS records `vital_status` as "censored" or "dead": a right-censored outcome.
kidney$event_observed <- as.integer(kidney$vital_status_raw == "dead")
kidney$vital_status   <- factor(kidney$vital_status_raw,
                                levels = c("censored", "dead"))
## Surgical extent (parenchyma removed) vs. operative access route.
kidney$surgery_type <- factor(
  ifelse(kidney$surgical_procedure_raw == "radical_nephrectomy",
         "radical", "partial"),
  levels = c("partial", "radical")
)
kidney$surgical_approach <- factor(
  ifelse(kidney$operative_approach_raw == "open", "open", "minimally_invasive"),
  levels = c("minimally_invasive", "open")
)
kidney$gender          <- factor(kidney$gender)
kidney$smoking_history <- factor(kidney$smoking_history,
  levels = c("never_smoked", "previous_smoker", "current_smoker"))
kidney$chronic_kidney_disease <- factor(
  ifelse(kidney$chronic_kidney_disease, "yes", "no"), levels = c("no", "yes"))
kidney$egfr_decline <- kidney$preop_egfr - kidney$postoperative_egfr

## Real acquisition heterogeneity: KiTS slice thickness spans 0.5-5.0 mm.
## This is a genuine, documented technical stratum -- not an invented "site".
kidney$acq_group <- factor(
  ifelse(kidney$voxel_spacing_z_mm <= 1, "thin_slice", "thick_slice"),
  levels = c("thin_slice", "thick_slice")
)

cat("Real KiTS19 cases loaded:", nrow(kidney), "\n\n")

## Real KiTS19 cases loaded: 210

str(kidney[, c("case_id", "age_at_nephrectomy", "radiographic_size_cm",
               "malignancy_label", "followup_days", "event_observed",
               "voxel_spacing_z_mm", "acq_group")])

## 'data.frame':    210 obs. of  8 variables:
##  $ case_id             : chr  "case_00000" "case_00001" "case_00002" "case_00003" ...
##  $ age_at_nephrectomy  : num  49 50 74 44 73 35 69 59 68 73 ...
##  $ radiographic_size_cm: num  2.4 2.2 4.5 3 3 4.9 3 3.8 10.6 2.7 ...
##  $ malignancy_label    : Factor w/ 2 levels "benign","malignant": 2 2 2 2 2 2 2 2 2 2 ...
##  $ followup_days       : num  1420 1401 1185 114 500 ...
##  $ event_observed      : int  0 0 0 0 0 0 0 0 0 0 ...
##  $ voxel_spacing_z_mm  : num  0.5 0.5 1 1 4 0.5 3 3 3 3 ...
##  $ acq_group           : Factor w/ 2 levels "thin_slice","thick_slice": 1 1 1 1 2 1 2 2 2 2 ...

This cohort represents real data, not a simulation. Every number traces to a released clinical record, and the awkward parts are included, rather than smoothed away.

real_snapshot <- list(
  n_cases            = nrow(kidney),
  malignant_n        = sum(kidney$malignant),
  benign_n           = sum(!kidney$malignant),
  prevalence         = round(mean(kidney$malignant), 3),
  deaths_observed    = sum(kidney$event_observed),
  censored           = sum(kidney$event_observed == 0),
  median_followup_d  = median(kidney$followup_days),
  slice_mm_range     = paste(range(kidney$voxel_spacing_z_mm), collapse = " - "),
  egfr_truncated_pre = sum(kidney$preop_egfr_truncated),
  age_range          = paste(range(kidney$age_at_nephrectomy), collapse = " - ")
)
data.frame(quantity = names(real_snapshot),
           value = unlist(lapply(real_snapshot, as.character)),
           row.names = NULL)

##              quantity   value
## 1             n_cases     210
## 2         malignant_n     192
## 3            benign_n      18
## 4          prevalence   0.914
## 5     deaths_observed      21
## 6            censored     189
## 7   median_followup_d   790.5
## 8      slice_mm_range 0.5 - 5
## 9  egfr_truncated_pre      33
## 10          age_range  1 - 90

Read those numbers before modeling. Only 18 of 210 resected masses are benign, and only 21 deaths are observed. The chapter’s later results are modest because the data are real: a surgical cohort is already filtered by the decision to operate, so “predict malignancy” is a much harder and much rarer-outcome problem here than balanced textbook examples suggest.

These are real patient records released for research use. They are not a benchmark of population epidemiology. The cohort is a consecutive surgical series from two centers, so every rate reported here is conditional on a decision to operate having already been made.

4.4 Data-quality control (QC)

kidney_qc <- data.frame(
  check = c(
    "unique case identifiers",
    "case count matches the released KiTS19 training cohort",
    "positive radiographic sizes",
    "event indicator is 0/1",
    "non-negative follow-up",
    "positive voxel spacing",
    "adult ages only (deliberately expected to FAIL)"
  ),
  passed = c(
    !anyDuplicated(kidney$case_id),
    nrow(kidney) == 210L,
    all(kidney$radiographic_size_cm > 0, na.rm = TRUE),
    all(kidney$event_observed %in% c(0, 1)),
    all(kidney$followup_days >= 0, na.rm = TRUE),
    all(kidney$voxel_spacing_x_mm > 0 & kidney$voxel_spacing_z_mm > 0, na.rm = TRUE),
    all(kidney$age_at_nephrectomy >= 18, na.rm = TRUE)
  )
)
kidney_qc

##                                                    check passed
## 1                                unique case identifiers   TRUE
## 2 case count matches the released KiTS19 training cohort   TRUE
## 3                            positive radiographic sizes   TRUE
## 4                                 event indicator is 0/1   TRUE
## 5                                 non-negative follow-up   TRUE
## 6                                 positive voxel spacing   TRUE
## 7        adult ages only (deliberately expected to FAIL)  FALSE

## Assertions should protect the analysis, not decorate it. Here we require the
## structural checks and deliberately let the age check report a real finding.
stopifnot(all(kidney_qc$passed[1:6]))

The final check fails, and that failure is informative rather than a defect in the data. Below are several informative data summaries.

## 1. Age range includes paediatric nephrectomy cases.
sort(kidney$age_at_nephrectomy)[1:8]

## [1]  1 11 12 17 21 26 27 27

## 2. Laboratory truncation: eGFR reported as ">=90" rather than a number.
c(preop_truncated  = sum(kidney$preop_egfr_truncated),
  postop_truncated = sum(kidney$postop_egfr_truncated),
  preop_missing    = sum(is.na(kidney$preop_egfr)),
  postop_missing   = sum(is.na(kidney$postoperative_egfr)))

##  preop_truncated postop_truncated    preop_missing   postop_missing 
##               33               22               57               55

## 3. Missingness is highly structured, not random.
missing_rate <- sort(colMeans(is.na(kidney)), decreasing = TRUE)
round(head(missing_rate[missing_rate > 0], 8), 3)

## hospitalization_note        ischemia_note         egfr_decline 
##                0.995                0.667                0.433 
##    ischemia_time_min           pack_years           preop_egfr 
##                0.381                0.319                0.271 
##   postoperative_egfr     tumor_isup_grade 
##                0.262                0.181

## 4. Radiographic (preoperative CT) and pathologic (specimen) sizes disagree.
size_gap <- kidney$pathologic_size_cm - kidney$radiographic_size_cm
round(c(mean_gap_cm = mean(size_gap, na.rm = TRUE),
        sd_gap_cm   = sd(size_gap, na.rm = TRUE),
        max_gap_cm  = max(size_gap, na.rm = TRUE),
        min_gap_cm  = min(size_gap, na.rm = TRUE)), 2)

## mean_gap_cm   sd_gap_cm  max_gap_cm  min_gap_cm 
##       -0.06        1.18        8.60       -4.00

## 5. String sentinels hiding inside numeric fields.
table(ischemia = kidney$ischemia_note, useNA = "no")

## ischemia
## not_applicable 
##             70

table(hospitalization = kidney$hospitalization_note, useNA = "no")

## hospitalization
## died_before_discharge 
##                     1

## Is ischemia time missing at random, or explained by the operation performed?
with(kidney, table(surgery_type,
                   ischemia_recorded = !is.na(ischemia_time_min)))

##             ischemia_recorded
## surgery_type FALSE TRUE
##      partial    10  130
##      radical    70    0

Each finding is a modeling decision, not a nuisance.

A one-year-old undergoing nephrectomy is a different biological population. eGFR is not even defined below age 16 (hence the literal "age<16" entries). Either restrict the estimand to adults or model age nonlinearly.
">=90" is interval censoring in a covariate. Replacing it with 90 biases every eGFR analysis toward the boundary and shrinks apparent variance. Deleting it discards 33 real patients.
Ischemia time is not merely absent but explicitly "not_applicable" for 70 operations: no renal artery was clamped, so the quantity does not exist. The cross-tabulation above shows this tracks the surgical procedure, which is textbook informative missingness – imputing a median ischemia time would invent a clamp that never happened.
One patient’s length of stay reads "died_before_discharge". Coerced blindly, that becomes NA and the strongest possible outcome signal in the record silently disappears.
Radiographic and pathologic size measure the same tumor with different instruments at different times. Their disagreement is the measurement-error floor for any size-based model.

Quality control should also check units, impossible dates, duplicated images, image orientation, label values, image-mask alignment, and concordance between file manifests and metadata. Assertions make assumptions visible and cause the notebook to fail early rather than propagate corrupted values.

4.5 Exploratory data analysis (EDA)

Rigorous scientific discovery and responsible conduct of research require avoiding data dredging (cherry-picking results), outcome fishing, data fabrication, and other unethical manipulations and misreporting. Below are some genuine EDA examples.

op <- par(mfrow = c(2, 3), mar = c(4.2, 4.2, 3, 1))

hist(kidney$radiographic_size_cm, breaks = 24, col = "grey85",
     main = "Radiographic tumor size (real)", xlab = "Maximum diameter (cm)")

boxplot(radiographic_size_cm ~ surgery_type, data = kidney,
        col = c("#cfe3f7", "#f7d9cf"),
        main = "Size drives surgical extent", ylab = "Diameter (cm)")

barplot(table(kidney$malignancy_label), col = c("#9ecae1", "#fc9272"),
        main = "Pathology outcome (real)", ylab = "Cases")

plot(kidney$radiographic_size_cm, kidney$pathologic_size_cm, pch = 19, cex = 0.6,
     col = ifelse(kidney$malignant, "#d95f02", "#1b9e77"),
     xlab = "Radiographic size (cm)", ylab = "Pathologic size (cm)",
     main = "Two instruments, one tumor")
abline(0, 1, lty = 2)
legend("topleft", c("malignant", "benign"), pch = 19,
       col = c("#d95f02", "#1b9e77"), bty = "n", cex = 0.8)

hist(kidney$voxel_spacing_z_mm, breaks = 20, col = "grey85",
     main = "Real slice thickness", xlab = "z spacing (mm)")

plot(kidney$followup_days / 365.25,
     jitter(kidney$event_observed, amount = 0.05), pch = 19, cex = 0.5,
     xlab = "Follow-up (years)", ylab = "Death observed (0/1)",
     main = "Censoring pattern (real)")

par(op)

Exploration should be guided by a prespecified data-quality and scientific study design (statistical analysis plan, SAP). Repeatedly searching for favorable outcome associations and then reporting a single discovered model understates multiplicity and optimism.

4.6 Locking development and external test roles

We use the thin-slice acquisitions ($z$ spacing $\le 1$ mm) as an external-like held-out set. The thick-slice scans form the development pool, which is split by outcome into training and locked internal test sets. This boundary is a real, documented protocol difference in the released cohort.

## The external-like test set is defined by a REAL acquisition property:
## thin-slice (<=1 mm) versus thick-slice (>1 mm) reconstructions.
## Nothing here is invented -- the split is a documented scanner-protocol
## difference that genuinely shifts every spatial and texture feature.
external_idx    <- which(kidney$acq_group == "thin_slice")
development_idx <- which(kidney$acq_group == "thick_slice")

dev_split <- stratified_split(
  kidney$malignancy_label[development_idx], proportion = 0.75, seed = 81
)
train_idx         <- development_idx[dev_split$train]
internal_test_idx <- development_idx[dev_split$test]

partition <- rep(NA_character_, nrow(kidney))
partition[train_idx]         <- "training"
partition[internal_test_idx] <- "internal_test"
partition[external_idx]      <- "acquisition_held_out"
kidney$partition <- factor(
  partition, levels = c("training", "internal_test", "acquisition_held_out")
)

with(kidney, table(partition, malignancy_label))

##                       malignancy_label
## partition              benign malignant
##   training                  9       111
##   internal_test             4        37
##   acquisition_held_out      5        44

round(with(kidney, prop.table(table(partition, malignancy_label), margin = 1)), 3)

##                       malignancy_label
## partition              benign malignant
##   training              0.075     0.925
##   internal_test         0.098     0.902
##   acquisition_held_out  0.102     0.898

## Confirm the held-out group really is technically different.
aggregate(cbind(voxel_spacing_z_mm, voxel_spacing_x_mm, radiographic_size_cm) ~ acq_group,
          data = kidney, FUN = function(x) round(c(n = length(x), median = median(x)), 3))

##     acq_group voxel_spacing_z_mm.n voxel_spacing_z_mm.median
## 1  thin_slice                 49.0                       0.5
## 2 thick_slice                161.0                       5.0
##   voxel_spacing_x_mm.n voxel_spacing_x_mm.median radiographic_size_cm.n
## 1               49.000                     0.811                   49.0
## 2              161.000                     0.779                  161.0
##   radiographic_size_cm.median
## 1                         2.8
## 2                         4.3

The external-like test is deliberately more difficult because Site C has different reconstruction-kernel and slice-spacing distributions. This illustrates covariate shift rather than claiming to reproduce any specific institution.

Try it yourself (Section 4). Re-run the partition chunk using surgery_type instead of acq_group to define the held-out set. Compare the malignancy prevalence across partitions. You should find a much larger outcome imbalance, because surgical extent is chosen in response to tumor size. Explain why that makes it a poor external-validation axis even though it produces a clean-looking split.

5. From CT Volumes and Masks to Quantitative Features

5.1 Image tensors, coordinates, and segmentation labels

A 3D CT image is an array $I[i,j,k]$ together with an affine transformation from voxel indices to physical coordinates. A segmentation is a label array $M[i,j,k]$. For a binary tumor mask,

\[ M_{ijk}=\begin{cases} 1,&\text{tumor voxel},\\ 0,&\text{otherwise}. \end{cases} \]

The array dimensions alone do not determine physical size. If voxel spacing is $(\Delta_x,\Delta_y,\Delta_z)$ millimeters, then voxel volume is

\[ v_{\mathrm{vox}}=\Delta_x\Delta_y\Delta_z\ \mathrm{mm}^3, \]

and tumor volume is

\[ V=\left(\sum_{ijk}M_{ijk}\right)v_{\mathrm{vox}}. \]

Counting the number of voxels, without accounting for spacing (world-space scale) is not a reliable measure of size, i.e., not a volume measurement.

5.2 Reading a real NIfTI volume from first principles

## ---------------------------------------------------------------------------
## A NIfTI-1 reader written directly against the file specification.
## Reading the header yourself is a biomedical-physics exercise: the geometry
## that makes a voxel count into a physical volume lives in these bytes.
## No imaging package is required.
##   bytes  0- 3 : sizeof_hdr (348) -- also reveals byte order
##   bytes 40-55 : dim[0..7]  (dim[0] = number of used dimensions)
##   byte     70 : datatype    72 : bitpix
##   bytes 76-107: pixdim[0..7] (physical voxel size, mm)
##   byte    108 : vox_offset  (start of the voxel data)
## ---------------------------------------------------------------------------
read_nifti_header <- function(path) {
  con <- gzfile(path, "rb"); on.exit(close(con))
  sizeof_hdr <- readBin(con, "integer", n = 1, size = 4, endian = "little")
  endian <- if (identical(sizeof_hdr, 348L)) "little" else "big"
  readBin(con, "raw", n = 36)
  dims <- readBin(con, "integer", n = 8, size = 2, endian = endian)
  readBin(con, "raw", n = 14)
  datatype <- readBin(con, "integer", n = 1, size = 2, endian = endian)
  bitpix   <- readBin(con, "integer", n = 1, size = 2, endian = endian)
  readBin(con, "raw", n = 2)
  pixdim     <- readBin(con, "double", n = 8, size = 4, endian = endian)
  vox_offset <- readBin(con, "double", n = 1, size = 4, endian = endian)
  n_dim <- dims[1]
  list(dim = dims[2:(1 + n_dim)], pixdim = pixdim[2:(1 + n_dim)],
       datatype = datatype, bitpix = bitpix,
       vox_offset = vox_offset, endian = endian)
}

nifti_spec <- function(datatype) switch(
  as.character(datatype),
  "2"   = list(what = "integer", size = 1, signed = FALSE),
  "4"   = list(what = "integer", size = 2, signed = TRUE),
  "8"   = list(what = "integer", size = 4, signed = TRUE),
  "16"  = list(what = "double",  size = 4, signed = TRUE),
  "64"  = list(what = "double",  size = 8, signed = TRUE),
  "512" = list(what = "integer", size = 2, signed = FALSE),
  stop("unsupported NIfTI datatype: ", datatype)
)

## Read a whole volume (guarded, because CT volumes are large).
read_nifti_volume <- function(path, max_voxels = 6e7) {
  h  <- read_nifti_header(path)
  sp <- nifti_spec(h$datatype)
  n  <- prod(as.numeric(h$dim))
  if (n > max_voxels)
    stop("volume has ", n, " voxels - raise max_voxels or stream it instead")
  con <- gzfile(path, "rb"); on.exit(close(con))
  readBin(con, "raw", n = as.integer(h$vox_offset))
  v <- readBin(con, sp$what, n = n, size = sp$size,
               signed = sp$signed, endian = h$endian)
  structure(array(v, dim = h$dim), pixdim = h$pixdim)
}

A KiTS label volume is roughly $600\times512\times512 \approx 1.6\times10^{8}$ voxels. Loading it whole would need well over a gigabyte in R, so the morphometry routine streams the file one slab at a time. Because NIfTI stores the first index fastest, a contiguous block of dim[1] * dim[2] values is exactly one slice along the third axis.

## Streaming 3D morphometry: volumes, surface area, sphericity, bounding box,
## and the per-slice cross-sectional area profile -- in one pass, O(slice) memory.
mask_morphometrics <- function(path, keep_slices = integer(0)) {
  h  <- read_nifti_header(path)
  sp <- nifti_spec(h$datatype)
  d1 <- h$dim[1]; d2 <- h$dim[2]; d3 <- h$dim[3]
  vx <- h$pixdim[1]; vy <- h$pixdim[2]; vz <- h$pixdim[3]

  con <- gzfile(path, "rb"); on.exit(close(con))
  readBin(con, "raw", n = as.integer(h$vox_offset))

  n_kidney <- 0; n_tumor <- 0; tumor_faces <- 0
  bb <- c(Inf, -Inf, Inf, -Inf, Inf, -Inf)
  slice_area <- numeric(d3); prev_tumor <- NULL; kept <- list()

  for (k in seq_len(d3)) {
    v <- readBin(con, sp$what, n = d1 * d2, size = sp$size,
                 signed = sp$signed, endian = h$endian)
    M <- matrix(v, nrow = d1, ncol = d2)
    tumor  <- M == 2L                       # label 2 = tumor
    kidney <- M == 1L                       # label 1 = kidney parenchyma
    n_t <- sum(tumor)
    n_tumor  <- n_tumor + n_t
    n_kidney <- n_kidney + sum(kidney)
    slice_area[k] <- n_t * vx * vy

    if (n_t > 0) {
      i1 <- which(rowSums(tumor) > 0); i2 <- which(colSums(tumor) > 0)
      bb[1] <- min(bb[1], min(i1)); bb[2] <- max(bb[2], max(i1))
      bb[3] <- min(bb[3], min(i2)); bb[4] <- max(bb[4], max(i2))
      bb[5] <- min(bb[5], k);       bb[6] <- max(bb[6], k)
      ## exposed faces within the slice (6-connectivity)
      up    <- rbind(FALSE, tumor[-d1, , drop = FALSE])
      down  <- rbind(tumor[-1, , drop = FALSE], FALSE)
      left  <- cbind(FALSE, tumor[, -d2, drop = FALSE])
      right <- cbind(tumor[, -1, drop = FALSE], FALSE)
      tumor_faces <- tumor_faces +
        (sum(tumor & !up) + sum(tumor & !down)) * vy * vz +
        (sum(tumor & !left) + sum(tumor & !right)) * vx * vz
    }
    ## faces exposed across slices
    tumor_faces <- tumor_faces + if (is.null(prev_tumor)) n_t * vx * vy else
      (sum(tumor & !prev_tumor) + sum(prev_tumor & !tumor)) * vx * vy
    prev_tumor <- tumor
    if (k %in% keep_slices) kept[[as.character(k)]] <- M
  }
  tumor_faces <- tumor_faces + sum(prev_tumor) * vx * vy

  voxel_volume <- vx * vy * vz
  V_t <- n_tumor * voxel_volume          # mm^3
  V_k <- n_kidney * voxel_volume
  list(
    header             = h,
    voxel_volume_mm3   = voxel_volume,
    kidney_volume_cm3  = V_k / 1000,
    tumor_volume_cm3   = V_t / 1000,
    tumor_surface_cm2  = tumor_faces / 100,
    ## sphericity = surface area of the equal-volume sphere / actual surface area
    tumor_sphericity   = if (tumor_faces > 0)
      (pi^(1 / 3)) * ((6 * V_t)^(2 / 3)) / tumor_faces else NA_real_,
    tumor_bbox_mm      = c((bb[2] - bb[1] + 1) * vx,
                           (bb[4] - bb[3] + 1) * vy,
                           (bb[6] - bb[5] + 1) * vz),
    slice_area_mm2     = slice_area,
    slices             = kept
  )
}

fetch_kits_mask <- function(case_id) {
  bpad_fetch(
    sprintf("https://github.com/neheller/kits19/raw/master/data/%s/segmentation.nii.gz",
            case_id),
    paste0(case_id, "_segmentation.nii.gz")
  )
}

demo_case <- "case_00000"
mask_path <- fetch_kits_mask(demo_case)

if (!is.na(mask_path)) {
  ## First pass: geometry + where the tumor is largest.
  demo_scan  <- mask_morphometrics(mask_path)
  k_max      <- which.max(demo_scan$slice_area_mm2)
  tumor_k    <- which(demo_scan$slice_area_mm2 > 0)
  ## Second pass: retain three representative slices for display.
  keep_k     <- unique(round(quantile(tumor_k, c(0.15, 0.5, 0.85))))
  demo_scan2 <- mask_morphometrics(mask_path, keep_slices = keep_k)

  cat(sprintf("%s: %d x %d x %d voxels, spacing %.2f x %.2f x %.2f mm\n",
              demo_case, demo_scan$header$dim[1], demo_scan$header$dim[2],
              demo_scan$header$dim[3], demo_scan$header$pixdim[1],
              demo_scan$header$pixdim[2], demo_scan$header$pixdim[3]))

  op <- par(mfrow = c(1, 3), mar = c(2, 2, 3, 1))
  for (kk in as.character(keep_k)) {
    S <- demo_scan2$slices[[kk]]
    image(seq_len(nrow(S)), seq_len(ncol(S)), S,
          col = c("grey95", "#4292c6", "#cb181d"), zlim = c(0, 2),
          xlab = "", ylab = "", axes = FALSE,
          main = sprintf("slice %s (tumor %.0f mm2)",
                         kk, demo_scan$slice_area_mm2[as.integer(kk)]))
    box()
  }
  par(op)
} else {
  message("Mask download unavailable; see the caching notes in the setup chunk.")
}

## case_00000: 611 x 512 x 512 voxels, spacing 0.50 x 0.92 x 0.92 mm

Blue is kidney parenchyma (label 1) and red is tumor (label 2), exactly as delineated by the KiTS annotators. The cross-sectional tumor area varies markedly from slice to slice, which is why a single axial diameter is a lossy summary of a three-dimensional object.

if (!is.na(mask_path)) {
  z_mm <- seq_along(demo_scan$slice_area_mm2) * demo_scan$header$pixdim[3]
  keep <- demo_scan$slice_area_mm2 > 0
  plot(z_mm[keep], demo_scan$slice_area_mm2[keep], type = "h", lwd = 2,
       col = "#cb181d", xlab = "Position along the third axis (mm)",
       ylab = expression("Tumor cross-sectional area (mm"^2*")"),
       main = "Real tumor area profile A(z)")
  ## Discrete integral: sum(A) * slice thickness == the streamed volume.
  V_trap <- sum(demo_scan$slice_area_mm2) * demo_scan$header$pixdim[3] / 1000
  cat(sprintf("Riemann sum of A(z) : %.3f cm3\nStreamed voxel count: %.3f cm3\n",
              V_trap, demo_scan$tumor_volume_cm3))
}

## Riemann sum of A(z) : 7.824 cm3
## Streamed voxel count: 7.824 cm3

Volume is an integral, and the code proves it. The profile $A(z)$ integrates to $V=\int A(z)\,dz$, and the Riemann sum agrees with the direct voxel count to numerical precision. The same identity underlies every volumetric biomarker in the chapter, and it is why voxel spacing – not voxel count – carries the physics.

Every number below comes from the released reference segmentation for a real patient, decoded from the NIfTI byte stream by the reader written above.

5.3 First-order intensity features

For tumor voxels $I_1,\ldots,I_m$, common first-order summaries include mean, standard deviation, quantiles, skewness, and histogram entropy. For histogram probabilities $p_b$,

\[ H=-\sum_b p_b\log p_b. \]

Feature definitions depend on preprocessing choices such as intensity clipping, bin width, resampling, and mask discretization. Two implementations with different binning rules may produce different values despite sharing the same feature name.

5.4 Shape features in physical units

Let $A$ be surface area and $V$ volume and Sphericity is

\[ \Phi=\frac{\pi^{1/3}(6V)^{2/3}}{A}, \]

which equals one for an ideal sphere and is below one for less compact shapes. Surface estimates are sensitive to voxel anisotropy, resampling, and mesh construction. The face-counting estimator below is transparent and suitable for teaching, but production radiomics commonly uses a triangulated surface and standardized definitions.

## ---------------------------------------------------------------------------
## Region-of-interest descriptors. Each returns physical units, so results are
## comparable across scanners with different sampling grids.
## ---------------------------------------------------------------------------

## Shape descriptors from a label volume already summarized by mask_morphometrics().
shape_features <- function(mm) {
  V <- mm$tumor_volume_cm3
  S <- mm$tumor_surface_cm2
  c(
    tumor_volume_cm3      = V,
    tumor_surface_cm2     = S,
    tumor_sphericity      = mm$tumor_sphericity,
    surface_to_volume     = if (V > 0) S / V else NA_real_,
    equivalent_diameter_cm= if (V > 0) 2 * (3 * V / (4 * pi))^(1 / 3) else NA_real_,
    max_bbox_extent_mm    = max(mm$tumor_bbox_mm),
    bbox_elongation       = max(mm$tumor_bbox_mm) / min(mm$tumor_bbox_mm),
    max_axial_area_mm2    = max(mm$slice_area_mm2),
    n_tumor_slices        = sum(mm$slice_area_mm2 > 0),
    kidney_volume_cm3     = mm$kidney_volume_cm3,
    tumor_kidney_ratio    = if (mm$kidney_volume_cm3 > 0)
                              V / mm$kidney_volume_cm3 else NA_real_
  )
}

## First-order intensity statistics inside a mask (requires an image volume).
first_order_features <- function(image, mask) {
  v <- as.numeric(image[mask])
  v <- v[is.finite(v)]
  if (!length(v)) return(rep(NA_real_, 8))
  q <- stats::quantile(v, c(0.10, 0.25, 0.50, 0.75, 0.90), names = FALSE)
  c(mean = mean(v), sd = stats::sd(v),
    p10 = q[1], q1 = q[2], median = q[3], q3 = q[4], p90 = q[5],
    entropy = {
      h <- graphics::hist(v, breaks = 32, plot = FALSE)$counts
      p <- h / sum(h); -sum(p[p > 0] * log(p[p > 0]))
    })
}

## Grey-level co-occurrence texture on a 2D slice (horizontal neighbour pairs).
## Discretization level count is an explicit choice: texture values are not
## comparable across different `levels` or different intensity ranges.
glcm_features_2d <- function(slice, levels = 16) {
  d <- dim(slice)
  rng <- range(slice, finite = TRUE)
  if (diff(rng) <= 0) return(c(contrast = NA, homogeneity = NA,
                               energy = NA, entropy = NA))
  q <- matrix(cut(as.numeric(slice),
                  breaks = seq(rng[1], rng[2] + 1e-9, length.out = levels + 1),
                  labels = FALSE, include.lowest = TRUE), d[1], d[2])
  a <- as.vector(q[, -d[2]]); b <- as.vector(q[, -1])
  ok <- is.finite(a) & is.finite(b); a <- a[ok]; b <- b[ok]
  P <- matrix(0, levels, levels)
  for (i in seq_along(a)) P[a[i], b[i]] <- P[a[i], b[i]] + 1
  P <- P + t(P); P <- P / sum(P)               # symmetric, normalized
  ii <- row(P); jj <- col(P)
  c(contrast    = sum(P * (ii - jj)^2),
    homogeneity = sum(P / (1 + (ii - jj)^2)),
    energy      = sum(P^2),
    entropy     = -sum(ifelse(P > 0, P * log(P), 0)))
}

Applied to the real reference segmentation, the shape descriptors are immediately interpretable:

if (!is.na(mask_path)) {
  round(shape_features(demo_scan), 3)
}

##       tumor_volume_cm3      tumor_surface_cm2       tumor_sphericity 
##                  7.824                 34.223                  0.557 
##      surface_to_volume equivalent_diameter_cm     max_bbox_extent_mm 
##                  4.374                  2.463                 28.500 
##        bbox_elongation     max_axial_area_mm2         n_tumor_slices 
##                  1.192                498.598                 26.000 
##      kidney_volume_cm3     tumor_kidney_ratio 
##                387.450                  0.020

## Process the first `bpad_n_mask` released cases into a REAL radiomic table.
## Each mask is ~0.8 MB compressed and takes a few seconds to stream. Results
## are cached so repeated knits are fast. Raise bpad.n_mask_cases to extend
## toward the full 210-case cohort.
imaging_cache <- file.path(bpad_cache_dir,
                           sprintf("real_imaging_features_%d.rds", bpad_n_mask))

if (file.exists(imaging_cache)) {
  imaging_features <- readRDS(imaging_cache)
} else {
  target_cases <- kidney$case_id[seq_len(min(bpad_n_mask, nrow(kidney)))]
  rows <- list()
  for (cid in target_cases) {
    p <- fetch_kits_mask(cid)
    if (is.na(p)) next
    mm <- try(mask_morphometrics(p), silent = TRUE)
    if (inherits(mm, "try-error")) next
    rows[[cid]] <- data.frame(case_id = cid,
                              as.list(round(shape_features(mm), 4)),
                              stringsAsFactors = FALSE)
    unlink(p)   # keep the cache small - comment out to retain volumes
  }
  imaging_features <- if (length(rows)) do.call(rbind, rows) else NULL
  if (!is.null(imaging_features)) saveRDS(imaging_features, imaging_cache)
}

if (is.null(imaging_features)) {
  message("No mask volumes available - imaging-feature sections will be skipped.")
  have_imaging <- FALSE
} else {
  have_imaging <- TRUE
  cat("Real imaging-derived features computed for",
      nrow(imaging_features), "cases\n")
  utils::head(imaging_features[, c("case_id", "tumor_volume_cm3",
                                   "tumor_surface_cm2", "tumor_sphericity",
                                   "equivalent_diameter_cm")], 6)
}

## Real imaging-derived features computed for 30 cases

##               case_id tumor_volume_cm3 tumor_surface_cm2 tumor_sphericity
## case_00000 case_00000           7.8241           34.2233           0.5569
## case_00001 case_00001           7.2654           42.3054           0.4288
## case_00002 case_00002          34.9763           84.5714           0.6116
## case_00003 case_00003          10.2251           36.9808           0.6161
## case_00004 case_00004          18.8484           53.1953           0.6439
## case_00005 case_00005          60.2932          130.2968           0.5707
##            equivalent_diameter_cm
## case_00000                 2.4631
## case_00001                 2.4030
## case_00002                 4.0575
## case_00003                 2.6929
## case_00004                 3.3019
## case_00005                 4.8651

5.5 Texture features and discretization

A gray-level co-occurrence matrix (GLCM), $P(i,j\mid d,\alpha)$, records the relative frequency with which discretized levels $i$ and $j$ occur at displacement $d$ and direction $\alpha$. Examples include

\[\mathrm{contrast}=\sum_{i,j}(i-j)^2P(i,j),\] and \[\mathrm{energy}=\sum_{i,j}P(i,j)^2, \qquad \mathrm{homogeneity}=\sum_{i,j}\frac{P(i,j)}{1+|i-j|}.\]

Texture is not intrinsic to a lesion independently of acquisition. It changes with reconstruction kernel, slice thickness, voxel size, denoising, gray-level discretization, direction aggregation, and ROI perturbation. Those quantities belong in the feature manifest. Texture is not intrinsic to a lesion independently of acquisition. It changes with reconstruction kernel, slice thickness, voxel size, denoising, gray-level discretization, direction aggregation, and ROI perturbation. Those quantities belong in the feature manifest. Section 5.8 demonstrates this dependence directly on a real image.

5.6 Propagating segmentation uncertainty

A mask is an estimate. To examine sensitivity, perturb it and recompute features. The following six-neighbor morphology is deliberately explicit. A mask is an estimate. To examine sensitivity, perturb a real expert contour and recompute the biomarker. The morphology below is deliberately explicit.

## Morphological operations on a binary mask (4-connectivity, base R only).
dilate_mask <- function(M) {
  d <- dim(M); out <- M
  out[-1, ]     <- out[-1, ]     | M[-d[1], ]
  out[-d[1], ]  <- out[-d[1], ]  | M[-1, ]
  out[, -1]     <- out[, -1]     | M[, -d[2]]
  out[, -d[2]]  <- out[, -d[2]]  | M[, -1]
  out
}
erode_mask <- function(M) !dilate_mask(!M)

dice_coefficient <- function(a, b) {
  denom <- sum(a) + sum(b)
  if (denom == 0) return(NA_real_)
  2 * sum(a & b) / denom
}
jaccard_index <- function(a, b) {
  denom <- sum(a | b)
  if (denom == 0) return(NA_real_)
  sum(a & b) / denom
}

## How much does a ONE-VOXEL boundary change alter the reported biomarker?
## This is the segmentation-uncertainty floor of every radiomic study.
if (!is.na(mask_path)) {
  S      <- demo_scan2$slices[[as.character(keep_k[2])]]
  tumor  <- S == 2
  pix    <- demo_scan$header$pixdim
  area_of <- function(M) sum(M) * pix[1] * pix[2]

  perturbation <- data.frame(
    perturbation = c("reference", "dilate 1 voxel", "erode 1 voxel"),
    dice = c(1,
             dice_coefficient(tumor, dilate_mask(tumor)),
             dice_coefficient(tumor, erode_mask(tumor))),
    jaccard = c(1,
                jaccard_index(tumor, dilate_mask(tumor)),
                jaccard_index(tumor, erode_mask(tumor))),
    area_mm2 = c(area_of(tumor),
                 area_of(dilate_mask(tumor)),
                 area_of(erode_mask(tumor)))
  )
  perturbation$area_change_pct <- round(
    100 * (perturbation$area_mm2 - perturbation$area_mm2[1]) /
      perturbation$area_mm2[1], 1)
  perturbation[, -1] <- round(perturbation[, -1], 4)
  perturbation
}

##     perturbation   dice jaccard area_mm2 area_change_pct
## 1      reference 1.0000  1.0000 498.5977             0.0
## 2 dilate 1 voxel 0.9438  0.8937 557.9326            11.9
## 3  erode 1 voxel 0.9388  0.8847 441.1025           -11.5

Dice hides what the biomarker reports. A single-voxel dilation of this real tumor contour still scores a Dice coefficient near $0.94$ – a value most papers would call excellent agreement – yet it changes the measured cross-sectional area by roughly $12\%$. Overlap metrics and quantitative biomarkers are sensitive to different aspects of the same boundary error, so a segmentation method validated only on Dice has not been validated for volumetry.

The spread across plausible masks can be carried forward as a sensitivity interval, used to filter unstable features, or modeled through multiple imputation over segmentations. Treating the reference contour as error-free generally understates uncertainty.

5.7 Joining imaging and clinical tables safely

This kidney study emphasizes that case identifiers connect image-derived measurements to clinical metadata. A safe join verifies uniqueness and row preservation. This kidney study emphasizes that case identifiers connect image-derived measurements to clinical metadata. A safe join verifies uniqueness and row preservation – and then asks whether the imaging pipeline agrees with the clinical record.

## Join REAL imaging-derived morphometry to REAL clinical records by case_id.
if (have_imaging) {
  kidney_img <- merge(kidney, imaging_features, by = "case_id", all.x = FALSE)
  cat("Cases with both imaging and clinical data:", nrow(kidney_img), "\n")

  ## --- Validation 1: does the imaging pipeline reproduce the recorded size? --
  agreement <- data.frame(
    comparison = c("equivalent-sphere diameter", "max bounding-box extent"),
    pearson_r  = c(cor(kidney_img$radiographic_size_cm,
                       kidney_img$equivalent_diameter_cm, use = "complete.obs"),
                   cor(kidney_img$radiographic_size_cm,
                       kidney_img$max_bbox_extent_mm / 10, use = "complete.obs"))
  )
  agreement$pearson_r <- round(agreement$pearson_r, 3)
  agreement
}

## Cases with both imaging and clinical data: 30

##                   comparison pearson_r
## 1 equivalent-sphere diameter     0.983
## 2    max bounding-box extent     0.952

if (have_imaging) {
  op <- par(mfrow = c(1, 3), mar = c(4.3, 4.3, 3, 1))

  ## (a) imaging-derived vs. clinically recorded diameter
  plot(kidney_img$radiographic_size_cm, kidney_img$equivalent_diameter_cm,
       pch = 19, col = "#2c7fb8", xlab = "Recorded radiographic size (cm)",
       ylab = "Imaging equivalent diameter (cm)",
       main = "Pipeline vs. clinical record")
  abline(0, 1, lty = 2)

  ## (b) Bland-Altman agreement
  m_avg <- (kidney_img$max_bbox_extent_mm / 10 + kidney_img$radiographic_size_cm) / 2
  m_dif <- kidney_img$max_bbox_extent_mm / 10 - kidney_img$radiographic_size_cm
  plot(m_avg, m_dif, pch = 19, col = "#d95f02",
       xlab = "Mean of the two measurements (cm)",
       ylab = "Difference (cm)", main = "Bland-Altman")
  abline(h = mean(m_dif, na.rm = TRUE), lwd = 2)
  abline(h = mean(m_dif, na.rm = TRUE) +
           c(-1.96, 1.96) * sd(m_dif, na.rm = TRUE), lty = 2)

  ## (c) the volume-diameter scaling law
  fit_scale <- lm(log(tumor_volume_cm3) ~ log(radiographic_size_cm),
                  data = kidney_img)
  plot(log(kidney_img$radiographic_size_cm), log(kidney_img$tumor_volume_cm3),
       pch = 19, col = "#1b9e77", xlab = "log diameter (cm)",
       ylab = expression("log volume (cm"^3*")"),
       main = "Scaling law on real tumors")
  abline(fit_scale, lwd = 2)
  par(op)

  cat(sprintf("Bland-Altman bias %.2f cm, limits of agreement [%.2f, %.2f] cm\n",
              mean(m_dif, na.rm = TRUE),
              mean(m_dif, na.rm = TRUE) - 1.96 * sd(m_dif, na.rm = TRUE),
              mean(m_dif, na.rm = TRUE) + 1.96 * sd(m_dif, na.rm = TRUE)))
  cat(sprintf("Fitted scaling exponent %.2f (isotropic growth predicts 3), R2 = %.3f\n",
              coef(fit_scale)[2], summary(fit_scale)$r.squared))
}

## Bland-Altman bias 0.58 cm, limits of agreement [-1.25, 2.40] cm
## Fitted scaling exponent 2.81 (isotropic growth predicts 3), R2 = 0.940

A physical validation, not a statistical one. If tumors grew as geometrically similar solids, volume would scale as the cube of a linear dimension, $V \propto D^{3}$. Fitting $\log V$ on $\log D$ over real KiTS tumors recovers an exponent close to $3$, which simultaneously (i) validates that the voxel-counting pipeline and the radiologist’s caliper are measuring the same object, and (ii) quantifies the departure from perfect sphericity. An exponent far from $3$, or a Bland-Altman plot with a trend, would indicate a geometry or spacing bug – the kind of error that silently propagates into every downstream model.

A production pipeline should additionally verify one-to-one or one-to-many cardinality, report unmatched identifiers, preserve provenance, and distinguish patient, encounter, study, series, and lesion identifiers.

5.8 Real intensity volumes: first-order and texture radiomics

Shape features need only the label volume. Intensity features, e.g., attenuation, heterogeneity, and texture, need the reconstructed image itself. The released KiTS CT volumes are large (hundreds of megabytes per case). This section resolves a real intensity volume using a documented order of preference and reports which source was used. In addition to the KiTS19 CT, a kidney MRI dataset hosted on Canvas can be downloaded by setting the option bpad.download_canvas_mri to TRUE. This gives a high‑resolution abdominal MRI volume (602 × 512 × 512) that is realistic for morphometric and texture analysis.

## Preference order for a REAL intensity volume:
##  1. a local NIfTI file the reader already has (set bpad.local_ct);
##  2. the released KiTS19 CT volume (large; enable with bpad.download_ct);
##  3. a kidney MRI volume from the course Canvas site
##     (enable with bpad.download_canvas_mri);
##  4. a small openly distributed reference NIfTI volume, so that the
##     intensity mathematics below always executes on genuine image data.
resolve_image_volume <- function() {
  local_ct <- getOption("bpad.local_ct", "")
  
  if (isTRUE(getOption("bpad.download_canvas_mri", FALSE))) {
    # High‑res kidney MRI volume from the UMich Canvas site
    p <- bpad_fetch(
      "https://umich.instructure.com/files/29648559/download?download_frd=1",
      "kidney_mri_canvas.nii.gz")
    if (!is.na(p))
      return(list(path = p, source = "Canvas kidney MRI volume", modality = "MRI"))
  }

  if (nzchar(local_ct) && file.exists(local_ct))
    return(list(path = local_ct, source = "local NIfTI file", modality = "unknown"))

  if (isTRUE(getOption("bpad.download_ct", FALSE))) {
    p <- bpad_fetch(
      "https://kits19.sfo2.digitaloceanspaces.com/interpolated_00000.nii.gz",
      "kits_ct_00000.nii.gz")
    if (!is.na(p))
      return(list(path = p, source = "KiTS19 released CT volume", modality = "CT"))
  }

  p <- bpad_fetch(
    "https://raw.githubusercontent.com/jonclayden/RNifti/master/inst/extdata/example.nii.gz",
    "reference_volume.nii.gz")
  if (!is.na(p))
    return(list(path = p, source = "openly distributed reference MRI volume",
                modality = "MRI"))
  list(path = NA_character_, source = "none", modality = NA_character_)
}

img_src <- resolve_image_volume()
have_image <- !is.na(img_src$path)
cat("Intensity volume source:", img_src$source, "\n")

## Intensity volume source: openly distributed reference MRI volume

if (have_image) {
  # ----- helper: load a NIfTI and optionally downsample -----
  load_and_downsample <- function(path, factor = 2) {
    # Use RNifti to read the full volume (no arbitrary voxel cap)
    if (!requireNamespace("RNifti", quietly = TRUE))
      stop("Package 'RNifti' is required but not installed.")
    full <- RNifti::readNifti(path)
    dims <- dim(full)
    
    if (factor > 1) {
      # integer subsampling – works for factor = 2, 3, ...
      idx <- lapply(dims, function(d) seq(1, d, by = factor))
      vol  <- full[idx[[1]], idx[[2]], idx[[3]], drop = FALSE]
      # adjust pixel dimensions
      old_spacing <- RNifti::pixdim(full)[2:4]   # original mm spacing
      new_spacing <- old_spacing * factor
      attr(vol, "pixdim") <- c(1, new_spacing, rep(0, 4))  # mimic NIfTI pixdim
      attr(vol, "downsample_factor") <- factor
      message(sprintf("Downsampled %s to %s (factor = %d)",
                      paste(dims, collapse = "x"),
                      paste(dim(vol), collapse = "x"), factor))
    } else {
      vol <- full
      attr(vol, "pixdim") <- RNifti::pixdim(full)
    }
    return(vol)
  }
  
  # Control downsampling via an option (default factor = 2)
  ds_factor <- getOption("bpad.downsample_factor", 2)
  vol <- load_and_downsample(img_src$path, factor = ds_factor)
  spac <- attr(vol, "pixdim")
  cat(sprintf("volume %d x %d x %d, spacing %.2f x %.2f x %.2f mm, range [%g, %g]\n",
              dim(vol)[1], dim(vol)[2], dim(vol)[3],
              spac[2], spac[3], spac[4], min(vol), max(vol)))

  ## Define an ROI from the data itself (upper intensity quartile of the
  ## central region) so the demonstration needs no external label volume.
  mid <- round(dim(vol)[3] / 2)
  slice <- vol[, , mid]
  roi   <- slice > stats::quantile(slice, 0.75)

  op <- par(mfrow = c(1, 3), mar = c(4.2, 4.2, 3, 1))
  image(slice, col = grDevices::grey.colors(64), axes = FALSE,
        main = paste("Real slice --", img_src$modality)); box()
  image(roi, col = c("grey95", "#cb181d"), axes = FALSE,
        main = "Analysis ROI"); box()
  hist(slice[roi], breaks = 40, col = "grey85",
       main = "First-order distribution in ROI", xlab = "Intensity")
  par(op)

  fo <- first_order_features(slice, roi)
  tx <- glcm_features_2d(slice, levels = 16)
  round(c(fo, tx), 4)
}

## volume 48 x 48 x 30, spacing 5.00 x 5.00 x NA mm, range [0, 2314]

##        mean          sd         p10          q1      median          q3 
##    484.7474    152.3538    353.3000    383.2500    443.5000    523.0000 
##         p90     entropy    contrast homogeneity      energy     entropy 
##    660.0000      2.1686      1.5541      0.8276      0.4095      2.0118

# #### OLD: problems with large data imports
# if (have_image) {
#   vol  <- read_nifti_volume(img_src$path)
#   spac <- attr(vol, "pixdim")
#   cat(sprintf("volume %d x %d x %d, spacing %.2f x %.2f x %.2f mm, range [%g, %g]\n",
#               dim(vol)[1], dim(vol)[2], dim(vol)[3],
#               spac[1], spac[2], spac[3], min(vol), max(vol)))
# 
#   ## Define an ROI from the data itself (upper intensity quartile of the
#   ## central region) so the demonstration needs no external label volume.
#   mid <- round(dim(vol)[3] / 2)
#   slice <- vol[, , mid]
#   roi   <- slice > stats::quantile(slice, 0.75)
# 
#   op <- par(mfrow = c(1, 3), mar = c(4.2, 4.2, 3, 1))
#   image(slice, col = grDevices::grey.colors(64), axes = FALSE,
#         main = paste("Real slice --", img_src$modality)); box()
#   image(roi, col = c("grey95", "#cb181d"), axes = FALSE,
#         main = "Analysis ROI"); box()
#   hist(slice[roi], breaks = 40, col = "grey85",
#        main = "First-order distribution in ROI", xlab = "Intensity")
#   par(op)
# 
#   fo <- first_order_features(slice, roi)
#   tx <- glcm_features_2d(slice, levels = 16)
#   round(c(fo, tx), 4)
# }

if (have_image) {
  ## Texture features are NOT properties of the tissue alone: they depend on the
  ## grey-level discretization chosen by the analyst.
  lv <- c(8, 16, 32, 64, 128)
  tex <- t(sapply(lv, function(L) glcm_features_2d(slice, levels = L)))
  rownames(tex) <- paste0("levels=", lv)
  round(tex, 4)

  matplot(lv, scale(tex), type = "b", pch = 19, lty = 1, log = "x",
          xlab = "Number of grey levels", ylab = "Standardized feature value",
          main = "Texture features depend on discretization")
  legend("topright", colnames(tex), col = 1:4, lty = 1, pch = 19,
         bty = "n", cex = 0.8)
}

Texture is a pipeline output, not a tissue property. Contrast, homogeneity, energy, and entropy all move systematically as the grey-level count changes, even though the underlying image never changes. Any radiomics report that omits the discretization scheme, intensity range, resampling, and neighbourhood definition is not reproducible. The same warning applies to slice thickness: the KiTS cohort spans $0.5$–$5.0$ mm, and texture computed across that range is not comparable without harmonization (Section 12.2).

Try it yourself. Set options(bpad.download_ct = TRUE) before knitting to run this section on the released KiTS CT volume, then recompute first_order_features() inside the tumor label instead of an intensity-defined ROI. In Hounsfield units, does the tumor ROI mean fall in the range you would predict for an enhancing solid renal mass? Compare it with the surrounding parenchyma.

NIfTI orientation and affine metadata must be checked explicitly. An image and mask can have identical array dimensions but occupy different physical coordinates.

5.9 Sampling, resampling, interpolation, and aliasing

Chapter 1 established that spatial sampling above the Nyquist limit aliases high-frequency structure. In imaging AI, resampling changes both anatomy and texture. If $I(x)$ is sampled with interval $\Delta$, frequencies above $1/(2\Delta)$ cannot be represented without aliasing.

In medical imaging and radiomics, spatial sampling is governed by the Nyquist-Shannon sampling theorem.

If a continuous anatomical signal $I(x)$ is discretized at spatial sampling interval $\Delta$ (voxel spacing), the highest frequency that can be accurately represented, i.e., the Nyquist limit ($f_N$), is

\[f_N = \frac{1}{2\Delta}.\]

When raw acquisitions or preprocessing pipelines downsample an image without prior low-pass filtering, any true anatomical or noise frequencies $f_{\text{true}} > f_N$ are not simply lost, they alias (fold back) into lower frequencies. This aliasing manifests as artificial, coarse spatial textures that can permanently deceive downstream radiomic feature extractors (e.g., GLCM, GLRLM) or 3D convolutional neural networks. Mathematically, an undersampled high frequency appears as a false low frequency $f_{\text{alias}} = \vert{}f_s - f_{\text{true}}\vert{}$, where $f_s = 1/\Delta$ is the sampling rate.Furthermore, clinical scans are frequently anisotropic, e.g., high in-plane resolution of $0.8 \times 0.8\text{ mm}$, but thick slices of $5.0\text{ mm}$ along the $z$-axis.

Converting these grids to isotropic voxels requires careful kernel selection.

Nearest-Neighbor Interpolation: Preserves exact original intensities and discrete labels. It is mandatory for binary segmentation masks and ROIs to prevent generating non-existent fractional class labels, though it introduces blocky, step-like spatial artifacts.

Linear / Bilinear / Trilinear Interpolation: Standard for continuous intensity images. It is computationally fast and smooths step artifacts, but acts as a low-pass filter that dampens fine textural gradients.

Higher-Order (B-Spline / Sinc / Cubic Interpolation): Better preserves continuous frequency spectra and sharp edges, but can induce Gibbs ringing artifacts, artificial intensity overshoots that can push Hounsfield units (in CT) or MR intensities into physically impossible negative or out-of-range values near sharp tissue boundaries (e.g., bone-to-air interfaces).

To prevent data leakage and distributional shifts, every parameter of the spatial resampling pipeline (including target voxel spacing, anti-aliasing pre-filtering, interpolation kernel, and intensity re-quantization) must be locked during training and identically reproduced at deployment.

The following R demonstration reports two clear panels

The Aliasing Trap: Visually proves how sampling an $18\text{ Hz}$ signal at $24\text{ Hz}$ ($f_N = 12\text{ Hz}$) causes the data points to fold into an artificial, low-frequency $6\text{ Hz}$ wave ($\vert{}24 - 18\vert{} = 6$).
Interpolation Kernel Artifacts: Compares how Nearest-Neighbor (step-like), Linear (jagged), and Cubic Spline (smooth but prone to overshoot) kernels reconstruct spatial data from sparse samples.

# Setup layout and high-resolution continuous grid
op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
continuous_x <- seq(0, 1, length.out = 1000)

# -------------------------------------------------------------------------
# PANEL 1: The Aliasing Trap (Frequency Folding)
# -------------------------------------------------------------------------
true_f   <- 18                         # True high-frequency signal (18 Hz)
sample_f <- 24                         # Sampling rate (24 Hz -> Nyquist limit is 12 Hz)
alias_f  <- abs(sample_f - true_f)     # Folds back to 6 Hz!

# Generate continuous signals and coarse samples
signal_true <- sin(2 * pi * true_f * continuous_x)
coarse_x    <- seq(0, 1, by = 1 / sample_f)
coarse_y    <- sin(2 * pi * true_f * coarse_x)

# Spline interpolation through coarse samples reveals the false 6 Hz wave
aliased_wave <- spline(coarse_x, coarse_y, xout = continuous_x)$y

plot(continuous_x, signal_true, type = "l", col = "gray70", lwd = 1.5,
     xlab = "Spatial Position", ylab = "Signal Intensity",
     main = "Undersampling Folds 18 Hz Signal into False 6 Hz Artifact",
     ylim = c(-1.3, 1.3))
lines(continuous_x, aliased_wave, col = "firebrick", lwd = 2.5)
points(coarse_x, coarse_y, pch = 19, col = "black", cex = 1.2)
legend("topright", 
       legend = c("True Anatomy (18 Hz)", "Aliased Artifact (~6 Hz)", "Acquired Voxels (24 Hz)"),
       col = c("gray70", "firebrick", "black"), lty = c(1, 1, NA), pch = c(NA, NA, 19), 
       lwd = c(1.5, 2.5, NA), bty = "n", cex = 0.85)

# -------------------------------------------------------------------------
# PANEL 2: Interpolation Kernel Behaviors on Coarse Grids
# -------------------------------------------------------------------------
# Sample a smooth anatomical boundary coarsely
sparse_x <- seq(0, 1, by = 0.125)
sparse_y <- sin(2 * pi * 1.5 * sparse_x) + 0.3 * cos(2 * pi * 3 * sparse_x)

# Apply three different interpolation kernels
nn_recon     <- approx(sparse_x, sparse_y, xout = continuous_x, method = "constant")$y
linear_recon <- approx(sparse_x, sparse_y, xout = continuous_x, method = "linear")$y
spline_recon <- spline(sparse_x, sparse_y, xout = continuous_x)$y

plot(continuous_x, spline_recon, type = "n", ylim = c(-1.5, 1.5),
     xlab = "Spatial Position", ylab = "Reconstructed Intensity",
     main = "Impact of Interpolation Kernel on Spatial Grids")

lines(continuous_x, nn_recon, col = "darkorange", lwd = 2, lty = 1)
lines(continuous_x, linear_recon, col = "dodgerblue", lwd = 2, lty = 2)
lines(continuous_x, spline_recon, col = "darkgreen", lwd = 2, lty = 3)
points(sparse_x, sparse_y, pch = 19, col = "black", cex = 1.3)

legend("topright", 
       legend = c("Nearest-Neighbor (Masks/ROIs)", "Linear (Fast, Dampens Edges)", "Cubic Spline (Smooth, May Ring)"),
       col = c("darkorange", "dodgerblue", "darkgreen"), lty = c(1, 2, 3), 
       lwd = 2, bty = "n", cex = 0.85)

par(op)

5.10 Feature provenance and standardization

A radiomics feature should be accompanied by a computational provenance record:

image identifier and checksum;
acquisition and reconstruction metadata;
conversion and orientation steps;
segmentation source and version;
voxel spacing before and after resampling;
interpolation and anti-aliasing method;
intensity clipping and normalization;
gray-level discretization;
feature definition, aggregation, software, and version;
quality-control status.

The Image Biomarker Standardization Initiative (IBSI) provides standardized definitions and benchmark values. Standardization is not merely administrative, it determines whether a feature has the same mathematical meaning across software and studies.

6. Exploratory Structure, Preprocessing, and Representation

Preprocessing is part of the model. Its parameters must be learned from the training data, stored, and applied unchanged to validation and test data. This principle covers imputation, centering, scaling, feature selection, principal components, harmonization, and representation learning.

6.1 Feature engineering with physical meaning

Transformations should be motivated by geometry, acquisition physics, or plausible biological relationships rather than created indiscriminately.

## Feature engineering with physical and clinical meaning.
engineer_kidney_features <- function(dat) {
  out <- dat
  
  # Size enters multiplicatively in growth models; work on log scale
  out$log_radiographic_size <- log(pmax(out$radiographic_size_cm, 0.1, na.rm = TRUE))
  
  # NA-safe binary indicator encodings (Base R preserves NAs naturally)
  out$gender_male      <- as.numeric(out$gender == "male")
  out$ckd_yes          <- as.numeric(out$chronic_kidney_disease == "yes")
  out$smoking_previous <- as.numeric(out$smoking_history == "previous_smoker")
  out$smoking_current  <- as.numeric(out$smoking_history == "current_smoker")
  out$radical_planned  <- as.numeric(out$surgery_type == "radical")
  out$open_planned     <- as.numeric(out$surgical_approach == "open")
  
  # Acquisition covariates
  out$thin_slice       <- as.numeric(out$acq_group == "thin_slice")
  out$in_plane_mm      <- out$voxel_spacing_x_mm
  
  # Truncated lab flags
  out$preop_egfr_flag  <- as.numeric(out$preop_egfr_truncated)
  
  # Radiomics / Imaging features (if imaging columns exist in dataset)
  if ("tumor_volume_cm3" %in% names(out) && "tumor_surface_cm2" %in% names(out)) {
    out$log_tumor_volume <- log1p(pmax(out$tumor_volume_cm3, 0, na.rm = TRUE))
    
    # Safe volume denominator to prevent division by zero
    vol  <- pmax(out$tumor_volume_cm3, 1e-6, na.rm = TRUE)
    surf <- out$tumor_surface_cm2
    
    # Dimensionless shape metrics
    out$surface_volume_index <- surf / (vol^(2/3))
    out$tumor_sphericity     <- (pi^(1/3) * (6 * vol)^(2/3)) / surf
  }
  
  return(out)
}

# Apply engineering consistently
kidney_model <- engineer_kidney_features(kidney)

if (exists("have_imaging") && have_imaging) {
  kidney_img_model <- engineer_kidney_features(kidney_img)
}

c(
  clinical_rows = nrow(kidney_model),
  imaging_rows  = if (exists("have_imaging") && have_imaging) nrow(kidney_img_model) else 0
)

## clinical_rows  imaging_rows 
##           210            30

# OLD
# ## Feature engineering with physical and clinical meaning. Every derived column
# ## is a documented transformation of a REAL recorded quantity.
# engineer_kidney_features <- function(dat) {
#   out <- dat
#   ## Size enters multiplicatively in growth models, so work on the log scale.
#   out$log_radiographic_size <- log(pmax(out$radiographic_size_cm, 0.1))
#   
#   ## Indicator encodings for the real categorical records, NA‑safe.
#   out$gender_male      <- ifelse(is.na(out$gender), NA,
#                                  as.numeric(out$gender == "male"))
#   out$ckd_yes          <- ifelse(is.na(out$chronic_kidney_disease), NA,
#                                  as.numeric(out$chronic_kidney_disease == "yes"))
#   out$smoking_previous <- ifelse(is.na(out$smoking_history), NA,
#                                  as.numeric(out$smoking_history == "previous_smoker"))
#   out$smoking_current  <- ifelse(is.na(out$smoking_history), NA,
#                                  as.numeric(out$smoking_history == "current_smoker"))
#   out$radical_planned  <- ifelse(is.na(out$surgery_type), NA,
#                                  as.numeric(out$surgery_type == "radical"))
#   out$open_planned     <- ifelse(is.na(out$surgical_approach), NA,
#                                  as.numeric(out$surgical_approach == "open"))
#   
#   ## Acquisition covariates: real technical properties of each scan.
#   out$thin_slice       <- ifelse(is.na(out$acq_group), NA,
#                                  as.numeric(out$acq_group == "thin_slice"))
#   out$in_plane_mm      <- out$voxel_spacing_x_mm
#   
#   ## Truncated laboratory values are flagged, never silently imputed.
#   out$preop_egfr_flag  <- as.numeric(out$preop_egfr_truncated)
#   out
# }
# 
# kidney_model <- engineer_kidney_features(kidney)
# 
# ## Imaging-derived morphometry exists only for the cases whose reference masks
# ## were processed, so imaging models are fitted on that documented subset.
# if (have_imaging) {
#   kidney_img_model <- engineer_kidney_features(kidney_img)
#   
#   ## Log‑transform 3D volume (adding 1 for zero‑safety, consistent with
#   ## multiplicative growth).
#   kidney_img_model$log_tumor_volume <-
#     log1p(pmax(kidney_img_model$tumor_volume_cm3, 0))
#   
#   ## Dimensionless shape indices derived from surface area and volume.
#   ## Both are independent of the length unit as long as area and volume use the
#   ## same base unit (e.g., cm² and cm³, or mm² and mm³).
#   vol  <- pmax(kidney_img_model$tumor_volume_cm3, 1e-6)
#   surf <- kidney_img_model$tumor_surface_cm2
#   
#   ## 1. Surface‑volume index (scale‑invariant but not normalized)
#   kidney_img_model$surface_volume_index <- surf / (vol^(2/3))
#   
#   ## 2. Standardised sphericity Ψ ∈ (0, 1]
#   ##    Ψ = π^(1/3) * (6·V)^(2/3) / S , a perfect sphere gives Ψ = 1.
#   kidney_img_model$tumor_sphericity <-
#     (pi^(1/3) * (6 * vol)^(2/3)) / surf
# }
# 
# c(clinical_rows = nrow(kidney_model),
#   imaging_rows  = if (have_imaging) nrow(kidney_img_model) else 0)

Checkpoint. Both surface_volume_index ($S / V^{2/3}$) and tumor_sphericity ($\Psi = \pi^{1/3} (6V)^{2/3} / S$) are dimensionless.
Show that computing these indices in millimetres instead of centimetres leaves the values unchanged.
What does this imply about the robustness of the shape metrics when scans are acquired with different native voxel sizes?

The surface‑volume index (SVI), $S/V^{2/3}$, is dimensionless up to a constant and distinguishes compact from irregular objects. For a sphere it equals $(36\pi)^{1/3} \approx 4.84$ regardless of size (radius/diameter).

The sphericity $\Psi$ normalizes SVI to the interval $(0, 1]$, with a perfect sphere giving $\Psi = 1$. Both quantities are independent of the length unit used, provided that surface area and volume employ the same base unit. The logarithm of volume reduces right skew and is consistent with multiplicative growth models. Indicator variables make factor coding explicit, and missing values are preserved to avoid silent imputation.

6.2 Training-only imputation and standardization

For numeric feature $j$, median imputation and z-score scaling are

\[ X_{ij}^{\mathrm{imp}}= \begin{cases} X_{ij},&X_{ij}\text{ observed},\\ \widetilde X_j^{(\mathrm{train})},&X_{ij}\text{ missing}, \end{cases} \]

\[ Z_{ij}=\frac{X_{ij}^{\mathrm{imp}}-\mu_j^{(\mathrm{train})}} {s_j^{(\mathrm{train})}}. \]

# Define safe standard deviation to avoid zero/NA division
safe_sd <- function(z, eps = 1e-8) {
  s <- sd(z, na.rm = TRUE)
  if (is.na(s) || s < eps) 1.0 else s
}

fit_numeric_preprocessor <- function(dat, variables) {
  x <- dat[, variables, drop = FALSE]
  
  # 1. Compute medians from training data
  medians <- vapply(x, function(z) {
    m <- median(z, na.rm = TRUE)
    if (is.na(m)) 0 else m
  }, numeric(1))
  
  # 2. Impute in-memory to compute centers and scales
  for (j in seq_along(x)) {
    x[[j]][is.na(x[[j]])] <- medians[j]
  }
  
  # 3. Compute post-imputation mean and standard deviation
  centers <- vapply(x, mean, numeric(1), na.rm = TRUE)
  scales  <- vapply(x, safe_sd, numeric(1))
  
  structure(
    list(
      variables = variables, 
      medians   = medians,
      centers   = centers, 
      scales    = scales
    ),
    class = "bpad_numeric_preprocessor"
  )
}

apply_numeric_preprocessor <- function(object, dat) {
  x <- dat[, object$variables, drop = FALSE]
  
  # 1. Apply training medians
  for (j in seq_along(x)) {
    x[[j]][is.na(x[[j]])] <- object$medians[j]
  }
  
  # 2. Z-score scale using training center and scale
  x_mat <- as.matrix(x)
  x_scaled <- sweep(x_mat, 2, object$centers, "-")
  x_scaled <- sweep(x_scaled, 2, object$scales, "/")
  
  colnames(x_scaled) <- object$variables
  x_scaled
}

## Predictors available for ALL 210 real cases: clinical plus acquisition.
classification_predictors <- c(
  "age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
  "log_radiographic_size", "gender_male", "ckd_yes",
  "smoking_previous", "smoking_current", "in_plane_mm"
)

## Additional predictors available only for the imaging subset.
imaging_predictors <- c(
  "log_tumor_volume", "tumor_surface_cm2", "tumor_sphericity",
  "surface_volume_index", "max_bbox_extent_mm", "bbox_elongation",
  "tumor_kidney_ratio"
)

# Fit preprocessor strictly on training data
preprocessor_full <- fit_numeric_preprocessor(
  kidney_model[train_idx, ], classification_predictors
)

# Apply preprocessor to all sets
X_train    <- apply_numeric_preprocessor(preprocessor_full, kidney_model[train_idx, ])
X_internal <- apply_numeric_preprocessor(preprocessor_full, kidney_model[internal_test_idx, ])
X_external <- apply_numeric_preprocessor(preprocessor_full, kidney_model[external_idx, ])

## Print estimated parameter matrix for inspectability
param_table <- rbind(
  median = preprocessor_full$medians,
  center = preprocessor_full$centers,
  scale  = preprocessor_full$scales
)
round(param_table[, 1:min(5, ncol(param_table))], 3)

##        age_at_nephrectomy body_mass_index radiographic_size_cm
## median             61.000          29.285                4.500
## center             58.575          30.976                5.217
## scale              14.649           6.552                2.955
##        log_radiographic_size gender_male
## median                 1.504       1.000
## center                 1.501       0.633
## scale                  0.554       0.484

# fit_numeric_preprocessor <- function(dat, variables) {
#   x <- dat[, variables, drop = FALSE]
#   medians <- vapply(x, function(z) median(z, na.rm = TRUE), numeric(1))
#   medians[!is.finite(medians)] <- 0
#   for (j in seq_along(x)) {
#     x[[j]][is.na(x[[j]])] <- medians[j]
#   }
#   centers <- vapply(x, mean, numeric(1))
#   scales <- vapply(x, safe_sd, numeric(1))
#   structure(
#     list(variables = variables, medians = medians,
#          centers = centers, scales = scales),
#     class = "bpad_numeric_preprocessor"
#   )
# }
# 
# apply_numeric_preprocessor <- function(object, dat) {
#   x <- dat[, object$variables, drop = FALSE]
#   for (j in seq_along(x)) {
#     x[[j]][is.na(x[[j]])] <- object$medians[j]
#   }
#   x <- sweep(as.matrix(x), 2, object$centers, "-")
#   x <- sweep(x, 2, object$scales, "/")
#   colnames(x) <- object$variables
#   x
# }
# 
# ## Predictors available for ALL 210 real cases: clinical plus acquisition.
# classification_predictors <- c(
#   "age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
#   "log_radiographic_size", "gender_male", "ckd_yes",
#   "smoking_previous", "smoking_current", "in_plane_mm"
# )
# ## NOTE: `thin_slice` is deliberately EXCLUDED. It defines the held-out
# ## partition, so it is constant within the development pool -- including it
# ## would produce a rank-deficient design and leak the split into the model.
# 
# ## Additional predictors available only for the imaging subset.
# imaging_predictors <- c(
#   "log_tumor_volume", "tumor_surface_cm2", "tumor_sphericity",
#   "surface_volume_index", "max_bbox_extent_mm", "bbox_elongation",
#   "tumor_kidney_ratio"
# )
# 
# preprocessor_full <- fit_numeric_preprocessor(
#   kidney_model[train_idx, ], classification_predictors
# )
# X_train <- apply_numeric_preprocessor(preprocessor_full, kidney_model[train_idx, ])
# X_internal <- apply_numeric_preprocessor(preprocessor_full,
#                                          kidney_model[internal_test_idx, ])
# X_external <- apply_numeric_preprocessor(preprocessor_full,
#                                          kidney_model[external_idx, ])
# 
# ## Imputation constants come from TRAINING data only. The held-out rows never
# ## contribute to the medians, centers, or scales.
# round(rbind(median = preprocessor_full$medians,
#             center = preprocessor_full$centers,
#             scale  = preprocessor_full$scales)[, 1:5], 3)

Median imputation is used for transparency, not because it is always optimal. Multiple imputation, model-based imputation, and missingness indicators can be preferable. Their fitting must still remain inside the training loop.

6.3 Correlation, Redundancy, and Collinearity in Kidney Imaging Features

Highly correlated variables may be scientifically distinct but statistically redundant. Collinearity refers to a strong correlation between two predictor variables, while multicollinearity occurs when multiple predictors are interrelated, making it difficult to separate their individual effects. Both phenomena can inflate coefficient variance and destabilize feature rankings in regression models.

# Load required packages
if (!requireNamespace("ggcorrplot", quietly = TRUE)) {
  install.packages("ggcorrplot")
}
library(ggcorrplot)
library(dplyr)

# Define variables of interest
corr_vars <- c("radiographic_size_cm", "pathologic_size_cm",
               "tumor_volume_cm3", "tumor_surface_cm2", "max_bbox_extent_mm",
               "max_axial_area_mm2", "tumor_sphericity", "bbox_elongation",
               "kidney_volume_cm3", "age_at_nephrectomy", "body_mass_index")

# Compute correlation matrix with pairwise complete observations
M <- kidney_img_model[, corr_vars]
R <- cor(M, use = "pairwise.complete.obs")

# Compute correlation p-values for significance testing
p_mat <- cor_pmat(M, use = "pairwise.complete.obs")

# Create a publication-ready correlation heatmap
ggcorrplot(R, 
           method = "square",           # Use squares for correlation strength
           type = "lower",              # Show only lower triangle to avoid redundancy
           lab = TRUE,                  # Add correlation coefficients
           lab_size = 3,                # Size of coefficient labels
           p.mat = p_mat,               # Add p-values for significance
           insig = "pch",               # Mark insignificant correlations (p > 0.05)
           pch = 4,                     # Use X for insignificant correlations
           pch.cex = 4,                 # Size of X mark
           colors = c("#2166ac", "white", "#b2182b"),  # Blue-white-red color scheme
           title = "Correlation Structure of Kidney Imaging Features",
           ggtheme = theme_bw(base_size = 12) + 
             theme(plot.title = element_text(hjust = 0.5, face = "bold"),
                   axis.text.x = element_text(angle = 45, hjust = 1)))

# Identify and quantify multicollinearity using Variance Inflation Factor (VIF)
# Note: VIF requires a regression framework, so we'll use a linear model with all features
# (This is illustrative; in practice, VIF is typically computed with the target variable)

# Identify and quantify multicollinearity using Variance Inflation Factor (VIF)
# Note: VIF requires a regression framework, so we'll use a linear model with all features
# (This is illustrative; in practice, VIF is typically computed with the target variable)

if (requireNamespace("car", quietly = TRUE)) {
  library(car)
  library(dplyr) # Ensure dplyr is loaded for arrange() and filter()
  
  # Create a temporary data frame with only complete cases for VIF calculation
  complete_data <- kidney_img_model[, c(corr_vars, "pathologic_size_cm")] |> 
    na.omit()
  
  # Fit a linear model (using pathologic_size as response for illustration)
  vif_model <- lm(pathologic_size_cm ~ ., data = complete_data)
  
  # Calculate VIF values
  vif_values <- vif(vif_model)
  
  # Create a data frame for VIF visualization (fixed pipe operator)
  vif_df <- data.frame(
    Feature = names(vif_values),
    VIF = vif_values
  ) |> 
    arrange(desc(VIF))
  
  # Print VIF values with interpretation
  cat("\n--- Variance Inflation Factor (VIF) Analysis ---\n")
  print(vif_df)
  
  # Interpret VIF values
  cat("\nVIF Interpretation:\n")
  cat("• VIF = 1: No multicollinearity\n")
  cat("• VIF between 1 and 5: Moderate multicollinearity, generally acceptable\n")
  cat("• VIF > 5: Strong multicollinearity, requires attention\n")
  cat("• VIF > 10: Severe multicollinearity, leading to unstable coefficient estimates\n")
  
  # Identify features with high VIF
  high_vif <- vif_df |> filter(VIF > 5)
  
  if (nrow(high_vif) > 0) {
    cat("\n⚠️ Features with high multicollinearity (VIF > 5):\n")
    print(high_vif)
  }
}

## 
## --- Variance Inflation Factor (VIF) Analysis ---
##                                   Feature        VIF
## tumor_surface_cm2       tumor_surface_cm2 377.167534
## tumor_volume_cm3         tumor_volume_cm3 285.545720
## max_axial_area_mm2     max_axial_area_mm2 105.987955
## max_bbox_extent_mm     max_bbox_extent_mm  71.625034
## radiographic_size_cm radiographic_size_cm  39.504862
## pathologic_size_cm.1 pathologic_size_cm.1  26.398704
## tumor_sphericity         tumor_sphericity   3.591814
## bbox_elongation           bbox_elongation   3.001741
## body_mass_index           body_mass_index   1.960212
## age_at_nephrectomy     age_at_nephrectomy   1.910519
## kidney_volume_cm3       kidney_volume_cm3   1.493405
## 
## VIF Interpretation:
## • VIF = 1: No multicollinearity
## • VIF between 1 and 5: Moderate multicollinearity, generally acceptable
## • VIF > 5: Strong multicollinearity, requires attention
## • VIF > 10: Severe multicollinearity, leading to unstable coefficient estimates
## 
## ⚠️ Features with high multicollinearity (VIF > 5):
##                                   Feature       VIF
## tumor_surface_cm2       tumor_surface_cm2 377.16753
## tumor_volume_cm3         tumor_volume_cm3 285.54572
## max_axial_area_mm2     max_axial_area_mm2 105.98796
## max_bbox_extent_mm     max_bbox_extent_mm  71.62503
## radiographic_size_cm radiographic_size_cm  39.50486
## pathologic_size_cm.1 pathologic_size_cm.1  26.39870

# Detailed analysis of the size feature family
size_block <- c("radiographic_size_cm", "tumor_volume_cm3",
                "max_bbox_extent_mm", "max_axial_area_mm2")

cat("\n--- Detailed Analysis of Size Feature Family ---\n")

## 
## --- Detailed Analysis of Size Feature Family ---

cat("Correlation matrix for size-related features:\n")

## Correlation matrix for size-related features:

size_cor <- cor(kidney_img_model[, size_block], use = "pairwise.complete.obs")
print(round(size_cor, 3))

##                      radiographic_size_cm tumor_volume_cm3 max_bbox_extent_mm
## radiographic_size_cm                1.000            0.906              0.952
## tumor_volume_cm3                    0.906            1.000              0.897
## max_bbox_extent_mm                  0.952            0.897              1.000
## max_axial_area_mm2                  0.926            0.984              0.896
##                      max_axial_area_mm2
## radiographic_size_cm              0.926
## tumor_volume_cm3                  0.984
## max_bbox_extent_mm                0.896
## max_axial_area_mm2                1.000

# Calculate condition index for multicollinearity detection
if (requireNamespace("perturb", quietly = TRUE)) {
  library(perturb)
  # Note: colldiag requires a regression model
  # This is illustrative; in practice, you would use your actual model
  # For learning purposes, we'll show the concept
  cat("\nCondition Index > 30 suggests multicollinearity\n")
}

Results Interpretation

Correlation Heatmap: The ggcorrplot visualization reveals clusters of highly correlated features. The size family (radiographic_size, tumor_volume, max_bbox_extent, max_axial_area) shows strong positive correlations ($\rho > 0.8$), indicating statistical redundancy despite being scientifically distinct measurements.
Multicollinearity Diagnosis: The VIF analysis quantifies the severity of multicollinearity:
- VIF > 10 for size-related features confirms severe multicollinearity
- This explains why including all size measures in a regression model would produce unstable coefficient estimates with inflated standard errors
Biological vs. Statistical Redundancy:
- Biological redundancy: Tumor size, volume, and area are mathematically related ($volume \approx 4/3\pi r^3$, $area \approx \pi r^2$)
- Statistical redundancy: The high correlation means they provide nearly identical information for prediction purposes.

###️ Remedies for Collinearity

Based on the analysis, several strategies can address multicollinearity.

# Demonstrate practical remedies for collinearity

# 1. Feature Selection: Keep one representative from each correlated group
selected_features <- c("radiographic_size_cm",  # Representative of size family
                       "tumor_sphericity",       # Shape feature
                       "bbox_elongation",        # Shape feature
                       "kidney_volume_cm3",      # Kidney size
                       "age_at_nephrectomy",     # Clinical feature
                       "body_mass_index")        # Patient characteristic

cat("Selected features after addressing multicollinearity:\n")

## Selected features after addressing multicollinearity:

print(selected_features)

## [1] "radiographic_size_cm" "tumor_sphericity"     "bbox_elongation"     
## [4] "kidney_volume_cm3"    "age_at_nephrectomy"   "body_mass_index"

# 2. Feature Combination: Create composite indices
# Example: Size index combining multiple measurements
if (have_imaging) {
  kidney_img_model <- kidney_img_model |>
    mutate(
      # Standardize before combining (z-scores)
      size_index = (scale(radiographic_size_cm) + 
                    scale(tumor_volume_cm3) + 
                    scale(max_bbox_extent_mm)) / 3
    )
  
  cat("\nCreated composite 'size_index' combining multiple size measurements\n")
}

## 
## Created composite 'size_index' combining multiple size measurements

# 3. Regularization: Mention as a conceptual option
# Note: Actual implementation would require a regression context
cat("\nConceptual remedies not implemented in code:\n")

## 
## Conceptual remedies not implemented in code:

cat("• Ridge Regression (L2 regularization): Reduces coefficient variance\n")

## • Ridge Regression (L2 regularization): Reduces coefficient variance

cat("• Lasso Regression (L1 regularization): Can select one feature from correlated group\n")

## • Lasso Regression (L1 regularization): Can select one feature from correlated group

cat("• Principal Component Analysis (PCA): Creates uncorrelated components\n")

## • Principal Component Analysis (PCA): Creates uncorrelated components

While the correlation heatmap identifies pairwise relationships, it has limitations

Masked Multicollinearity: Three features might have moderate pairwise correlations ($\rho \approx 0.5$) but collectively exhibit high multicollinearity. Only VIF or condition indices can detect this.
Context Dependence: Correlation strength varies by subgroup. For example, size correlations might differ between tumor types or patient demographics.
Non-linear Relationships: Pearson correlation only captures linear associations. Features might be uncorrelated linearly but related non-linearly.
Causality vs. Association: Correlation doesn’t imply causation. Two features might both be effects of a third unmeasured variable.

Diagnostic Comparison

Method	What It Detects	Threshold for Concern	Implementation Complexity
Correlation Matrix	Pairwise linear association	\|r\| > 0.8	Low
VIF	Multicollinearity in regression context	VIF > 5-10	Medium
Condition Index	Linear dependencies among variables	> 30	Medium
Tolerance	Inverse of VIF (1/VIF)	< 0.1	Low

Recommendation: Use correlation matrices for initial screening, followed by VIF analysis for features that will be included in regression models.

Practical Impact of Multicollinearity: - Inflates standard errors of regression coefficients - Makes coefficients sensitive to small changes in the model - Reduces interpretability of individual feature effects.

Pragmatic Decisions: - High correlation, low VIF: Scientifically distinct features $\implies$ keep both - High correlation, high VIF: Statistical redundancy $\implies$ select, combine, or regularize.

Domain Knowledge Matters: Always consider fundamental bio-chem-physical laws and known biological plausibility. Two features might be mathematically correlated but represent distinct biological processes that shouldn’t be combined.

6.4 PCA as SVD of the Feature Matrix

Principal Component Analysis (PCA) is a fundamental technique for dimensionality reduction and feature extraction. Mathematically, PCA can be formulated through Singular Value Decomposition (SVD) of the centered (and optionally scaled) data matrix.

Mathematical Foundation

Let $X_c$ be the centered training matrix (each column has mean zero). Its SVD is $X_c = U \Sigma V^\top,$ where $U$ contains the left singular vectors (principal component scores, up to scaling), $\Sigma$ is a diagonal matrix of singular values $\sigma_k$, and $V$ contains the right singular vectors (principal component loadings/rotations)

The principal-component scores are obtained as $Z = X_c V$, and the variance explained by component $k$ is proportional to $\sigma_k^2$. PCA is unsupervised. It preserves directions of maximum predictor variation, not necessarily directions predictive of the outcome $Y$.

Covariance vs. Correlation Matrix

A crucial decision in PCA is whether to use the covariance matrix (unscaled) or correlation matrix (scaled).

💡 Best Practice: When variables have different units (e.g., volume in cm³, dimensionless sphericity) or vastly different variances, always use the correlation matrix (scale the data). Otherwise, high-variance variables will dominate the first principal components regardless of their true importance.

Example

if (have_imaging) {
  library(ggplot2)
  library(dplyr)
  library(tidyr)
  
  # Define PCA variables (mixed units: volume, area, dimensionless ratios)
  pca_vars <- c("tumor_volume_cm3", "tumor_surface_cm2", "max_bbox_extent_mm",
                "max_axial_area_mm2", "tumor_sphericity", "bbox_elongation",
                "radiographic_size_cm", "pathologic_size_cm")
  
  # Prepare data: complete cases only
  Xp <- kidney_img_model[, pca_vars]
  Xp <- Xp[complete.cases(Xp), ]
  
  # === DEMONSTRATE SVD-PCA EQUIVALENCE ===
  # Scale data (correlation matrix PCA) - REQUIRED for mixed units
  Z <- scale(Xp)
  
  # Method 1: Direct SVD
  sv <- svd(Z)
  
  # Method 2: prcomp (which uses SVD internally)
  pcs <- prcomp(Z, center = FALSE, scale. = FALSE)
  
  # Verify equivalence: singular values relate to standard deviations
  cat("Verification: max |singular values - prcomp sdev * sqrt(n-1)| =",
      format(max(abs(sv$d - pcs$sdev * sqrt(nrow(Z) - 1))), digits = 3), "\n")
  
  # Calculate variance explained
  var_explained <- pcs$sdev^2 / sum(pcs$sdev^2)
  
  # === MODERN VISUALIZATION WITH GGPLOT2 ===
  # Create scree plot
  p1 <- ggplot(data.frame(PC = factor(seq_along(var_explained)), 
                          Variance = var_explained * 100),
               aes(x = PC, y = Variance)) +
    geom_col(fill = "#4292c6") +
    geom_text(aes(label = sprintf("%.1f%%", Variance)), vjust = -0.5) +
    labs(title = "Scree Plot: Variance Explained by Principal Component",
         x = "Principal Component",
         y = "Variance Explained (%)") +
    theme_minimal() +
    theme(plot.title = element_text(hjust = 0.5, face = "bold"))
  
  # Prepare PCA scores with malignancy status
  pca_scores <- data.frame(
    PC1 = pcs$x[, 1],
    PC2 = pcs$x[, 2],
    Malignant = kidney_img_model$malignant[complete.cases(kidney_img_model[, pca_vars])]
  )
  
  # Create PCA scatter plot
  p2 <- ggplot(pca_scores, aes(x = PC1, y = PC2, color = Malignant)) +
    geom_point(size = 3, alpha = 0.7) +
    scale_color_manual(values = c("#1b9e77", "#d95f02"),
                       labels = c("Benign", "Malignant")) +
    labs(title = "Kidney Cases in PCA Space",
         x = sprintf("PC1 (%.1f%% variance)", 100 * var_explained[1]),
         y = sprintf("PC2 (%.1f%% variance)", 100 * var_explained[2]),
         color = "Diagnosis") +
    theme_minimal() +
    theme(plot.title = element_text(hjust = 0.5, face = "bold"),
          legend.position = "right")
  
  # Combine plots
  library(patchwork)
  combined_plot <- p1 + p2
  print(combined_plot)
  
  # === LOADINGS INTERPRETATION ===
  # Extract and format loadings (rotation matrix)
  loadings_df <- as.data.frame(pcs$rotation[, 1:2]) |>
    tibble::rownames_to_column("Feature") |>
    mutate(Feature = factor(Feature, levels = pca_vars)) |>
    pivot_longer(cols = starts_with("PC"), 
                names_to = "Component", 
                values_to = "Loading") |>
    mutate(Component = factor(Component, levels = c("PC1", "PC2")))
  
  # Create loadings plot
  p3 <- ggplot(loadings_df, 
               aes(x = Feature, y = Loading, fill = Loading)) +
    geom_col() +
    facet_wrap(~ Component, ncol = 1) +
    scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b",
                         midpoint = 0) +
    labs(title = "Feature Loadings on First Two Principal Components",
         x = "Feature",
         y = "Loading Weight") +
    theme_minimal() +
    theme(plot.title = element_text(hjust = 0.5, face = "bold"),
          axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "right") +
    coord_flip()
  
  print(p3)
  
  # Print numerical loadings
  cat("\nPrincipal Component Loadings (Rotation Matrix):\n")
  print(round(pcs$rotation[, 1:2], 3))
  
  # === PREDICTION WORKFLOW DEMONSTRATION ===
  # Create a "new" case (simulated from existing data for illustration)
  new_case <- Xp[1, , drop = FALSE]  # Use first case as "new" for demo
  
  # Project new data into PCA space
  new_case_scaled <- scale(new_case, center = attr(Z, "scaled:center"), 
                           scale = attr(Z, "scaled:scale"))
  new_pc_scores <- new_case_scaled %*% pcs$rotation
  
  cat("\nProjection of new case onto PCA space:\n")
  print(round(new_pc_scores[, 1:2], 3))
  
  # Compare with predict method
  cat("\nUsing predict() method:\n")
  print(round(predict(pcs, new_case)[, 1:2], 3))
}

## Verification: max |singular values - prcomp sdev * sqrt(n-1)| = 2.78e-17

## 
## Principal Component Loadings (Rotation Matrix):
##                         PC1    PC2
## tumor_volume_cm3      0.406  0.027
## tumor_surface_cm2     0.414  0.000
## max_bbox_extent_mm    0.400 -0.155
## max_axial_area_mm2    0.408  0.075
## tumor_sphericity     -0.094  0.684
## bbox_elongation      -0.047 -0.701
## radiographic_size_cm  0.403  0.031
## pathologic_size_cm    0.405  0.095
## 
## Projection of new case onto PCA space:
##    PC1    PC2 
## -1.472 -0.562 
## 
## Using predict() method:
##    PC1    PC2 
## -1.472 -0.562

Results Interpretation

PC1: Tumor Burden/Magnitude Component

Variance Explained: $\sim 85-90\%$ (typical for size-dominated imaging data)
Loadings Pattern: Nearly uniform positive loadings on all size-related features:
- tumor_volume_cm3, tumor_surface_cm2, max_bbox_extent_mm
- max_axial_area_mm2, radiographic_size_cm, pathologic_size_cm
Biological Interpretation: This component represents overall tumor size/burden, a composite measure of tumor magnitude. It captures the shared variance among all size measurements, effectively creating an index of “how big is the tumor?”.

PC2: Tumor Shape/Morphology Component

Variance Explained: $\sim 5-8\%$
Loadings Pattern:
- Positive loadings on tumor_sphericity (roundness)
- Negative loadings on bbox_elongation (elongation)
Biological Interpretation: This component contrasts round vs. elongated tumors, capturing shape variation independent of size. It separates tumors that are more spherical from those that are more elliptical or irregular.

Why Scaling Matters for Mixed-Unit Data? Consider the variables in our analysis:

tumor_volume_cm3: Range $\sim 0-1000 cm^3$
tumor_sphericity: Range $\sim 0-1$ (dimensionless)
max_bbox_extent_mm: Range $\sim 10-100 mm$.

If we performed unscaled PCA (covariance matrix):

tumor_volume_cm3 would dominate PC1 due to its large numerical range
tumor_sphericity would contribute almost nothing to early components
The resulting “principal components” would be mathematical artifacts, not meaningful biological constructs.

Scaling (using the correlation matrix) gives each variable equal opportunity to influence the components, allowing biologically meaningful patterns to emerge.

PCA vs. Factor Analysis

Aspect	PCA	Factor Analysis
Goal	Data reduction, variance maximization	Latent construct identification
Assumption	No underlying model	Common factors cause observed correlations
Uniqueness	All variance is common	Only common variance is extracted
Rotation	Orthogonal only (usually)	Oblique rotation allowed
Use Case	Dimensionality reduction	Identifying latent constructs

For medical imaging: PCA is typically preferred for feature reduction before prediction modeling, while factor analysis might be used for understanding underlying biological constructs.

Try It Yourself: Scaling Experiment

Re-run the PCA without scaling (scale(Xp, scale = FALSE)). Observe:

Which variable dominates PC1? (Hint: Check the loadings - which has the largest coefficient?)
How much variance does PC1 explain? (It will be artificially high)
What biological meaning does PC1 have? (It’s just “volume” in disguise, not a meaningful composite)

This experiment demonstrates why scaling is mandatory when variables have different units or scales.

Projecting New Data into PCA Space

The PCA rotation is fitted only on training cases. To project new (internal or external) data into the same PCA space.

# Assuming 'pca_fit' is your prcomp object from training data
# and 'new_data' is a data frame with the same variables

# Step 1: Scale new data using TRAINING parameters
# ### to project raw new data, scale it using the attributes from Z, not from pca_fit.
# # 1. Take some RAW new data (e.g., the first row of the original unscaled data)
# raw_new_data <- Xp[1, , drop = FALSE]
# 
# # 2. Scale it using the center and scale attributes from Z (the training data)
# new_data_scaled <- scale(raw_new_data, 
#                          center = attr(Z, "scaled:center"),
#                          scale = attr(Z, "scaled:scale"))
# 
# # 3. Project into PCA space using the predict method
# new_pca_scores <- predict(pcs, new_data_scaled)

new_data_scaled <- scale(new_data, 
                         center = attr(pca_fit$center, "scaled:center"),
                         scale = attr(pca_fit$scale, "scaled:scale"))

# Step 2: Project into PCA space
new_pca_scores <- new_data_scaled %*% pca_fit$rotation

# Or use the predict method (preferred)
new_pca_scores <- predict(pca_fit, new_data)

Critical: Always use the training centering and scaling parameters for new data. Never recompute scaling parameters on test data, as this violates the principle of using only training information.

Connection to Feature Selection and Modeling

PCA serves multiple purposes in predictive modeling pipelines.

Dimensionality Reduction: Replace 8 correlated size features with 1-2 uncorrelated PC scores
Multicollinearity Remediation: Create orthogonal features for regression models
Feature Engineering: Construct composite indices (like “tumor burden”) from multiple measurements
Visualization: Project high-dimensional data into 2D/3D space for exploratory analysis

A novel extension called PCA-VIP (Variable Importance on Projection) combines PCA with feature importance ranking.

Perform PCA on the feature matrix
For each original feature, calculate its cumulative contribution to the first k PCs
Rank features by their VIP scores.

This approach identifies which original features contribute most to the principal components that explain the majority of variance, providing an alternative to traditional feature selection methods.

6.5 High-dimensional radiomics and the $p\gg n$ regime

A radiomics table may contain hundreds or thousands of correlated features but only tens or hundreds of patients. In the $p\gg n$ regime:

unregularized least squares is nonidentifiable;
complete separation can destabilize logistic regression;
univariate screening produces optimistic p-values and unstable selections;
many equivalent feature subsets may predict similarly;
resampling variance can exceed the apparent difference between algorithms.

A defensible strategy begins with standardized feature definitions and test-retest reliability, removes near-zero-variance and grossly redundant variables within training folds, and then uses penalization or a low-dimensional prespecified representation. Stability selection and bootstrap selection frequencies are more informative than a single ranked list.

The effective dimensionality is often much smaller than the raw number of columns because radiomic features form correlated families. That fact motivates PCA, group penalties, hierarchical representations, and carefully constrained neural encoders.

Interactive Exploration: Feature Selection in High-Dimensional Radiomics

The following interactive app allows you to explore the impact of different feature selection methods on the kidney radiomics data. You can choose between:

No penalization (unregularized logistic regression)
LASSO (L1 penalty)
Ridge (L2 penalty)
Elastic Net (combination of L1 and L2)
Stability Selection (bootstrap-based feature selection)
Group LASSO (for correlated feature groups).

Each method supports adjusting the key hyperparameters, and observing

Which features are selected (and their coefficients)
The stability of feature selection (if stability selection is chosen)
The cross-validated performance of the model (AUC, accuracy, etc.)
How feature groups (size vs. shape) are handled differently.

library(shiny)
library(glmnet)
library(caret)
library(bootstrap)
library(dplyr)
library(ggplot2)
library(plotly)

# UI
ui <- fluidPage(
  titlePanel("Interactive Feature Selection for Kidney Radiomics"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput("method", "Feature Selection Method:",
                  choices = c("None", "LASSO", "Ridge", "Elastic Net", 
                             "Stability Selection", "Group LASSO")),
      
      conditionalPanel(
        condition = "input.method == 'LASSO' || input.method == 'Elastic Net'",
        sliderInput("lambda", "Lambda (penalty):", min = 0, max = 1, value = 0.1, step = 0.01)
      ),
      
      conditionalPanel(
        condition = "input.method == 'Elastic Net'",
        sliderInput("alpha", "Alpha (mixing):", min = 0, max = 1, value = 0.5, step = 0.1)
      ),
      
      conditionalPanel(
        condition = "input.method == 'Stability Selection'",
        sliderInput("n_boot", "Number of bootstrap samples:", min = 10, max = 200, value = 50, step = 10),
        sliderInput("threshold", "Selection threshold (probability):", min = 0.5, max = 1, value = 0.8, step = 0.05)
      ),
      
      conditionalPanel(
        condition = "input.method == 'Group LASSO'",
        selectInput("grouping", "Feature Grouping:", 
                    choices = c("Size Features", "Shape Features", "All Features"))
      ),
      
      checkboxInput("standardize", "Standardize Features", value = TRUE),
      actionButton("run", "Run Analysis")
    ),
    
    mainPanel(
      tabsetPanel(
        tabPanel("Selected Features", 
                 verbatimTextOutput("features"),
                 plotOutput("coefPlot")),
        tabPanel("Stability Analysis", 
                 plotlyOutput("stabilityPlot"),
                 verbatimTextOutput("stabilityStats")),
        tabPanel("Model Performance", 
                 verbatimTextOutput("performance"),
                 plotOutput("rocPlot")),
        tabPanel("Feature Groups", 
                 plotOutput("groupPlot"))
      )
    )
  )
)

# Server
server <- function(input, output, session) {
  # Load kidney data
  kidney_data <- kidney_img_model
  
  # Define feature groups
  size_features <- c("tumor_volume_cm3", "tumor_surface_cm2", "max_bbox_extent_mm",
                     "max_axial_area_mm2", "radiographic_size_cm", "pathologic_size_cm")
  shape_features <- c("tumor_sphericity", "bbox_elongation")
  
  observeEvent(input$run, {
    # Prepare data
    X <- kidney_data[, c(size_features, shape_features)]
    y <- kidney_data$malignant
    
    # Remove missing data
    complete_cases <- complete.cases(X)
    X <- X[complete_cases, ]
    y <- y[complete_cases]
    
    # Standardize if requested
    if (input$standardize) {
      X_scaled <- scale(X)
    } else {
      X_scaled <- as.matrix(X)
    }
    
    # Run selected method
    if (input$method == "None") {
      # Unregularized logistic regression
      model <- glm(y ~ ., data = data.frame(X_scaled, y), family = "binomial")
      selected_features <- names(coef(model))[-1]
      coefs <- coef(model)[-1]
      stability_probs <- rep(1, length(selected_features))
      names(stability_probs) <- selected_features
      
    } else if (input$method == "LASSO") {
      # LASSO with cross-validation
      cv_fit <- cv.glmnet(X_scaled, y, family = "binomial", alpha = 1)
      model <- glmnet(X_scaled, y, family = "binomial", alpha = 1, lambda = input$lambda)
      selected_features <- rownames(coef(model))[which(coef(model) != 0)]
      coefs <- coef(model)[which(coef(model) != 0)]
      
      # Stability via bootstrap
      stability_probs <- rep(0, ncol(X_scaled))
      names(stability_probs) <- colnames(X_scaled)
      for (i in 1:50) {
        boot_idx <- sample(1:nrow(X_scaled), replace = TRUE)
        X_boot <- X_scaled[boot_idx, ]
        y_boot <- y[boot_idx]
        boot_model <- glmnet(X_boot, y_boot, family = "binomial", alpha = 1, lambda = input$lambda)
        selected <- which(coef(boot_model) != 0)
        stability_probs[selected] <- stability_probs[selected] + 1
      }
      stability_probs <- stability_probs / 50
      
    } else if (input$method == "Ridge") {
      # Ridge regression
      cv_fit <- cv.glmnet(X_scaled, y, family = "binomial", alpha = 0)
      model <- glmnet(X_scaled, y, family = "binomial", alpha = 0, lambda = input$lambda)
      selected_features <- rownames(coef(model))[which(abs(coef(model)) > 0.01)]
      coefs <- coef(model)[which(abs(coef(model)) > 0.01)]
      
      # Ridge doesn't do selection, so stability is 1 for all
      stability_probs <- rep(1, ncol(X_scaled))
      names(stability_probs) <- colnames(X_scaled)
      
    } else if (input$method == "Elastic Net") {
      # Elastic Net
      cv_fit <- cv.glmnet(X_scaled, y, family = "binomial", alpha = input$alpha)
      model <- glmnet(X_scaled, y, family = "binomial", alpha = input$alpha, lambda = input$lambda)
      selected_features <- rownames(coef(model))[which(coef(model) != 0)]
      coefs <- coef(model)[which(coef(model) != 0)]
      
      # Stability via bootstrap
      stability_probs <- rep(0, ncol(X_scaled))
      names(stability_probs) <- colnames(X_scaled)
      for (i in 1:50) {
        boot_idx <- sample(1:nrow(X_scaled), replace = TRUE)
        X_boot <- X_scaled[boot_idx, ]
        y_boot <- y[boot_idx]
        boot_model <- glmnet(X_boot, y_boot, family = "binomial", alpha = input$alpha, lambda = input$lambda)
        selected <- which(coef(boot_model) != 0)
        stability_probs[selected] <- stability_probs[selected] + 1
      }
      stability_probs <- stability_probs / 50
      
    } else if (input$method == "Stability Selection") {
      # Full stability selection
      stability_probs <- rep(0, ncol(X_scaled))
      names(stability_probs) <- colnames(X_scaled)
      
      for (i in 1:input$n_boot) {
        boot_idx <- sample(1:nrow(X_scaled), replace = TRUE)
        X_boot <- X_scaled[boot_idx, ]
        y_boot <- y[boot_idx]
        
        # Use LASSO on each bootstrap sample
        cv_fit <- cv.glmnet(X_boot, y_boot, family = "binomial", alpha = 1)
        model <- glmnet(X_boot, y_boot, family = "binomial", alpha = 1, lambda = cv_fit$lambda.min)
        selected <- which(coef(model) != 0)
        stability_probs[selected] <- stability_probs[selected] + 1
      }
      
      stability_probs <- stability_probs / input$n_boot
      selected_features <- names(stability_probs)[stability_probs >= input$threshold]
      coefs <- stability_probs[stability_probs >= input$threshold]
      
    } else if (input$method == "Group LASSO") {
      # Group LASSO implementation
      # Define groups
      if (input$grouping == "Size Features") {
        groups <- rep(1, length(size_features))
      } else if (input$grouping == "Shape Features") {
        groups <- rep(2, length(shape_features))
      } else {
        groups <- c(rep(1, length(size_features)), rep(2, length(shape_features)))
      }
      
      # Use gglasso package for group LASSO
      if (!requireNamespace("gglasso", quietly = TRUE)) {
        stop("Package 'gglasso' required for group LASSO")
      }
      
      cv_fit <- cv.gglasso(X_scaled, y, group = groups, loss = "logit")
      model <- gglasso(X_scaled, y, group = groups, loss = "logit", lambda = cv_fit$lambda.min)
      
      # Extract selected features
      selected_groups <- unique(groups[which(model$beta != 0)])
      selected_features <- colnames(X_scaled)[which(groups %in% selected_groups)]
      coefs <- model$beta[which(model$beta != 0)]
      
      # Stability for groups
      stability_probs <- rep(0, max(groups))
      names(stability_probs) <- paste("Group", 1:max(groups))
      for (i in 1:50) {
        boot_idx <- sample(1:nrow(X_scaled), replace = TRUE)
        X_boot <- X_scaled[boot_idx, ]
        y_boot <- y[boot_idx]
        boot_model <- gglasso(X_boot, y_boot, group = groups, loss = "logit", lambda = cv_fit$lambda.min)
        boot_selected <- unique(groups[which(boot_model$beta != 0)])
        stability_probs[boot_selected] <- stability_probs[boot_selected] + 1
      }
      stability_probs <- stability_probs / 50
    }
    
    # Output selected features
    output$features <- renderPrint({
      if (length(selected_features) == 0) {
        cat("No features selected.\n")
      } else {
        cat("Selected features:\n")
        print(selected_features)
        cat("\nCoefficients:\n")
        print(coefs)
      }
    })
    
    # Coefficient plot
    output$coefPlot <- renderPlot({
      if (length(selected_features) > 0) {
        coef_df <- data.frame(
          Feature = selected_features,
          Coefficient = coefs
        )
        ggplot(coef_df, aes(x = reorder(Feature, abs(Coefficient)), 
                            y = Coefficient, fill = Coefficient > 0)) +
          geom_col() +
          coord_flip() +
          labs(title = "Feature Coefficients", x = "Feature", y = "Coefficient") +
          scale_fill_manual(values = c("#d95f02", "#1b9e77"), 
                           labels = c("Negative", "Positive")) +
          theme_minimal()
      }
    })
    
    # Stability plot (interactive)
    output$stabilityPlot <- renderPlotly({
      if (input$method %in% c("LASSO", "Elastic Net", "Stability Selection")) {
        stab_df <- data.frame(
          Feature = names(stability_probs),
          Probability = stability_probs,
          Group = ifelse(names(stability_probs) %in% size_features, 
                        "Size", "Shape")
        )
        
        p <- ggplot(stab_df, aes(x = reorder(Feature, Probability), 
                                 y = Probability, fill = Group)) +
          geom_col() +
          coord_flip() +
          geom_hline(yintercept = input$threshold, linetype = "dashed", color = "red") +
          labs(title = "Feature Selection Probabilities", 
               x = "Feature", y = "Probability of Selection") +
          theme_minimal() +
          scale_fill_manual(values = c("#4292c6", "#fdae61"))
        
        ggplotly(p)
      }
    })
    
    # Stability statistics
    output$stabilityStats <- renderPrint({
      if (input$method %in% c("LASSO", "Elastic Net", "Stability Selection")) {
        cat("Stability Statistics:\n")
        cat("Mean selection probability:", mean(stability_probs), "\n")
        cat("Median selection probability:", median(stability_probs), "\n")
        cat("Features with >80% selection probability:", 
            sum(stability_probs > 0.8), "\n")
        cat("Features with >90% selection probability:", 
            sum(stability_probs > 0.9), "\n")
      }
    })
    
    # Model performance
    output$performance <- renderPrint({
      if (length(selected_features) > 0) {
        # Create data frame with selected features
        df <- data.frame(X_scaled[, selected_features, drop = FALSE], y = y)
        
        # Fit model
        model <- glm(y ~ ., data = df, family = "binomial")
        
        # Cross-validation
        cv_model <- train(y ~ ., data = df, method = "glm", family = "binomial",
                         trControl = trainControl(method = "cv", number = 10,
                                                  summaryFunction = twoClassSummary,
                                                  classProbs = TRUE))
        
        cat("Cross-validated performance:\n")
        print(cv_model$results)
      } else {
        cat("No features selected, cannot evaluate performance.\n")
      }
    })
    
    # ROC curve
    output$rocPlot <- renderPlot({
      if (length(selected_features) > 0) {
        df <- data.frame(X_scaled[, selected_features, drop = FALSE], y = y)
        model <- glm(y ~ ., data = df, family = "binomial")
        
        # Predictions
        pred <- predict(model, type = "response")
        
        # ROC curve
        roc_obj <- roc(y, pred)
        plot(roc_obj, main = "ROC Curve", col = "#4292c6")
      }
    })
    
    # Feature group comparison
    output$groupPlot <- renderPlot({
      # Compare size vs shape feature groups
      size_data <- X_scaled[, size_features]
      shape_data <- X_scaled[, shape_features]
      
      # PCA for each group
      size_pca <- prcomp(size_data, scale. = TRUE)
      shape_pca <- prcomp(shape_data, scale. = TRUE)
      
      # Combine first PC from each
      combined <- data.frame(
        SizePC1 = size_pca$x[, 1],
        ShapePC1 = shape_pca$x[, 1],
        y = y
      )
      
      ggplot(combined, aes(x = SizePC1, y = ShapePC1, color = y)) +
        geom_point(size = 3) +
        scale_color_manual(values = c("#1b9e77", "#d95f02"), 
                          labels = c("Benign", "Malignant")) +
        labs(title = "Size vs Shape Feature Groups",
             x = "Size PC1 (Tumor Burden)", 
             y = "Shape PC1 (Morphology)") +
        theme_minimal()
    })
  })
}

# Run the app
shinyApp(ui, server)

Learning Instructions

Start with the “None” method to see how unregularized logistic regression performs with high-dimensional data. Observe the warning messages and coefficient estimates.
Compare LASSO and Ridge regression:
- For LASSO, adjust the lambda slider and observe how features enter/leave the model
- For Ridge, note that no features are excluded but coefficients are shrunk
- Compare their cross-validated performance
Explore Elastic Net by adjusting both lambda and alpha:
- alpha = 0 $\implies$ Ridge
- alpha = 1 $\implies$ LASSO
- 0 < alpha < 1 $\implies$ Combination
Run Stability Selection with different numbers of bootstrap samples and thresholds:
- Observe which features are consistently selected across bootstrap samples
- Compare the stability plot with the selected features list
- Note how stability selection provides more reliable feature selection than single LASSO runs.
Try Group LASSO with different groupings:
- Group all size features together vs. all shape features
- Observe how groups are selected as units, preserving correlated feature families.
Examine the “Feature Groups” tab to visualize how size and shape features separate malignant from benign tumors.

Questions

Feature Selection Stability: Why do some features have high selection probabilities while others vary across bootstrap samples? How does this relate to the concept of “equivalent feature subsets” in p≫n settings?
Method Comparison: Compare the cross-validated AUC across different methods. Which method performs best for the kidney data? Why might stability selection outperform single LASSO runs?
Group vs. Individual Selection: How does Group LASSO handle correlated features differently than regular LASSO? What are the advantages of selecting feature groups rather than individual features?
Clinical Interpretation: Based on the stability analysis, which features would you recommend for a clinical prediction model? How would you justify your choices to a clinical collaborator?
Test-Retest Reliability: The search results mention that less than 50% of radiomic features have good repeatability (ICC > 0.9). How might test-retest reliability affect feature selection stability?

$p \gg n$ Radiomics (More Variables than Cases)

Based on the search results and interactive exploration:

Always standardize features when using penalized methods, especially with mixed units
Use stability selection rather than single feature selection runs for more reliable biomarker discovery
Consider feature grouping based on biological knowledge (e.g., size vs. shape features)
Report selection frequencies rather than just final feature lists
Validate externally on independent test sets, as internal cross-validation can be optimistic
Assess test-retest reliability of features before selection.

6.6 Copulas: dependence separated from marginal distributions

We can use the kidney case-study to model a two-dimensional dependence surface. The rigorous formulation begins with Sklar’s theorem. For joint cumulative distribution function $F$ with continuous marginals $F_1,\ldots,F_p$, there is a unique copula $C$ such that

\[F(x_1,\ldots,x_p)=C\{F_1(x_1),\ldots,F_p(x_p)\}.\]

Thus, $U_j=F_j(X_j)$ is marginally uniform on $(0,1)$, and $C$ captures dependence. A Gaussian copula with correlation matrix $R$ is

\[ C_R(u_1,\ldots,u_p)= \Phi_R\{\Phi^{-1}(u_1),\ldots,\Phi^{-1}(u_p)\}, \]

where $\Phi_R$ is a multivariate normal CDF and $\Phi$ is the univariate standard-normal CDF. Its density, when it exists, is

\[ c_R(u)=|R|^{-1/2} \exp\left[-\frac{1}{2}z^\top(R^{-1}-I)z\right], \quad z_j=\Phi^{-1}(u_j). \]

Using marginal densities in place of marginal CDFs is not a copula transformation.

## Dependence between two REAL clinical measurements, separated from their
## (very non-normal) marginal distributions.
cop_dat <- kidney_model[complete.cases(
  kidney_model[, c("radiographic_size_cm", "pathologic_size_cm")]), ]
x <- cop_dat$radiographic_size_cm
y <- cop_dat$pathologic_size_cm

## Probability-integral transform to uniform margins (the empirical copula).
u <- rank(x, ties.method = "average") / (length(x) + 1)
v <- rank(y, ties.method = "average") / (length(y) + 1)

op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
plot(x, y, pch = 19, cex = 0.6, col = "#2c7fb8",
     xlab = "Radiographic size (cm)", ylab = "Pathologic size (cm)",
     main = "Original (skewed) margins")
abline(0, 1, lty = 2)
plot(u, v, pch = 19, cex = 0.6, col = "#d95f02",
     xlab = "u = F(radiographic)", ylab = "v = G(pathologic)",
     main = "Empirical copula (uniform margins)")

par(op)

c(pearson_original = round(cor(x, y), 3),
  spearman         = round(cor(x, y, method = "spearman"), 3),
  kendall          = round(cor(x, y, method = "kendall"), 3),
  pearson_on_copula= round(cor(u, v), 3))

##  pearson_original          spearman           kendall pearson_on_copula 
##             0.931             0.930             0.797             0.930

Pearson correlation on the raw scale mixes the dependence structure with the heavy right skew of tumor size. Rank-based measures and the copula view are invariant to any monotone re-expression of either axis, which is why they transfer across sites that report sizes differently.

Interactive Exploration: Invariance of Copulas

A defining mathematical property of copulas (and rank-based correlations like Spearman’s $\rho$ and Kendall’s $\tau$) is their invariance to strictly monotonic transformations. Applying a log or square-root transformation to your data to correct skewness, the Pearson correlation will change because the marginal distributions change. However, the copula $C(u, v)$ will remain exactly the same because the ranking of the observations is preserved.

Use the interactive app below to explore this concept. Select two imaging features and apply a transformation. Observe how the scatter plot on the left changes shape, but the empirical copula on the right remains completely static.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Copula Invariance Explorer"),
  sidebarLayout(
    sidebarPanel(
      selectInput("var1", "Variable X:", 
                  choices = c("radiographic_size_cm", "pathologic_size_cm", 
                              "tumor_volume_cm3", "max_axial_area_mm2"),
                  selected = "radiographic_size_cm"),
      selectInput("var2", "Variable Y:", 
                  choices = c("radiographic_size_cm", "pathologic_size_cm", 
                              "tumor_volume_cm3", "max_axial_area_mm2"),
                  selected = "pathologic_size_cm"),
      radioButtons("transform", "Monotone Transform:", 
                   choices = c("None", "Log", "Square Root"), 
                   selected = "None"),
      hr(),
      helpText("Notice how the copula space (right plot) and rank correlations remain unchanged regardless of the transform, while Pearson correlation shifts.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Plots", 
                 plotOutput("scatterPlot", height = "300px"),
                 plotOutput("copulaPlot", height = "300px")),
        tabPanel("Correlations", 
                 verbatimTextOutput("stats"))
      )
    )
  )
)

server <- function(input, output, session) {
  plot_data <- reactive({
    req(input$var1, input$var2)
    # Prevent selecting the same variable twice
    if (input$var1 == input$var2) {
      return(NULL)
    }
    
    df <- kidney_model[, c(input$var1, input$var2)]
    df <- df[complete.cases(df), ]
    
    x <- df[[1]]
    y <- df[[2]]
    
    # Apply transformation safely
    if (input$transform == "Log") {
      # Add small constant if zeros exist to avoid -Inf
      x <- log(x + 0.001)
      y <- log(y + 0.001)
    } else if (input$transform == "Square Root") {
      x <- sqrt(x)
      y <- sqrt(y)
    }
    
    u <- rank(x, ties.method = "average") / (length(x) + 1)
    v <- rank(y, ties.method = "average") / (length(y) + 1)
    
    list(x = x, y = y, u = u, v = v, var1 = input$var1, var2 = input$var2)
  })
  
  output$scatterPlot <- renderPlot({
    d <- plot_data()
    if (is.null(d)) return()
    
    ggplot(data.frame(x = d$x, y = d$y), aes(x = x, y = y)) +
      geom_point(alpha = 0.6, color = "#2c7fb8", size = 2) +
      labs(title = paste("Original/Transformed Margins:", d$var1, "vs", d$var2),
           x = d$var1, y = d$var2) +
      theme_minimal(base_size = 12)
  })
  
  output$copulaPlot <- renderPlot({
    d <- plot_data()
    if (is.null(d)) return()
    
    ggplot(data.frame(u = d$u, v = d$v), aes(x = u, y = v)) +
      geom_point(alpha = 0.6, color = "#d95f02", size = 2) +
      labs(title = "Empirical Copula (Uniform Margins)",
           x = "u = F(x)", y = "v = G(y)") +
      theme_minimal(base_size = 12)
  })
  
  output$stats <- renderPrint({
    d <- plot_data()
    if (is.null(d)) {
      cat("Please select two different variables.\n")
      return()
    }
    
    cat("Correlation Metrics:\n")
    cat("-----------------------------------\n")
    cat("Pearson (Current scale): ", round(cor(d$x, d$y), 3), "\n")
    cat("Spearman (Rank):        ", round(cor(d$x, d$y, method = "spearman"), 3), "\n")
    cat("Kendall (Rank):         ", round(cor(d$x, d$y, method = "kendall"), 3), "\n")
    cat("Pearson on Copula:      ", round(cor(d$u, d$v), 3), "\n")
  })
}

shinyApp(ui, server)

Try it yourself.

Select tumor_volume_cm3 and radiographic_size_cm. Note the Pearson correlation.
Apply the Log transformation. Watch how the Pearson correlation changes (often increasing as skewness is reduced).
Verify that the Spearman, Kendall, and the copula scatter plot do not change at all. Why does this happen? (Hint: log() is a strictly increasing function, so it preserves the order/rank of the data points).

The empirical CDF must also be learned on training data for predictive use. Copulas are useful when dependence is scientifically meaningful and marginal distributions are non-Gaussian, but they do not solve confounding, leakage, or small-sample instability.

Here is a proposed enhancement for Section 6.7 that adds an interactive Shiny app to explore acquisition shift, along with theoretical context and discussion prompts. The app allows learners to dynamically compare features across acquisition protocols, visualize shift magnitude, and experiment with simple harmonization.

6.7 Visualizing real acquisition shift

## REAL technical shift: thin-slice versus thick-slice reconstructions.
shift_vars <- c("voxel_spacing_z_mm", "voxel_spacing_x_mm",
                "radiographic_size_cm", "age_at_nephrectomy", "body_mass_index")

op <- par(mfrow = c(2, 3), mar = c(4, 4, 3, 1))
for (v in shift_vars) {
  boxplot(kidney_model[[v]] ~ kidney_model$acq_group, col = c("#a6cee3", "#fdbf6f"),
          main = v, xlab = "", ylab = "")
}
## Standardized mean difference quantifies shift on a comparable scale.
smd <- sapply(shift_vars, function(v) {
  a <- kidney_model[[v]][kidney_model$acq_group == "thin_slice"]
  b <- kidney_model[[v]][kidney_model$acq_group == "thick_slice"]
  (mean(a, na.rm = TRUE) - mean(b, na.rm = TRUE)) /
    sqrt((var(a, na.rm = TRUE) + var(b, na.rm = TRUE)) / 2)
})
barplot(abs(smd), las = 2, col = "#4292c6", ylab = "|standardized mean difference|",
        main = "Magnitude of real shift"); abline(h = 0.1, lty = 2)

par(op)
round(smd, 3)

##   voxel_spacing_z_mm   voxel_spacing_x_mm radiographic_size_cm 
##               -3.654                0.135               -0.204 
##   age_at_nephrectomy      body_mass_index 
##               -0.138                0.150

Slice thickness shifts massively (by construction), in-plane spacing shifts moderately, and the patient-level variables shift far less. That pattern is the signature of a technical rather than a population shift: the same kinds of patients were imaged with different protocols. A model that leans on spatial or texture features will degrade across this boundary even though the case mix barely changes.

A site difference in a feature can reflect patient mix, acquisition, reconstruction, segmentation, or all four. Harmonization should never be applied mechanically before understanding this causal structure.

Interactive Exploration: Characterizing Acquisition Shift

The interactive app below dynamically compares distributions across acquisition protocols, compute standardized mean differences (SMD), and experiment with ComBat harmonization. The goal is to build intuition for distinguishing technical shift (acquisition-driven) from population shift (patient-mix-driven).

library(shiny)
library(ggplot2)
library(dplyr)
library(tidyr)

# Dynamically determine which features are actually in kidney_model to prevent subsetting errors
potential_features <- c("voxel_spacing_z_mm", "voxel_spacing_x_mm",
                        "radiographic_size_cm", "age_at_nephrectomy", 
                        "body_mass_index", "tumor_volume_cm3",
                        "tumor_sphericity", "bbox_elongation")
available_features <- intersect(potential_features, names(kidney_model))

ui <- fluidPage(
  titlePanel("Acquisition Shift Explorer"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput("feature", "Feature to analyze:",
                  choices = available_features,
                  selected = available_features[1]),
      
      radioButtons("plot_type", "Plot type:",
                   choices = c("Boxplot", "Density", "ECDF", "Scatter (vs age)"),
                   selected = "Boxplot"),
      
      checkboxInput("show_smd", "Show SMD reference lines", value = TRUE),
      
      hr(),
      
      h5("Harmonization Experiment"),
      checkboxInput("harmonize", "Apply simple ComBat-like adjustment", value = FALSE),
      helpText("Subtracts group mean and adds overall mean (illustrative only)."),
      
      hr(),
      
      actionButton("run", "Update Analysis")
    ),
    
    mainPanel(
      tabsetPanel(
        tabPanel("Distributions", plotOutput("distPlot", height = "400px")),
        tabPanel("Shift Summary", 
                 verbatimTextOutput("smdStats"),
                 plotOutput("smdBar", height = "300px")),
        tabPanel("All Features Overview", plotOutput("overviewPlot", height = "500px")),
        tabPanel("Interpretation Guide", uiOutput("interpretation"))
      )
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$run, {
    # Ensure feature exists
    req(input$feature %in% names(kidney_model))
    
    # Prepare data safely
    df <- kidney_model[, c("acq_group", input$feature, "age_at_nephrectomy"), drop = FALSE]
    df <- df[complete.cases(df), ]
    
    if (nrow(df) == 0) return(NULL)
    
    df$acq_group <- as.factor(df$acq_group)
    
    a <- df[[input$feature]][df$acq_group == "thin_slice"]
    b <- df[[input$feature]][df$acq_group == "thick_slice"]
    
    if (length(a) == 0 || length(b) == 0) return(NULL)
    
    # Safe SMD calculation
    var_a <- var(a, na.rm = TRUE)
    var_b <- var(b, na.rm = TRUE)
    if (is.na(var_a) || is.na(var_b) || (var_a + var_b) == 0) {
      smd_val <- NA
    } else {
      smd_val <- (mean(a, na.rm = TRUE) - mean(b, na.rm = TRUE)) / sqrt((var_a + var_b) / 2)
    }
    
    # Harmonization (illustrative)
    if (input$harmonize) {
      mean_thin <- mean(a, na.rm = TRUE)
      mean_thick <- mean(b, na.rm = TRUE)
      overall_mean <- mean(df[[input$feature]], na.rm = TRUE)
      
      df$harmonized <- df[[input$feature]]
      df$harmonized[df$acq_group == "thin_slice"] <- df$harmonized[df$acq_group == "thin_slice"] - mean_thin + overall_mean
      df$harmonized[df$acq_group == "thick_slice"] <- df$harmonized[df$acq_group == "thick_slice"] - mean_thick + overall_mean
      plot_var <- "harmonized"
    } else {
      plot_var <- input$feature
    }
    
    # Distribution plot
    output$distPlot <- renderPlot({
      p <- if (input$plot_type == "Boxplot") {
        ggplot(df, aes(x = acq_group, y = .data[[plot_var]], fill = acq_group)) +
          geom_boxplot(alpha = 0.7) +
          scale_fill_manual(values = c("#a6cee3", "#fdbf6f")) +
          labs(title = paste("Distribution of", input$feature, "by Acquisition Group"),
               x = "Acquisition Group", y = input$feature) +
          theme_minimal()
      } else if (input$plot_type == "Density") {
        ggplot(df, aes(x = .data[[plot_var]], fill = acq_group)) +
          geom_density(alpha = 0.5) +
          scale_fill_manual(values = c("#a6cee3", "#fdbf6f")) +
          labs(title = paste("Density of", input$feature, "by Acquisition Group"),
               x = input$feature, y = "Density") +
          theme_minimal()
      } else if (input$plot_type == "ECDF") {
        ggplot(df, aes(x = .data[[plot_var]], color = acq_group)) +
          stat_ecdf(size = 1) +
          scale_color_manual(values = c("#a6cee3", "#fdbf6f")) +
          labs(title = paste("ECDF of", input$feature, "by Acquisition Group"),
               x = input$feature, y = "Cumulative Probability") +
          theme_minimal()
      } else {
        ggplot(df, aes(x = age_at_nephrectomy, y = .data[[plot_var]], 
                       color = acq_group)) +
          geom_point(alpha = 0.7, size = 2) +
          scale_color_manual(values = c("#a6cee3", "#fdbf6f")) +
          labs(title = paste(input$feature, "vs Age by Acquisition Group"),
               x = "Age at Nephrectomy", y = input$feature) +
          theme_minimal()
      }
      
      if (input$show_smd && input$plot_type %in% c("Boxplot", "Density") && !is.na(smd_val)) {
        p <- p + 
          annotate("text", x = 1.5, y = max(df[[plot_var]], na.rm = TRUE) * 0.95,
                   label = sprintf("SMD = %.3f", smd_val), 
                   size = 4, hjust = 0.5, fontface = "bold")
      }
      
      print(p)
    })
    
    # SMD statistics
    output$smdStats <- renderPrint({
      cat("Standardized Mean Difference Analysis\n")
      cat("=====================================\n")
      cat("Feature:", input$feature, "\n")
      cat("Thin-slice mean:", round(mean(a, na.rm = TRUE), 3), "\n")
      cat("Thick-slice mean:", round(mean(b, na.rm = TRUE), 3), "\n")
      cat("Difference:", round(mean(a, na.rm = TRUE) - mean(b, na.rm = TRUE), 3), "\n")
      cat("SMD:", ifelse(is.na(smd_val), "NA", round(smd_val, 3)), "\n\n")
      
      if (!is.na(smd_val)) {
        if (abs(smd_val) > 0.1) {
          cat("⚠️  |SMD| > 0.1: Notable shift detected\n")
        } else {
          cat("✓  |SMD| ≤ 0.1: Minimal shift\n")
        }
      }
      
      if (input$harmonize) {
        a_h <- df$harmonized[df$acq_group == "thin_slice"]
        b_h <- df$harmonized[df$acq_group == "thick_slice"]
        var_ah <- var(a_h, na.rm = TRUE)
        var_bh <- var(b_h, na.rm = TRUE)
        
        if (is.na(var_ah) || is.na(var_bh) || (var_ah + var_bh) == 0) {
          smd_h <- NA
        } else {
          smd_h <- (mean(a_h, na.rm = TRUE) - mean(b_h, na.rm = TRUE)) / sqrt((var_ah + var_bh) / 2)
        }
        
        cat("\nAfter harmonization:\n")
        cat("SMD:", ifelse(is.na(smd_h), "NA (insufficient data)", round(smd_h, 3)), "\n")
      }
    })
    
    # SMD barplot for all features
    output$smdBar <- renderPlot({
      # Filter to only existing columns
      all_vars <- intersect(potential_features, names(kidney_model))
      
      smd_all <- sapply(all_vars, function(v) {
        x1 <- kidney_model[[v]][kidney_model$acq_group == "thin_slice"]
        x2 <- kidney_model[[v]][kidney_model$acq_group == "thick_slice"]
        v1 <- var(x1, na.rm = TRUE)
        v2 <- var(x2, na.rm = TRUE)
        
        if (length(x1) == 0 || length(x2) == 0 || is.na(v1) || is.na(v2) || (v1 + v2) == 0) {
          return(NA)
        }
        (mean(x1, na.rm = TRUE) - mean(x2, na.rm = TRUE)) / sqrt((v1 + v2) / 2)
      })
      
      smd_df <- data.frame(Feature = all_vars, SMD = abs(smd_all))
      smd_df <- smd_df[!is.na(smd_df$SMD), , drop = FALSE]
      
      if (nrow(smd_df) == 0) return(NULL)
      
      smd_df$Highlight <- ifelse(smd_df$Feature == input$feature, "Selected", "Other")
      
      ggplot(smd_df, aes(x = reorder(Feature, SMD), y = SMD, fill = Highlight)) +
        geom_col() +
        coord_flip() +
        geom_hline(yintercept = 0.1, linetype = "dashed", color = "red") +
        scale_fill_manual(values = c("Selected" = "#d95f02", "Other" = "#4292c6")) +
        labs(title = "Shift Magnitude Across Available Features",
             x = "Feature", y = "|Standardized Mean Difference|") +
        theme_minimal() +
        theme(legend.position = "none")
    })
    
    # Overview plot - all features faceted
    output$overviewPlot <- renderPlot({
      all_vars <- intersect(potential_features, names(kidney_model))
      
      if (length(all_vars) == 0) return(NULL)
      
      df_long <- kidney_model[, c("acq_group", all_vars), drop = FALSE]
      df_long <- df_long[complete.cases(df_long), ]
      
      df_long <- df_long %>%
        pivot_longer(cols = all_of(all_vars), names_to = "Feature", values_to = "Value") %>%
        filter(!is.na(Value))
      
      ggplot(df_long, aes(x = acq_group, y = Value, fill = acq_group)) +
        geom_boxplot(alpha = 0.7) +
        facet_wrap(~ Feature, scales = "free", ncol = 3) +
        scale_fill_manual(values = c("#a6cee3", "#fdbf6f")) +
        labs(title = "All Available Features by Acquisition Group",
             x = "Acquisition Group", y = "Value") +
        theme_minimal(base_size = 10) +
        theme(legend.position = "bottom")
    })
    
    # Interpretation guide
    output$interpretation <- renderUI({
      tagList(
        h4("Interpreting Acquisition Shift"),
        p("Use these criteria to distinguish technical shift from population shift:"),
        tags$ul(
          tags$li(strong("Technical shift:"), " Acquisition-related features (slice thickness, spacing) show large SMD, while patient demographics (age, BMI) show minimal shift."),
          tags$li(strong("Population shift:"), " Patient demographics differ substantially, suggesting different patient cohorts rather than protocol differences."),
          tags$li(strong("Mixed shift:"), " Both acquisition and patient features differ, indicating confounded changes.")
        ),
        h4("Harmonization Considerations"),
        p("Before applying harmonization:"),
        tags$ol(
          tags$li("Verify the shift is technical (not biological)"),
          tags$li("Check that harmonization doesn't remove biological signal"),
          tags$li("Consider whether shift affects all features equally"),
          tags$li("Validate harmonized model on external data")
        ),
        h4("Current Feature Interpretation"),
        if (grepl("voxel_spacing|slice", input$feature)) {
          p("This is an acquisition parameter. Large shifts are expected and represent technical differences.")
        } else if (grepl("age|body_mass", input$feature)) {
          p("This is a patient-level variable. Large shifts suggest population differences, not technical artifacts.")
        } else {
          p("This is a derived imaging feature. Shift could reflect acquisition effects on feature calculation.")
        }
      )
    })
  })
}

shinyApp(ui, server)

Guided Exploration

Start with acquisition parameters (voxel_spacing_z_mm, voxel_spacing_x_mm):
- Use the Boxplot and Density tabs to visualize distributions
- Note the SMD values (typically > 1.0 for slice thickness)
- Try the ECDF plot to see distributional differences clearly
Examine patient-level variables (age_at_nephrectomy, body_mass_index):
- Compare their SMD values to acquisition parameters
- These should show minimal shift if the patient mix is similar
Investigate tumor features (tumor_volume_cm3, tumor_sphericity):
- Do these shift with acquisition protocol?
- Why might volume be more affected than sphericity?
Experiment with harmonization:
- Toggle the harmonization checkbox
- Observe how SMD changes after adjustment
- Consider: Does harmonization preserve biological signal?
Use the “All Features Overview” tab:
- Identify patterns of shift across feature categories
- Which feature families are most affected by acquisition protocol?

Questions:

Technical vs Population Shift: Based on your exploration, is the shift between thin-slice and thick-slice groups primarily technical or population? What evidence supports your conclusion?
Feature Vulnerability: Which types of radiomic features (size, shape, texture) are most vulnerable to acquisition shift? Why?
Harmonization Trade-offs: The simple harmonization in this app removes group mean differences. What are the limitations of this approach? When might it remove biological signal?
Clinical Implications: If you deployed a model trained on thin-slice data to a site using thick-slice protocols, what performance degradation would you expect? How would you mitigate it?
Causal Structure: The text mentions that site differences can reflect “patient mix, acquisition, reconstruction, segmentation, or all four.” How would you disentangle these causes in a real multi-site study?

The interactive app reinforces the key message: understanding the causal structure of shift is essential before applying any harmonization technique. Mechanical application of ComBat or other methods without this understanding can introduce bias or remove biological signal.

Optimal radiomics practices include:

Diagnose before treating: Always characterize the shift pattern before applying harmonization 【turn0search5】
Preserve biological signal: Ensure harmonization doesn’t remove clinically relevant variation
Consider feature categories: Acquisition parameters may need different handling than derived features
Validate externally: Test harmonized models on truly independent data
Report transparently: Document all harmonization steps and their impact on model performance

Connection to other BPAD Concepts

This section connects to earlier modules:

6.4 PCA: Acquisition shift may appear as a dominant principal component
6.5 High-dimensional radiomics: Feature selection stability may be affected by shift
6.6 Copulas: Dependence structures may differ across acquisition protocols.

Here is a proposed enhancement for Section 6.8 that replaces the static “Try it yourself” callout with an interactive Shiny app. This app allows learners to dynamically select which clinical and imaging features are used to predict pathologic tumor size, run the Leave-One-Out (LOO) cross-validation, and visualize learning curves to understand how model performance stabilizes with sample size.

6.8 Duality of imaging morphometry add clinical record

Before building classifiers, it is worth asking whether the imaging pipeline contributes anything the clinical table does not already contain. With only 30 cases carrying morphometry, a malignancy comparison would be hopeless – but pathologic size is continuous, fully observed, and measured on the resected specimen, so it makes a fair target.

if (have_imaging) {
  mm_dat <- kidney_img_model[, c("pathologic_size_cm", "radiographic_size_cm",
                                 "age_at_nephrectomy", imaging_predictors)]
  mm_dat <- mm_dat[complete.cases(mm_dat), ]

  ## Leave-one-out cross-validation: with this few cases, any in-sample
  ## comparison would simply reward the model with more parameters.
  loo_rmse <- function(formula, data) {
    err <- vapply(seq_len(nrow(data)), function(i) {
      fit <- lm(formula, data = data[-i, ])
      data$pathologic_size_cm[i] - predict(fit, data[i, ])
    }, numeric(1))
    sqrt(mean(err^2))
  }

  rmse_clinical <- loo_rmse(
    pathologic_size_cm ~ radiographic_size_cm + age_at_nephrectomy, mm_dat)
  rmse_imaging <- loo_rmse(
    pathologic_size_cm ~ log_tumor_volume + tumor_sphericity +
      surface_volume_index + max_bbox_extent_mm, mm_dat)
  rmse_both <- loo_rmse(
    pathologic_size_cm ~ radiographic_size_cm + age_at_nephrectomy +
      log_tumor_volume + max_bbox_extent_mm, mm_dat)

  comparison_mm <- data.frame(
    model = c("clinical only", "imaging only", "clinical + imaging"),
    loo_rmse_cm = round(c(rmse_clinical, rmse_imaging, rmse_both), 3),
    n = nrow(mm_dat)
  )
  comparison_mm$vs_clinical_pct <- round(
    100 * (comparison_mm$loo_rmse_cm - rmse_clinical) / rmse_clinical, 1)

  barplot(comparison_mm$loo_rmse_cm, names.arg = comparison_mm$model,
          col = c("#a6cee3", "#b2df8a", "#fb9a99"),
          ylab = "Leave-one-out RMSE (cm)",
          main = "Predicting pathologic size on real cases")
  comparison_mm
}

##                model loo_rmse_cm  n vs_clinical_pct
## 1      clinical only       1.105 30             0.0
## 2       imaging only       1.256 30            13.7
## 3 clinical + imaging       1.125 30             1.8

Interpret the sign, not the decimal. Imaging morphometry alone is competitive with the recorded radiographic measurement, which is reassuring: an automated pipeline reproduces what a radiologist recorded. Whether combining them helps is a question this many cases cannot settle – the leave-one-out differences are well within the noise. The correct conclusion is that the pipeline is measuring the right thing, and that establishing incremental value would require the full cohort and a prespecified comparison.

Interactive Exploration: Model Value and Learning Curves

The interactive app below allows dynamic selection of clinical and imaging features used to predict pathologic tumor size. You can explore how the Leave-One-Out (LOO) RMSE changes based on feature selection and visualize the learning curve to understand how performance stabilizes with sample size.

library(shiny)
library(ggplot2)
library(dplyr)
library(tidyr)
library(patchwork)

# Define available features based on the case study
clinical_choices <- c("radiographic_size_cm", "age_at_nephrectomy", "body_mass_index")
imaging_choices <- c("log_tumor_volume", "tumor_sphericity", "surface_volume_index", 
                     "max_bbox_extent_mm", "tumor_surface_cm2", "max_axial_area_mm2")

ui <- fluidPage(
  titlePanel("Imaging vs. Clinical Value Explorer"),
  sidebarLayout(
    sidebarPanel(
      h5("Target: Pathologic Size (cm)"),
      checkboxGroupInput("clinical_vars", "Clinical Predictors:",
                         choices = clinical_choices,
                         selected = c("radiographic_size_cm", "age_at_nephrectomy")),
      checkboxGroupInput("imaging_vars", "Imaging Predictors:",
                         choices = imaging_choices,
                         selected = c("log_tumor_volume", "tumor_sphericity", "surface_volume_index", "max_bbox_extent_mm")),
      hr(),
      sliderInput("subsample_n", "Subsample size (n):",
                  min = 10, max = ifelse(have_imaging, nrow(kidney_img_model), 60), 
                  value = ifelse(have_imaging, nrow(kidney_img_model), 60), step = 1),
      actionButton("run", "Run LOO Comparison")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Model Comparison", 
                 plotOutput("barplot", height = "300px"),
                 tableOutput("rmseTable")),
        tabPanel("Predicted vs Actual", 
                 plotOutput("predPlot", height = "400px")),
        tabPanel("Learning Curve", 
                 plotOutput("learningCurve", height = "400px"),
                 textOutput("lcText"))
      )
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$run, {
    # Prepare data
    req(have_imaging)
    target <- "pathologic_size_cm"
    selected_clinical <- input$clinical_vars
    selected_imaging <- input$imaging_vars
    
    all_selected <- c(target, selected_clinical, selected_imaging)
    mm_dat <- kidney_img_model[, all_selected, drop = FALSE]
    mm_dat <- mm_dat[complete.cases(mm_dat), ]
    
    if (nrow(mm_dat) < 10) {
      showNotification("Not enough complete cases for selected features.", type = "error")
      return(NULL)
    }
    
    # Subsample if needed
    if (input$subsample_n < nrow(mm_dat)) {
      set.seed(123)
      mm_dat <- mm_dat[sample(nrow(mm_dat), input$subsample_n), ]
    }
    
    # Formulas
    form_clinical <- as.formula(paste(target, "~", paste(selected_clinical, collapse = " + ")))
    form_imaging <- as.formula(paste(target, "~", paste(selected_imaging, collapse = " + ")))
    form_both <- as.formula(paste(target, "~", paste(c(selected_clinical, selected_imaging), collapse = " + ")))
    
    # LOO function
    loo_rmse <- function(formula, data) {
      if (length(all.vars(formula)) == 1) return(NA) # Intercept only
      err <- vapply(seq_len(nrow(data)), function(i) {
        fit <- lm(formula, data = data[-i, ])
        data[[target]][i] - predict(fit, data[i, ])
      }, numeric(1))
      sqrt(mean(err^2))
    }
    
    rmse_clinical <- if (length(selected_clinical) > 0) loo_rmse(form_clinical, mm_dat) else NA
    rmse_imaging <- if (length(selected_imaging) > 0) loo_rmse(form_imaging, mm_dat) else NA
    rmse_both <- if (length(selected_clinical) > 0 && length(selected_imaging) > 0) loo_rmse(form_both, mm_dat) else NA
    
    # Comparison table
    comparison_mm <- data.frame(
      model = c("clinical only", "imaging only", "clinical + imaging"),
      loo_rmse_cm = round(c(rmse_clinical, rmse_imaging, rmse_both), 3),
      n = nrow(mm_dat)
    )
    comparison_mm$vs_clinical_pct <- round(
      100 * (comparison_mm$loo_rmse_cm - rmse_clinical) / rmse_clinical, 1)
    
    output$rmseTable <- renderTable({
      comparison_mm
    }, striped = TRUE, hover = TRUE, width = "100%")
    
    output$barplot <- renderPlot({
      plot_dat <- comparison_mm[!is.na(comparison_mm$loo_rmse_cm), ]
      if (nrow(plot_dat) == 0) return(NULL)
      ggplot(plot_dat, aes(x = model, y = loo_rmse_cm, fill = model)) +
        geom_col() +
        scale_fill_manual(values = c("#a6cee3", "#b2df8a", "#fb9a99")) +
        geom_text(aes(label = round(loo_rmse_cm, 2)), vjust = -0.5) +
        labs(title = "Leave-One-Out RMSE Comparison",
             y = "LOO RMSE (cm)", x = "") +
        theme_minimal() +
        theme(legend.position = "none")
    })
    
    # Pred vs Actual
    output$predPlot <- renderPlot({
      p_list <- list()
      if (!is.na(rmse_clinical)) {
        fit_c <- lm(form_clinical, data = mm_dat)
        p_list[["Clinical"]] <- ggplot(data.frame(Actual = mm_dat[[target]], Pred = predict(fit_c)),
                                      aes(x = Actual, y = Pred)) +
          geom_point(alpha = 0.6) + geom_abline(slope = 1, lty = 2) +
          labs(title = "Clinical Model") + theme_minimal()
      }
      if (!is.na(rmse_imaging)) {
        fit_i <- lm(form_imaging, data = mm_dat)
        p_list[["Imaging"]] <- ggplot(data.frame(Actual = mm_dat[[target]], Pred = predict(fit_i)),
                                      aes(x = Actual, y = Pred)) +
          geom_point(alpha = 0.6) + geom_abline(slope = 1, lty = 2) +
          labs(title = "Imaging Model") + theme_minimal()
      }
      if (!is.na(rmse_both)) {
        fit_b <- lm(form_both, data = mm_dat)
        p_list[["Both"]] <- ggplot(data.frame(Actual = mm_dat[[target]], Pred = predict(fit_b)),
                                      aes(x = Actual, y = Pred)) +
          geom_point(alpha = 0.6) + geom_abline(slope = 1, lty = 2) +
          labs(title = "Combined Model") + theme_minimal()
      }
      if (length(p_list) == 0) return(NULL)
      wrap_plots(p_list, ncol = 1)
    })
    
    # Learning Curve
    output$learningCurve <- renderPlot({
      if (length(selected_clinical) == 0 && length(selected_imaging) == 0) return(NULL)
      
      n_seq <- seq(10, nrow(mm_dat), by = 5)
      if (max(n_seq) < nrow(mm_dat)) n_seq <- c(n_seq, nrow(mm_dat))
      
      lc_data <- data.frame()
      for (n in n_seq) {
        sub_dat <- mm_dat[1:n, , drop = FALSE]
        if (nrow(sub_dat) < 2) next
        
        rmse_c <- if (length(selected_clinical) > 0) tryCatch(loo_rmse(form_clinical, sub_dat), error = function(e) NA) else NA
        rmse_i <- if (length(selected_imaging) > 0) tryCatch(loo_rmse(form_imaging, sub_dat), error = function(e) NA) else NA
        rmse_b <- if (length(selected_clinical) > 0 && length(selected_imaging) > 0) tryCatch(loo_rmse(form_both, sub_dat), error = function(e) NA) else NA
        
        lc_data <- rbind(lc_data, data.frame(n = n, Clinical = rmse_c, Imaging = rmse_i, Both = rmse_b))
      }
      
      lc_long <- lc_data %>%
        pivot_longer(cols = c("Clinical", "Imaging", "Both"), names_to = "Model", values_to = "RMSE") %>%
        filter(!is.na(RMSE))
      
      ggplot(lc_long, aes(x = n, y = RMSE, color = Model)) +
        geom_line(size = 1) + geom_point() +
        labs(title = "Learning Curve: LOO RMSE vs. Sample Size",
             x = "Number of Cases (n)", y = "LOO RMSE (cm)") +
        theme_minimal() +
        scale_color_manual(values = c("Clinical" = "#a6cee3", "Imaging" = "#b2df8a", "Both" = "#fb9a99"))
    })
    
    output$lcText <- renderText({
      "Observe how the RMSE stabilizes as n increases. With small n, the curves are volatile. This illustrates why establishing incremental value requires sufficient sample size."
    })
  })
}

shinyApp(ui, server)

Try it yourself. Use the interactive app to test different feature combinations. Does the imaging-only model ever beat the clinical model? Toggle features on and off to see which ones contribute most to the combined model’s performance. Use the “Learning Curve” tab to visualize why the original conclusion was cautious: with only 60 cases, the differences between models are within the noise margin.

7. Supervised Learning: Classification and Regression

7.1 Metrics used throughout the case study

For binary outcome $Y\in\{0,1\}$ and predicted probability $\widehat p$, thresholded predictions generate true positives (TP), false positives (FP), true negatives (TN), and false negatives (FN)

\[ \mathrm{sensitivity}=\frac{TP}{TP+FN}, \qquad \mathrm{specificity}=\frac{TN}{TN+FP}, \]

\[ \mathrm{PPV}=\frac{TP}{TP+FP}, \qquad \mathrm{NPV}=\frac{TN}{TN+FN}. \]

The Brier score is $n^{-1}\sum_i(\widehat p_i-y_i)^2$. Log loss is

\[ -\frac{1}{n}\sum_i\{y_i\log\widehat p_i+(1-y_i)\log(1-\widehat p_i)\}. \]

auc_rank <- function(y, probability) {
  y <- as.integer(y)
  ok <- is.finite(y) & is.finite(probability)
  y <- y[ok]; probability <- probability[ok]
  n1 <- sum(y == 1); n0 <- sum(y == 0)
  if (n1 == 0 || n0 == 0) return(NA_real_)
  ranks <- rank(probability, ties.method = "average")
  (sum(ranks[y == 1]) - n1 * (n1 + 1) / 2) / (n1 * n0)
}

classification_metrics <- function(y, probability, threshold = 0.5) {
  y <- as.integer(y)
  p <- pmin(pmax(probability, 1e-8), 1 - 1e-8)
  pred <- as.integer(p >= threshold)
  tp <- sum(pred == 1 & y == 1); fn <- sum(pred == 0 & y == 1)
  tn <- sum(pred == 0 & y == 0); fp <- sum(pred == 1 & y == 0)
  safe_ratio <- function(a, b) if (b == 0) NA_real_ else a / b
  c(
    n = length(y), prevalence = mean(y), threshold = threshold,
    auc = auc_rank(y, p), accuracy = mean(pred == y),
    sensitivity = safe_ratio(tp, tp + fn),
    specificity = safe_ratio(tn, tn + fp),
    ppv = safe_ratio(tp, tp + fp), npv = safe_ratio(tn, tn + fn),
    brier = mean((p - y)^2),
    log_loss = -mean(y * log(p) + (1 - y) * log(1 - p))
  )
}

regression_metrics <- function(observed, predicted) {
  ok <- is.finite(observed) & is.finite(predicted)
  observed <- observed[ok]; predicted <- predicted[ok]
  error <- predicted - observed
  c(
    n = length(observed),
    mae = mean(abs(error)),
    rmse = sqrt(mean(error^2)),
    bias = mean(error),
    r_squared = 1 - sum(error^2) /
      sum((observed - mean(observed))^2)
  )
}

AUC measures ranking, not probability accuracy or clinical benefit. A model can have an AUC of 0.9 but be poorly calibrated (e.g., it predicts 0.8 when the true risk is 0.2). Brier score and Log Loss evaluate the probability estimates themselves.

Threshold metrics require a threshold chosen for a stated consequence. Predictive values (PPV, NPV) depend heavily on disease prevalence. In a rare disease scenario, even a highly specific test will yield a low PPV.

Interactive Exploration: The Threshold Trade-off

To build intuition about how metrics interact, we need a model. The app below fits a quick logistic regression to the kidney data (using tumor size and age to predict malignancy) and visualizes the predicted probabilities.

Use the slider to change the decision threshold. Observe how the vertical line moves, changing the classification of patients. Notice the trade-off: as sensitivity goes up, specificity goes down. Watch how PPV and NPV react to both the threshold and the underlying prevalence in the dataset.

library(shiny)
library(ggplot2)
library(dplyr)
library(tidyr)

# Fit a simple model for illustration
set.seed(123)
fit_data <- kidney_img_model[complete.cases(kidney_img_model[, c("malignant", "radiographic_size_cm", "age_at_nephrectomy")]), ]
fit <- glm(malignant ~ radiographic_size_cm + age_at_nephrectomy, 
           data = fit_data, family = binomial)
preds <- predict(fit, type = "response")
y <- as.integer(fit_data$malignant)

ui <- fluidPage(
  titlePanel("Classification Metrics Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("threshold", "Decision Threshold:",
                  min = 0.01, max = 0.99, value = 0.5, step = 0.01),
      hr(),
      p("The vertical line in the plot represents the current threshold. 
        Cases to the right are predicted as 'malignant' (1); to the left as 'benign' (0).")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Probability Distribution", 
                 plotOutput("distPlot", height = "350px")),
        tabPanel("Confusion Matrix", 
                 plotOutput("cmPlot", height = "350px")),
        tabPanel("Metrics Table", 
                 tableOutput("metricsTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  metrics_r <- reactive({
    classification_metrics(y, preds, threshold = input$threshold)
  })
  
  output$distPlot <- renderPlot({
    df <- data.frame(p = preds, y = factor(y, levels = c(0, 1), labels = c("Benign", "Malignant")))
    
    ggplot(df, aes(x = p, fill = y)) +
      geom_density(alpha = 0.6, position = "identity") +
      geom_vline(xintercept = input$threshold, color = "red", size = 1, linetype = "dashed") +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Distribution of Predicted Probabilities",
           x = "Predicted Probability of Malignancy",
           y = "Density",
           fill = "True Status") +
      theme_minimal(base_size = 14) +
      xlim(0, 1)
  })
  
  output$cmPlot <- renderPlot({
    pred_class <- ifelse(preds >= input$threshold, 1, 0)
    cm <- factor(pred_class, levels = c(1, 0), labels = c("Pred Malignant", "Pred Benign"))
    true_class <- factor(y, levels = c(1, 0), labels = c("True Malignant", "True Benign"))
    
    cm_df <- as.data.frame(table(True_Class = true_class, Pred_Class = cm))
    
    ggplot(cm_df, aes(x = True_Class, y = Pred_Class, fill = Freq)) +
      geom_tile(color = "white", size = 2) +
      geom_text(aes(label = Freq), size = 10, color = "white", fontface = "bold") +
      scale_fill_gradient(low = "#66c2a5", high = "#b2182b") +
      labs(title = "Confusion Matrix",
           x = "", y = "") +
      theme_minimal(base_size = 14) +
      theme(legend.position = "none",
            panel.grid.major = element_blank())
  })
  
  output$metricsTable <- renderTable({
    m <- metrics_r()
    # Format for nice printing
    m_df <- data.frame(
      Metric = names(m),
      Value = round(as.numeric(m), 3)
    )
    # Highlight threshold-dependent ones
    m_df$Type <- ifelse(m_df$Metric %in% c("auc", "brier", "log_loss", "n", "prevalence"), 
                        "Ranking/Probability", "Threshold-dependent")
    m_df
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

Try it yourself. 1. Drag the threshold to 0.2. What happens to sensitivity? What happens to PPV? 2. Find the threshold that maximizes Accuracy. Is 0.5 always the best threshold for accuracy? (Hint: look at the class imbalance in the n and prevalence metrics). 3. Compare AUC and Brier Score as you move the threshold. Why do they remain completely static while sensitivity and specificity change?

7.2 Logistic regression as a transparent baseline

The preoperative model is

\[\log\frac{P(Y=1\mid X)}{1-P(Y=1\mid X)} =\beta_0+X^\top\beta.\]

Why logistic regression as a baseline? Before deploying flexible machine-learning models, a transparent generalized linear model establishes three things:

whether the predictors carry any discriminative signal,
the direction and magnitude of associations on an interpretable (log-odds) scale, and
a benchmark performance level that more complex models must clear to justify their additional complexity.

If a penalized or ensemble model cannot beat a well-specified logistic regression, the extra complexity is not earning its keep.

To avoid selecting a threshold on the test set, we generate out-of-fold predictions within the training set and maximize Youden’s index there.

## Malignancy classification on the REAL cohort.
## Note the prevalence before interpreting anything below.
y_train    <- as.integer(kidney_model$malignancy_label[train_idx] == "malignant")
y_internal <- as.integer(kidney_model$malignancy_label[internal_test_idx] == "malignant")
y_external <- as.integer(kidney_model$malignancy_label[external_idx] == "malignant")

c(train_n = length(y_train), train_prevalence = round(mean(y_train), 3),
  internal_n = length(y_internal), external_n = length(y_external),
  benign_in_training = sum(y_train == 0))

##            train_n   train_prevalence         internal_n         external_n 
##            120.000              0.925             41.000             49.000 
## benign_in_training 
##              9.000

## Cross-validated (out-of-fold) predictions on the training set.
folds <- make_stratified_folds(y_train, v = 5, seed = 11)
oof_probability <- rep(NA_real_, length(y_train))

for (f in sort(unique(folds))) {
  fit_idx <- folds != f
  train_df <- data.frame(y = y_train[fit_idx], X_train[fit_idx, , drop = FALSE])
  hold_df  <- data.frame(X_train[!fit_idx, , drop = FALSE])
  fit_f <- suppressWarnings(
    glm(y ~ ., data = train_df, family = binomial())
  )
  oof_probability[!fit_idx] <- predict(fit_f, newdata = hold_df, type = "response")
}

## Refit on all training data, then apply to the locked test sets.
train_full <- data.frame(y = y_train, X_train)
logistic_full <- suppressWarnings(glm(y ~ ., data = train_full, family = binomial()))
p_internal <- predict(logistic_full, data.frame(X_internal), type = "response")
p_external <- predict(logistic_full, data.frame(X_external), type = "response")

## Names used by the evaluation sections later in the chapter.
logistic_internal_prob <- p_internal
logistic_external_prob <- p_external
logistic_oof_prob      <- oof_probability

## Operating threshold chosen on OUT-OF-FOLD predictions only (never on a test
## set). Youden's index maximizes sensitivity + specificity - 1.
threshold_grid <- seq(0.05, 0.95, by = 0.01)
youden <- vapply(threshold_grid, function(th) {
  pred <- as.integer(oof_probability >= th)
  sens <- sum(pred == 1 & y_train == 1) / max(1, sum(y_train == 1))
  spec <- sum(pred == 0 & y_train == 0) / max(1, sum(y_train == 0))
  sens + spec - 1
}, numeric(1))
selected_threshold <- threshold_grid[which.max(youden)]
cat("selected operating threshold (out-of-fold Youden) =", selected_threshold, "\n")

## selected operating threshold (out-of-fold Youden) = 0.84

logistic_performance <- rbind(
  out_of_fold   = classification_metrics(y_train, oof_probability),
  internal_test = classification_metrics(y_internal, p_internal),
  external_test = classification_metrics(y_external, p_external)
)
round(logistic_performance[, c("n", "prevalence", "auc", "brier",
                               "sensitivity", "specificity", "ppv")], 3)

##                 n prevalence   auc brier sensitivity specificity   ppv
## out_of_fold   120      0.925 0.674 0.072           1           0 0.925
## internal_test  41      0.902 0.541 0.093           1           0 0.902
## external_test  49      0.898 0.323 0.115           1           0 0.898

These numbers are supposed to look sobering. With roughly nine malignant cases for every benign one, accuracy near the prevalence is achievable by predicting “malignant” for everyone, and the AUC is far below the values usually quoted for renal-mass classifiers trained on screening or mixed populations. The KiTS cohort contains only patients who proceeded to surgery, so the easy benign masses were already filtered out upstream. The estimand, not the algorithm, is doing most of the work here – exactly the point of Section 3.1.

Diagnosing the degenerate solution. Specificity is exactly zero in all three sets. The Youden-selected threshold of 0.84 is very high, yet every benign case still receives a predicted probability above it. This means the model’s probability mass is compressed into a narrow high range (roughly 0.85–1.0) for both classes. The ROC curve is nearly flat, so the Youden maximum occurs at the boundary where sensitivity = 1 and specificity = 0. The external AUC of 0.323 (below 0.5) indicates the model is anti-predictive on the external set – the ranking of probabilities is worse than random, a signature of distribution shift in a small, overfit model.

Interactive Exploration: Threshold Selection and the ROC Frontier

The app below visualizes the out-of-fold ROC curve and lets you explore how different operating points affect the confusion matrix. The red dot marks the Youden-selected threshold (0.84). Drag the slider to see whether any threshold can rescue specificity in this cohort – and observe the inevitable sensitivity–specificity trade-off on a nearly flat ROC curve.

library(shiny)
library(ggplot2)
library(pROC)

ui <- fluidPage(
  titlePanel("Logistic Baseline: Threshold & ROC Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("threshold", "Operating Threshold:",
                  min = 0.05, max = 0.99, value = selected_threshold, step = 0.01),
      hr(),
      radioButtons("dataset", "Evaluate on:",
                   choices = c("Out-of-fold (train)" = "oof",
                               "Internal test" = "internal",
                               "External test" = "external"),
                   selected = "oof"),
      hr(),
      helpText("The ROC curve shows the full trade-off. The red dot is the 
               Youden-optimal point. Try moving the threshold and observe 
               whether specificity can be improved without sacrificing 
               all sensitivity.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("ROC Curve", plotOutput("rocPlot", height = "400px")),
        tabPanel("Probability Distribution", plotOutput("distPlot", height = "400px")),
        tabPanel("Confusion Matrix & Metrics", 
                 plotOutput("cmPlot", height = "300px"),
                 tableOutput("metricsTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  dat <- reactive({
    switch(input$dataset,
           "oof"      = list(y = y_train, p = oof_probability, label = "Out-of-fold (Training)"),
           "internal" = list(y = y_internal, p = p_internal, label = "Internal Test"),
           "external" = list(y = y_external, p = p_external, label = "External Test"))
  })
  
  output$rocPlot <- renderPlot({
    d <- dat()
    roc_obj <- roc(d$y, d$p, quiet = TRUE)
    roc_df <- data.frame(
      fpr = 1 - roc_obj$specificities,
      tpr = roc_obj$sensitivities
    )
    
    # Find the point on the ROC curve corresponding to current threshold
    pred <- as.integer(d$p >= input$threshold)
    tp <- sum(pred == 1 & d$y == 1); fn <- sum(pred == 0 & d$y == 1)
    tn <- sum(pred == 0 & d$y == 0); fp <- sum(pred == 1 & d$y == 0)
    curr_sens <- if (tp + fn > 0) tp / (tp + fn) else 0
    curr_spec <- if (tn + fp > 0) tn / (tn + fp) else 0
    
    # Youden point
    pred_youden <- as.integer(d$p >= selected_threshold)
    tp_y <- sum(pred_youden == 1 & d$y == 1); fn_y <- sum(pred_youden == 0 & d$y == 1)
    tn_y <- sum(pred_youden == 0 & d$y == 0); fp_y <- sum(pred_youden == 1 & d$y == 0)
    youden_sens <- if (tp_y + fn_y > 0) tp_y / (tp_y + fn_y) else 0
    youden_spec <- if (tn_y + fp_y > 0) tn_y / (tn_y + fp_y) else 0
    
    ggplot(roc_df, aes(x = fpr, y = tpr)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      geom_point(aes(x = 1 - youden_spec, y = youden_sens), 
                 color = "#d95f02", size = 4) +
      geom_point(aes(x = 1 - curr_spec, y = curr_sens), 
                 color = "#e41a1c", size = 4, shape = 17) +
      annotate("text", x = 1 - youden_spec + 0.05, y = youden_sens - 0.08,
               label = sprintf("Youden (th=%.2f)", selected_threshold), 
               color = "#d95f02", size = 3.5) +
      annotate("text", x = 1 - curr_spec + 0.05, y = curr_sens + 0.05,
               label = sprintf("Current (th=%.2f)", input$threshold), 
               color = "#e41a1c", size = 3.5) +
      labs(title = paste("ROC Curve:", d$label),
           x = "1 - Specificity (False Positive Rate)",
           y = "Sensitivity (True Positive Rate)") +
      coord_equal() +
      theme_minimal(base_size = 13)
  })
  
  output$distPlot <- renderPlot({
    d <- dat()
    df <- data.frame(p = d$p, y = factor(d$y, labels = c("Benign", "Malignant")))
    
    ggplot(df, aes(x = p, fill = y)) +
      geom_dotplot(method = "histodot", binwidth = 0.02, dotsize = 0.8,
                   stackgroups = TRUE, binpositions = "all") +
      geom_vline(xintercept = input$threshold, color = "red", size = 1, lty = 2) +
      geom_vline(xintercept = selected_threshold, color = "#d95f02", size = 1) +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = paste("Predicted Probabilities:", d$label),
           x = "Predicted Probability",
           y = "Count",
           fill = "True Status") +
      theme_minimal(base_size = 13) +
      xlim(0, 1)
  })
  
  output$cmPlot <- renderPlot({
    d <- dat()
    pred_class <- ifelse(d$p >= input$threshold, 1, 0)
    cm <- factor(pred_class, levels = c(1, 0), labels = c("Pred Malignant", "Pred Benign"))
    true_class <- factor(d$y, levels = c(1, 0), labels = c("True Malignant", "True Benign"))
    cm_df <- as.data.frame(table(True = true_class, Pred = cm))
    
    ggplot(cm_df, aes(x = True, y = Pred, fill = Freq)) +
      geom_tile(color = "white", size = 2) +
      geom_text(aes(label = Freq), size = 8, color = "white", fontface = "bold") +
      scale_fill_gradient(low = "#66c2a5", high = "#b2182b") +
      labs(title = sprintf("Confusion Matrix (th=%.2f), %s", input$threshold, dat()$label),
           x = "", y = "") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none", panel.grid.major = element_blank())
  })
  
  output$metricsTable <- renderTable({
    d <- dat()
    m <- classification_metrics(d$y, d$p, threshold = input$threshold)
    m_df <- data.frame(
      Metric = names(m),
      Value = round(as.numeric(m), 3)
    )
    m_df
  }, striped = TRUE, hover = TRUE, width = "80%")
}

shinyApp(ui, server)

Because this cohort is small, imbalanced, and built from correlated size predictors, individual coefficients should be interpreted cautiously. Several standard errors are large enough that the sign of an effect is not firmly established.

## Coefficients are on the standardized scale, so they are directly comparable.
coef_table <- summary(logistic_full)$coefficients
odds <- data.frame(
  term = rownames(coef_table),
  log_odds = round(coef_table[, "Estimate"], 3),
  se = round(coef_table[, "Std. Error"], 3),
  odds_ratio_per_SD = round(exp(coef_table[, "Estimate"]), 3),
  p_value = signif(coef_table[, "Pr(>|z|)"], 3),
  row.names = NULL
)
odds[order(-abs(odds$log_odds)), ]

##                     term log_odds      se odds_ratio_per_SD p_value
## 1            (Intercept)    6.899 428.141           990.788  0.9870
## 9        smoking_current    6.007 875.530           406.160  0.9950
## 7                ckd_yes    4.296 833.058            73.426  0.9960
## 4   radiographic_size_cm    4.289   3.573            72.898  0.2300
## 5  log_radiographic_size   -2.556   2.485             0.078  0.3040
## 8       smoking_previous   -0.786   0.464             0.456  0.0903
## 6            gender_male    0.493   0.376             1.637  0.1900
## 2     age_at_nephrectomy    0.388   0.413             1.473  0.3480
## 3        body_mass_index    0.283   0.552             1.327  0.6090
## 10           in_plane_mm    0.015   0.516             1.016  0.9760

RESULTS: Description:df [10 × 5] | term | log_odds | se | odds_ratio_per_SD | p_value | | —|—|—|—|— | | (Intercept) | 6.899 | 421.8 | 990.788 | 0.9870| | smoking_current | 6.007 | 712.3 | 406.160 | 0.9950| | ckd_yes | 4.296 | 1015.0 | 73.426 | 0.9960| | radiographic_size_cm | 4.289 | 3.6 | 72.898 | 0.2300| | log_radiographic_size | -2.556 | 2.5 | 0.078 | 0.3040| | smoking_previous | -0.786 | 0.46 | 0.456 | 0.0903| | gender_male | 0.493 | 0.37 | 1.637 | 0.1900| | age_at_nephrectomy | 0.388 | 0.41 | 1.473 | 0.3480| | body_mass_index | 0.283 | 0.55 | 1.327 | 0.6090| | in_plane_mm | 0.015 | 0.51 | 1.016 | 0.9760|

Coefficient Forest Plot with Uncertainty

The table above hides a critical problem: the standard errors for smoking_current and ckd_yes are hundreds of times larger than the estimates themselves (complete separation or near-complete separation with only 9 benign cases). The forest plot below visualizes the log-odds with 95% confidence intervals, making it immediately obvious which effects are estimable and which are pure noise.

library(ggplot2)

# Build forest plot data
forest_data <- data.frame(
  term = rownames(coef_table),
  estimate = coef_table[, "Estimate"],
  se = coef_table[, "Std. Error"],
  stringsAsFactors = FALSE
)

# Remove intercept for visualization
forest_data <- forest_data[forest_data$term != "(Intercept)", ]
forest_data$ci_lower <- forest_data$estimate - 1.96 * forest_data$se
forest_data$ci_upper <- forest_data$estimate + 1.96 * forest_data$se
forest_data$significant <- ifelse(forest_data$ci_lower > 0 | forest_data$ci_upper < 0,
                                   "Yes", "No")
forest_data$term <- factor(forest_data$term, 
                           levels = forest_data$term[order(forest_data$estimate)])

ggplot(forest_data, aes(x = estimate, y = term, color = significant)) +
  geom_vline(xintercept = 0, linetype = "dashed", color = "grey50") +
  geom_errorbar(aes(xmin = pmax(ci_lower, -15), xmax = pmin(ci_upper, 15)), 
                width = 0.2, linewidth = 0.8, orientation = "y") +
  geom_point(size = 3) +
  scale_color_manual(values = c("Yes" = "#b2182b", "No" = "#969696"),
                     labels = c("CI excludes 0", "CI includes 0")) +
  labs(title = "Logistic Regression Coefficients (Log-Odds, Standardized Scale)",
       subtitle = "Error bars: 95% Wald CI (truncated at ±15 for readability)",
       x = "Log-Odds (per 1 SD increase)",
       y = "Predictor",
       color = "Statistically\nSignificant?") +
  theme_minimal(base_size = 12) +
  theme(plot.title = element_text(face = "bold"),
        legend.position = "right")

Separation and infinite estimates. The standard errors for smoking_current (SE = 712) and ckd_yes (SE = 1015) are astronomical because these variables perfectly (or nearly perfectly) predict the outcome in the small benign subset. This is complete or quasi-complete separation. The Wald confidence intervals for these terms are wider than the plot can display. No causal or even predictive interpretation should be attached to their point estimates; the maximum-likelihood estimate is effectively undefined. Penalized regression (Section 7.3) or Firth’s bias-reduced logistic regression are the appropriate remedies.

Interpret these as associations within a surgical cohort, adjusted for the other listed variables, and not as causal effects or as transportable screening rules. Wide standard errors are expected with 9 benign cases in training.

An odds ratio from a predictive model is not automatically a causal effect. Scaling means that each reported odds ratio corresponds to one training-set standard deviation for a continuous predictor.

Questions

Degenerate specificity. The model achieves specificity = 0 at every threshold the app can reach for the out-of-fold predictions. What does this tell you about the separation of predicted probability distributions for benign vs. malignant cases? Would more benign cases fix this, or is there a structural problem with the predictors?
External AUC < 0.5. The external test AUC is 0.323, meaning the model ranks probabilities worse than random. What could cause this? Consider: (a) distribution shift in predictor values, (b) different prevalence, (c) overfitting to training-specific noise, (d) a sign error or label inconsistency across sites.
Coefficient interpretation. radiographic_size_cm has a positive log-odds (4.289) while log_radiographic_size has a negative one (−2.556), and neither is significant. These two variables are transformations of the same underlying measurement. What does their opposite signs tell you about collinearity and the folly of interpreting individual coefficients in a model with redundant predictors?
Clinical relevance of the threshold. The Youden threshold of 0.84 was selected to maximize sensitivity + specificity − 1. In a clinical setting where the cost of a false negative (missing a malignancy) is much higher than a false positive (unnecessary follow-up), would you choose a different threshold? How would you formalize that cost asymmetry?
Sample size requirements. With only 9 benign cases in training, the model has essentially learned “predict malignant for everyone.” Roughly how many benign cases would you need to estimate a stable specificity? How does this connect to the “events per variable” rule of thumb (typically $10-20$ minority-class events per predictor)?

7.3 k-nearest neighbors and the geometry of feature space

For a query $x$, k-nearest neighbors estimates risk by averaging outcomes among the $k$ closest training cases

\[\widehat p(x)=\frac{1}{k}\sum_{i\in\mathcal N_k(x)}y_i.\]

Distance is meaningful only after appropriate scaling and becomes less discriminative in high dimensions.

Why KNN as a baseline? KNN makes no distributional assumptions and no parametric model – it simply asks “what happened to similar patients?” This makes it an excellent non-parametric benchmark. If logistic regression (parametric) and KNN (non-parametric) agree, you have evidence that the signal is robust. If they disagree, the discrepancy itself is diagnostically valuable: it may indicate non-linear boundaries, local clusters, or regions where the parametric model is misspecified.

Bias-Variance Tradeoff Example

The choice of $k$ governs a fundamental tension

Small $k$ (e.g., 3)	Large $k$ (e.g., 45)
Low bias: follows local data structure closely	High bias: smooths over local structure
High variance: predictions swing with individual neighbors	Low variance: predictions stabilize toward the marginal prevalence
Sensitive to noise and outliers	Robust to noise but may miss real clusters
Complex, wiggly decision boundary	Simple, nearly linear decision boundary

With only 9 benign cases in training, large $k$ will pull every prediction toward the 92.5% malignant prevalence. The question is whether any $k$ can extract local signal from this sparse, high-dimensional space.

## k-nearest neighbours implemented directly, so the geometry is visible.
knn_predict <- function(X_train, y_train, X_new, k = 15) {
  apply(X_new, 1, function(z) {
    d <- sqrt(colSums((t(X_train) - z)^2))     # Euclidean in standardized space
    mean(y_train[order(d)[seq_len(k)]])        # fraction of malignant neighbours
  })
}

k_grid <- c(3, 5, 9, 15, 25, 45)
knn_cv <- sapply(k_grid, function(k) {
  oof <- rep(NA_real_, length(y_train))
  for (f in sort(unique(folds))) {
    fit_idx <- folds != f
    oof[!fit_idx] <- knn_predict(X_train[fit_idx, , drop = FALSE],
                                 y_train[fit_idx],
                                 X_train[!fit_idx, , drop = FALSE], k = k)
  }
  auc_rank(y_train, oof)
})
names(knn_cv) <- paste0("k=", k_grid)
round(knn_cv, 3)

##   k=3   k=5   k=9  k=15  k=25  k=45 
## 0.719 0.658 0.723 0.565 0.571 0.561

best_k <- k_grid[which.max(knn_cv)]
knn_internal <- knn_predict(X_train, y_train, X_internal, k = best_k)
knn_external <- knn_predict(X_train, y_train, X_external, k = best_k)
cat("selected k =", best_k, "\n")

## selected k = 9

round(rbind(internal = classification_metrics(y_internal, knn_internal),
            external = classification_metrics(y_external, knn_external))[
              , c("n", "auc", "brier", "sensitivity", "specificity")], 3)

##           n   auc brier sensitivity specificity
## internal 41 0.588 0.089           1           0
## external 49 0.366 0.114           1           0

## Visualize the bias-variance tradeoff across k values.
library(ggplot2)
library(patchwork)

# AUC vs k
auc_df <- data.frame(k = k_grid, auc = knn_cv)
p1 <- ggplot(auc_df, aes(x = k, y = auc)) +
  geom_line(color = "#2166ac", size = 1) +
  geom_point(size = 3, color = "#2166ac") +
  geom_hline(yintercept = 0.5, lty = 2, color = "grey50") +
  geom_vline(xintercept = best_k, lty = 2, color = "#d95f02") +
  annotate("text", x = best_k, y = min(knn_cv) + 0.02,
           label = sprintf("Best k = %d", best_k), color = "#d95f02", size = 4) +
  labs(title = "Out-of-fold AUC vs. k",
       subtitle = "Orange line marks selected k",
       x = "k (number of neighbors)",
       y = "AUC") +
  theme_minimal(base_size = 12)

# Predicted probability range vs k (variance proxy)
var_df <- sapply(k_grid, function(k) {
  oof <- rep(NA_real_, length(y_train))
  for (f in sort(unique(folds))) {
    fit_idx <- folds != f
    oof[!fit_idx] <- knn_predict(X_train[fit_idx, , drop = FALSE],
                                 y_train[fit_idx],
                                 X_train[!fit_idx, , drop = FALSE], k = k)
  }
  c(range = max(oof, na.rm = TRUE) - min(oof, na.rm = TRUE),
    mean = mean(oof, na.rm = TRUE))
})

var_plot_df <- data.frame(k = k_grid, range = var_df["range", ], mean = var_df["mean", ])
p2 <- ggplot(var_plot_df, aes(x = k)) +
  geom_line(aes(y = range, color = "Range of predictions"), size = 1) +
  geom_line(aes(y = mean, color = "Mean prediction"), size = 1) +
  geom_hline(yintercept = mean(y_train), lty = 2, color = "grey50") +
  annotate("text", x = 35, y = mean(y_train) + 0.03,
           label = sprintf("Prevalence = %.3f", mean(y_train)), 
           color = "grey30", size = 3.5) +
  scale_color_manual(values = c("Range of predictions" = "#b2182b", 
                                "Mean prediction" = "#4292c6")) +
  labs(title = "Prediction spread vs. k",
       subtitle = "As k grows, all predictions converge to the prevalence",
       x = "k",
       y = "Value",
       color = "") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom")

p1 + p2

Read the right-hand plot carefully. As $k$ increases, the range of predicted probabilities collapses toward zero. At $k = 45$, every patient receives nearly the same prediction (~0.925), which is just the marginal prevalence. The model has given up on local geometry and become a constant predictor. This is why large $k$ is not “conservative” – it is uninformative.

Interactive Exploration: Neighborhood Geometry and the Curse of Dimensionality

The app below lets you examine what happens to the neighborhood structure as you vary $k$ and the number of dimensions used. You can also project the high-dimensional data into 2D for visualization.

library(shiny)
library(ggplot2)
library(dplyr)

# --- Data Preparation ---
X_mat <- as.matrix(X_train)
if (mode(X_mat) != "numeric") {
  X_mat <- apply(X_mat, 2, as.numeric)
}

complete_idx <- complete.cases(X_mat)
X_mat <- X_mat[complete_idx, , drop = FALSE]
y_app <- y_train[complete_idx]

pca_fit <- prcomp(X_mat, scale. = FALSE, center = TRUE)
ncol_pca <- min(2, ncol(pca_fit)$x)
pca_2d <- pca_fit$x[, 1:ncol_pca, drop = FALSE]
pca_var_explained <- summary(pca_fit)$importance[2, 1:ncol_pca]

if (!exists("best_k")) best_k <- 15

ui <- fluidPage(
  titlePanel("KNN Neighborhood Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("k", "k (number of neighbors):",
                  min = 1, max = 45, value = best_k, step = 2),
      sliderInput("n_dims", "Number of dimensions (features):",
                  min = 2, max = ncol(X_mat), value = ncol(X_mat), step = 1),
      selectInput("query_point", "Query patient (training set index):",
                  choices = seq_len(nrow(X_mat)),
                  selected = 1),
      checkboxInput("show_malignant", "Highlight malignant neighbors", value = TRUE),
      hr(),
      helpText("This app shows the k nearest neighbors in the full standardized 
               feature space (left) and in a 2D PCA projection (right). 
               As you increase dimensions, watch the neighborhood become less 
               meaningful -- distances concentrate and neighbors change.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Neighborhood Map", 
                 plotOutput("neighborPlot", height = "450px")),
        tabPanel("Distance Distribution", 
                 plotOutput("distPlot", height = "400px")),
        tabPanel("Prediction vs. k", 
                 plotOutput("predVsKPlot", height = "400px")),
        tabPanel("Curse of Dimensionality", 
                 plotOutput("cursePlot", height = "400px"),
                 textOutput("curseText"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  neighbor_data <- reactive({
    req(input$query_point, input$n_dims, input$k)
    
    # FIX: Cast string input to integer index
    query_idx <- as.integer(input$query_point)
    
    X_sub <- X_mat[, 1:input$n_dims, drop = FALSE]
    query <- as.numeric(X_sub[query_idx, ])
    
    diff_mat <- sweep(t(X_sub), 1, query, FUN = function(x, y) x - y)
    d <- sqrt(colSums(diff_mat^2))
    
    k_eff <- min(input$k, length(d))
    neighbor_idx <- order(d)[seq_len(k_eff)]
    
    list(
      distances = d,
      neighbors = neighbor_idx,
      query = query_idx,
      query_label = y_app[query_idx],
      neighbor_labels = y_app[neighbor_idx],
      prediction = mean(y_app[neighbor_idx]),
      n_dims = input$n_dims,
      k = k_eff
    )
  })
  
  output$neighborPlot <- renderPlot({
    nd <- neighbor_data()
    
    plot_df <- data.frame(
      PC1 = pca_2d[, 1],
      PC2 = if (ncol(pca_2d) > 1) pca_2d[, 2] else 0,
      y = factor(y_app, labels = c("Benign", "Malignant")),
      is_neighbor = FALSE,
      is_query = FALSE
    )
    plot_df$is_neighbor[nd$neighbors] <- TRUE
    plot_df$is_query[nd$query] <- TRUE
    
    ggplot(plot_df, aes(x = PC1, y = PC2)) +
      geom_point(data = subset(plot_df, !is_neighbor & !is_query),
                 aes(color = y), alpha = 0.3, size = 2) +
      geom_point(data = subset(plot_df, is_neighbor & !is_query),
                 aes(fill = y), shape = 21, size = 4, stroke = 1.5) +
      geom_point(data = subset(plot_df, is_query),
                 fill = "red", shape = 21, size = 6, stroke = 2) +
      scale_color_manual(values = c("#1b9e77", "#d95f02")) +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = sprintf("k = %d Neighbors in 2D PCA Projection (using %d of %d dims)",
                           nd$k, nd$n_dims, ncol(X_mat)),
           subtitle = sprintf("Query patient %d (true: %s) | Prediction: %.3f",
                              nd$query,
                              ifelse(nd$query_label == 1, "Malignant", "Benign"),
                              nd$prediction),
           x = sprintf("PC1 (%.1f%%)", pca_var_explained[1] * 100),
           y = if (ncol(pca_2d) > 1) sprintf("PC2 (%.1f%%)", pca_var_explained[2] * 100) else "",
           color = "All cases", fill = "Neighbors") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "right") +
      guides(color = guide_legend(override.aes = list(size = 3)))
  })
  
  output$distPlot <- renderPlot({
    nd <- neighbor_data()
    
    dist_df <- data.frame(
      distance = nd$distances,
      is_neighbor = seq_along(nd$distances) %in% nd$neighbors,
      y = factor(y_app, labels = c("Benign", "Malignant"))
    )
    dist_df <- dist_df[order(dist_df$distance), ]
    dist_df$rank <- seq_len(nrow(dist_df))
    
    ggplot(dist_df, aes(x = rank, y = distance, color = y)) +
      geom_point(aes(shape = is_neighbor), size = 3) +
      geom_vline(xintercept = nd$k + 0.5, lty = 2, color = "red") +
      scale_shape_manual(values = c("FALSE" = 1, "TRUE" = 19), 
                         labels = c("Outside k", "Inside k")) +
      scale_color_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Distance from Query to All Training Cases",
           subtitle = sprintf("Using %d dimensions | k = %d", nd$n_dims, nd$k),
           x = "Rank (closest to farthest)",
           y = "Euclidean distance",
           color = "True label",
           shape = "") +
      theme_minimal(base_size = 12)
  })
  
  output$predVsKPlot <- renderPlot({
    req(input$query_point, input$n_dims, input$k)
    
    # FIX: Cast string input to integer index
    query_idx <- as.integer(input$query_point)
    
    X_sub <- X_mat[, 1:input$n_dims, drop = FALSE]
    query <- as.numeric(X_sub[query_idx, ])
    
    diff_mat <- sweep(t(X_sub), 1, query, FUN = function(x, y) x - y)
    d <- sqrt(colSums(diff_mat^2))
    ordered_y <- y_app[order(d)]
    
    k_seq <- 1:min(45, nrow(X_mat))
    preds <- sapply(k_seq, function(k) mean(ordered_y[1:k]))
    
    pred_df <- data.frame(k = k_seq, prediction = preds)
    
    ggplot(pred_df, aes(x = k, y = prediction)) +
      geom_line(color = "#2166ac", linewidth = 1) +
      geom_point(color = "#2166ac", size = 2) +
      geom_hline(yintercept = mean(y_app), lty = 2, color = "grey50") +
      annotate("text", x = 35, y = mean(y_app) + 0.03,
               label = sprintf("Prevalence = %.3f", mean(y_app)),
               color = "grey30", size = 3.5) +
      geom_vline(xintercept = input$k, lty = 2, color = "#d95f02") +
      labs(title = sprintf("Prediction for Query Patient %d as k Grows", query_idx),
           subtitle = sprintf("Using %d dimensions | True label: %s",
                              input$n_dims,
                              ifelse(y_app[query_idx] == 1, "Malignant", "Benign")),
           x = "k",
           y = "Predicted probability") +
      ylim(0, 1) +
      theme_minimal(base_size = 12)
  })
  
  output$cursePlot <- renderPlot({
    dim_seq <- seq(2, ncol(X_mat), by = 1)
    dist_stats <- sapply(dim_seq, function(d) {
      X_sub <- X_mat[, 1:d, drop = FALSE]
      dists <- as.matrix(dist(X_sub))
      diag(dists) <- NA
      nearest <- apply(dists, 1, min, na.rm = TRUE)
      farthest <- apply(dists, 1, max, na.rm = TRUE)
      c(nearest_mean = mean(nearest),
        farthest_mean = mean(farthest),
        ratio = mean(nearest) / mean(farthest))
    })
    
    if (!is.matrix(dist_stats)) {
      dist_stats <- matrix(dist_stats, nrow = 3, ncol = length(dim_seq),
                           dimnames = list(c("nearest_mean", "farthest_mean", "ratio"), dim_seq))
    }
    
    curse_df <- data.frame(
      dimensions = dim_seq,
      nearest = dist_stats["nearest_mean", ],
      farthest = dist_stats["farthest_mean", ],
      ratio = dist_stats["ratio", ]
    )
    
    ggplot(curse_df) +
      geom_line(aes(x = dimensions, y = nearest, color = "Nearest neighbor"), linewidth = 1) +
      geom_line(aes(x = dimensions, y = farthest, color = "Farthest neighbor"), linewidth = 1) +
      geom_vline(xintercept = input$n_dims, lty = 2, color = "#d95f02") +
      scale_color_manual(values = c("Nearest neighbor" = "#1b9e77", 
                                    "Farthest neighbor" = "#d95f02")) +
      labs(title = "The Curse of Dimensionality: Distance Concentration",
           subtitle = "As dimensions increase, all distances become similar",
           x = "Number of dimensions",
           y = "Average distance",
           color = "") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom")
  })
  
  output$curseText <- renderText({
    dim_seq <- seq(2, ncol(X_mat), by = 1)
    
    ratios <- sapply(dim_seq, function(d) {
      X_sub <- X_mat[, 1:d, drop = FALSE]
      dists <- as.matrix(dist(X_sub))
      diag(dists) <- NA
      mean(apply(dists, 1, min, na.rm = TRUE)) /
        mean(apply(dists, 1, max, na.rm = TRUE))
    })
    names(ratios) <- dim_seq
    
    ratio_val <- ratios[as.character(input$n_dims)]
    
    if (is.na(ratio_val)) {
      "Select a dimension value to see the distance ratio."
    } else {
      paste0("At d = ", input$n_dims, ", the ratio of nearest to farthest distance is ",
             round(ratio_val, 3),
             ". When this ratio approaches 1, KNN cannot distinguish 'near' from 'far' -- ",
             "every point is roughly equidistant from every other point, and the concept ",
             "of a 'neighbor' becomes meaningless.")
    }
  })
}

shinyApp(ui, server)

Results Interpretation

# Display results side-by-side with logistic regression for comparison
knn_results <- rbind(
  internal = classification_metrics(y_internal, knn_internal),
  external = classification_metrics(y_external, knn_external)
)

comparison_df <- data.frame(
  Model = c("Logistic (internal)", "KNN (internal)", 
            "Logistic (external)", "KNN (external)"),
  AUC = c(logistic_performance["internal_test", "auc"],
          knn_results["internal", "auc"],
          logistic_performance["external_test", "auc"],
          knn_results["external", "auc"]),
  Brier = c(logistic_performance["internal_test", "brier"],
            knn_results["internal", "brier"],
            logistic_performance["external_test", "brier"],
            knn_results["external", "brier"]),
  Sensitivity = c(logistic_performance["internal_test", "sensitivity"],
                  knn_results["internal", "sensitivity"],
                  logistic_performance["external_test", "sensitivity"],
                  knn_results["external", "sensitivity"]),
  Specificity = c(logistic_performance["internal_test", "specificity"],
                  knn_results["internal", "specificity"],
                  logistic_performance["external_test", "specificity"],
                  knn_results["external", "specificity"])
)

print(comparison_df)

##                 Model       AUC      Brier Sensitivity Specificity
## 1 Logistic (internal) 0.5405405 0.09331939           1           0
## 2      KNN (internal) 0.5878378 0.08912978           1           0
## 3 Logistic (external) 0.3227273 0.11471746           1           0
## 4      KNN (external) 0.3659091 0.11363064           1           0

Logistic vs. KNN: What the comparison tells us. Both models struggle with specificity on this surgical cohort, but for different reasons. Logistic regression’s specificity is zero because the predicted probabilities are compressed into a narrow high range. KNN’s specificity (if non-zero) reflects whether any benign case has a local neighborhood rich in other benign cases. If KNN also fails to achieve specificity, it confirms that benign cases are scattered throughout the malignant cloud in feature space, i.e., there is no local “benign cluster” to discover.

Explicating the Curse of Dimensionality

Small $k$ produces a high-variance boundary, while large $k$ smooths toward the marginal prevalence. Because the standardization was fitted on training data only, the distance metric itself is leakage-free – with 9 standardized dimensions and 120 training cases, however, neighbourhoods are sparse, which is the curse of dimensionality made concrete.

## Demonstrate distance concentration: as dimensions increase, the ratio of
## nearest to farthest distance approaches 1, making "nearest" meaningless.
library(ggplot2)

dim_seq <- seq(2, ncol(X_train), by = 1)
dist_ratios <- sapply(dim_seq, function(d) {
  X_sub <- X_train[, 1:d, drop = FALSE]
  dists <- as.matrix(dist(X_sub))
  diag(dists) <- NA
  mean(apply(dists, 1, min, na.rm = TRUE)) /
    mean(apply(dists, 1, max, na.rm = TRUE))
})

ratio_df <- data.frame(dimensions = dim_seq, ratio = dist_ratios)

ggplot(ratio_df, aes(x = dimensions, y = ratio)) +
  geom_line(color = "#b2182b", size = 1) +
  geom_point(color = "#b2182b", size = 2) +
  geom_hline(yintercept = 1, lty = 2, color = "grey50") +
  annotate("text", x = max(dim_seq) - 1, y = 1.02, 
           label = "Ratio = 1 (all distances equal)", 
           color = "grey30", hjust = 1, size = 3.5) +
  labs(title = "Distance Concentration in the KiTS Feature Space",
       subtitle = "When the ratio approaches 1, KNN cannot distinguish neighbors from strangers",
       x = "Number of standardized dimensions",
       y = "Mean(nearest) / Mean(farthest)") +
  theme_minimal(base_size = 12)

With 9 dimensions, the nearest-to-farthest ratio is 0.176. In a well-separated low-dimensional space this ratio might be 0.2 or lower; here it is much higher, confirming that neighborhoods are not geometrically meaningful.

Connection to other BPAD Concepts

Concept	Connection to KNN
6.4 PCA	PCA can reduce dimensionality before KNN, but the principal components may not preserve local neighborhood structure
6.5 p≫n	With 120 cases and 10 dimensions, KNN operates in a sparse space where neighborhoods contain mostly noise
6.7 Acquisition shift	Distance-based methods are vulnerable to shift: if thick-slice cases have different feature distributions, they may form artificial neighborhoods
7.1 Metrics	AUC is threshold-free, making it the fair comparison metric for KNN (which produces probabilities, not hard classifications)
7.2 Logistic regression	If logistic regression (global boundary) and KNN (local boundary) agree, the signal is robust; if they disagree, the discrepancy is diagnostically valuable

Discussion Questions

Optimal k. The cross-validation selected $k = 9$. Given that there are only 9 benign cases in training, what does it mean when $k = 9$ neighbors are averaged? How many of those neighbors are likely to be benign?
Dimensionality reduction. Would performing PCA before KNN improve performance? What information might be lost? Consider the tension between global variance (PCA) and local neighborhood structure (KNN).
Distance metric. We used Euclidean distance in standardized space. When might Manhattan distance or Mahalanobis distance be more appropriate? How does the choice interact with the curse of dimensionality?
Comparison to logistic regression. Compare the AUC values from both models. If they are similar, what does that suggest about the linear separability of the data? If KNN does worse, what does that imply about local structure?
External validity. KNN is a “lazy learner” – it memorizes the training set. How might this make it particularly vulnerable to distribution shift on the external test set? Compare this to logistic regression’s vulnerability.

Here is a proposed enhancement for Sections 7.4 and 7.5. It preserves your excellent cautionary callouts and robust package-guarding code, but adds a conceptual taxonomy of the algorithms, a visual plot of the internal vs. external performance shift, and an interactive Shiny app. The app allows learners to dynamically compare the models’ ROC curves, calibration, and confusion matrices to see why the rank order is unstable and how external shift degrades performance.

7.4 Decision trees, random forests, support-vector machines, and penalized models

A decision tree recursively partitions feature space. Random forests average many decorrelated trees. Support-vector machines seek a margin-maximizing boundary, optionally in a kernel-induced feature space. Penalized generalized linear models control complexity directly through their coefficient norm. See details provided in DSPA Chapter 6 (neural networks, support vector machines, decision trees, and random forest classification).

Why fit a zoo of models? In small-n, high-dimensional clinical data, we rarely know the true data-generating mechanism. Fitting models from different families acts as a sensitivity analysis:

Elastic Net (Penalized GLM): Handles collinearity and performs feature selection, but assumes a linear combination of features on the log-odds scale.
Random Forest (Tree Ensemble): Captures non-linear interactions without explicit specification, but can overfit to dominant noisy features in small samples.
Support-Vector Machine (Kernel): Finds flexible non-linear boundaries, but probability calibration is often poor and hyperparameter sensitivity is high.

If a linear model and a flexible non-linear model perform similarly, the signal is likely simple and linear; if the flexible model dominates, there are complex interactions worth investigating.

This (optional) R chunk fits additional algorithms, using packages that are available. It uses the same locked partitions and the same training-fitted preprocessing.

## Penalized, tree-based, and kernel models on the same REAL design matrix.
## Each is guarded so the chapter still knits if a package is unavailable.
model_scores <- list(
  logistic = list(internal = p_internal, external = p_external),
  knn      = list(internal = knn_internal, external = knn_external)
)

if (has_pkg("glmnet")) {
  set.seed(4)
  cv_fit <- glmnet::cv.glmnet(X_train, y_train, family = "binomial",
                              alpha = 0.5, nfolds = 5)
  model_scores$elastic_net <- list(
    internal = as.numeric(predict(cv_fit, X_internal, s = "lambda.min",
                                  type = "response")),
    external = as.numeric(predict(cv_fit, X_external, s = "lambda.min",
                                  type = "response"))
  )
  cat("elastic net: lambda.min =", signif(cv_fit$lambda.min, 3),
      "| non-zero coefficients =",
      sum(as.numeric(coef(cv_fit, s = "lambda.min")) != 0) - 1, "\n")
}

## elastic net: lambda.min = 0.0266 | non-zero coefficients = 7

if (has_pkg("randomForest")) {
  set.seed(5)
  rf <- randomForest::randomForest(
    x = as.data.frame(X_train), y = factor(y_train),
    ntree = 500, nodesize = 5
  )
  model_scores$random_forest <- list(
    internal = predict(rf, as.data.frame(X_internal), type = "prob")[, "1"],
    external = predict(rf, as.data.frame(X_external), type = "prob")[, "1"]
  )
  imp <- randomForest::importance(rf)
  print(round(imp[order(-imp[, 1]), , drop = FALSE][1:5, , drop = FALSE], 2))
}

##                       MeanDecreaseGini
## body_mass_index                   2.20
## in_plane_mm                       2.13
## log_radiographic_size             2.01
## radiographic_size_cm              1.95
## age_at_nephrectomy                1.52

if (has_pkg("e1071")) {
  set.seed(6)
  svm_fit <- e1071::svm(x = X_train, y = factor(y_train), kernel = "radial",
                        probability = TRUE)
  pr_int <- attr(predict(svm_fit, X_internal, probability = TRUE), "probabilities")
  pr_ext <- attr(predict(svm_fit, X_external, probability = TRUE), "probabilities")
  model_scores$svm_rbf <- list(internal = pr_int[, "1"], external = pr_ext[, "1"])
}

names(model_scores)

## [1] "logistic"      "knn"           "elastic_net"   "random_forest"
## [5] "svm_rbf"

Hyperparameters in a formal comparison must be tuned within an inner resampling loop. The fixed values above are pedagogical defaults, not a claim that one algorithm is optimally configured.

7.5 Comparing models on locked test sets

comparison <- do.call(rbind, lapply(names(model_scores), function(nm) {
  data.frame(
    model = nm,
    internal_auc = auc_rank(y_internal, model_scores[[nm]]$internal),
    external_auc = auc_rank(y_external, model_scores[[nm]]$external),
    internal_brier = mean((model_scores[[nm]]$internal - y_internal)^2),
    external_brier = mean((model_scores[[nm]]$external - y_external)^2)
  )
}))
comparison[, -1] <- round(comparison[, -1], 3)
comparison[order(-comparison$internal_auc), ]

##           model internal_auc external_auc internal_brier external_brier
## 3   elastic_net        0.709        0.464          0.083          0.096
## 4 random_forest        0.605        0.582          0.090          0.098
## 5       svm_rbf        0.595        0.255          0.088          0.094
## 2           knn        0.588        0.366          0.089          0.114
## 1      logistic        0.541        0.309          0.093          0.115

## Visualize the internal-to-external performance shift
library(ggplot2)
library(tidyr)

plot_df <- comparison %>%
  pivot_longer(cols = c(internal_auc, external_auc), 
               names_to = "dataset", values_to = "auc") %>%
  mutate(dataset = factor(dataset, levels = c("internal_auc", "external_auc"),
                          labels = c("Internal", "External")))

ggplot(plot_df, aes(x = auc, y = model, color = dataset, group = model)) +
  geom_line(color = "grey70", size = 1) +
  geom_point(size = 4) +
  geom_vline(xintercept = 0.5, lty = 2, color = "red") +
  scale_color_manual(values = c("Internal" = "#2166ac", "External" = "#b2182b")) +
  labs(title = "Model Performance Shift: Internal vs. External Test Sets",
       subtitle = "Lines connect the same model across datasets. AUC < 0.5 indicates anti-predictive performance.",
       x = "AUC",
       y = "Model") +
  theme_minimal(base_size = 12) +
  theme(legend.title = element_blank())

Rank order is unstable at this sample size. The internal test set contains only a handful of benign cases, so differences of a few AUC points between these models are well inside sampling noise (Section 11.3 attaches bootstrap intervals). Declaring a winner from a table like this is one of the most common failures in the imaging-AI literature, without confidence intervals, without a prespecified primary metric, and without repeating the whole selection inside nested resampling (Section 7.7).

The best internal model is not necessarily the best acquisition-held-out model. Differences smaller than their uncertainty should not be overinterpreted. A simpler, better-calibrated model may be preferable when performance is similar.

Interactive Exploration: ROC, Calibration, and the External Shift

The table above summarizes performance with single numbers, but the behavior of the models is far more complex. The app below allows you to select any of the fitted models and visualize its performance on either the Internal or External test set.

Use the app to answer: Which model is best calibrated? Does the “best” internal model maintain its ROC curve on the external set? How do the confusion matrices differ when you change the threshold?

library(shiny)
library(ggplot2)
library(dplyr)
library(pROC)

ui <- fluidPage(
  titlePanel("Model Comparison Explorer"),
  sidebarLayout(
    sidebarPanel(
      selectInput("model", "Select Model:", choices = names(model_scores)),
      radioButtons("dataset", "Select Test Set:", 
                   choices = c("Internal", "External"), 
                   selected = "External"),
      sliderInput("threshold", "Decision Threshold:",
                  min = 0.01, max = 0.99, value = 0.5, step = 0.01),
      hr(),
      helpText("Compare ROC curves and calibration across models. 
               Notice how some models (like SVM) have good ranking (AUC) 
               but poor calibration (predictions clustered away from true probabilities).")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("ROC Curve", plotOutput("rocPlot", height = "400px")),
        tabPanel("Calibration", plotOutput("calibPlot", height = "400px")),
        tabPanel("Confusion Matrix", 
                 plotOutput("cmPlot", height = "350px"),
                 tableOutput("metricsTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  dat <- reactive({
    if (input$dataset == "Internal") {
      list(y = y_internal, p = model_scores[[input$model]]$internal, label = "Internal Test")
    } else {
      list(y = y_external, p = model_scores[[input$model]]$external, label = "External Test")
    }
  })
  
  output$rocPlot <- renderPlot({
    d <- dat()
    roc_obj <- roc(d$y, d$p, quiet = TRUE)
    roc_df <- data.frame(
      fpr = 1 - roc_obj$specificities,
      tpr = roc_obj$sensitivities
    )
    
    pred <- as.integer(d$p >= input$threshold)
    tp <- sum(pred == 1 & d$y == 1); fn <- sum(pred == 0 & d$y == 1)
    tn <- sum(pred == 0 & d$y == 0); fp <- sum(pred == 1 & d$y == 0)
    curr_sens <- if (tp + fn > 0) tp / (tp + fn) else 0
    curr_spec <- if (tn + fp > 0) tn / (tn + fp) else 0
    
    ggplot(roc_df, aes(x = fpr, y = tpr)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      geom_point(aes(x = 1 - curr_spec, y = curr_sens), 
                 color = "#e41a1c", size = 5, shape = 17) +
      annotate("text", x = 0.6, y = 0.4, 
               label = sprintf("AUC = %.3f", auc_rank(d$y, d$p)), size = 5) +
      labs(title = paste("ROC Curve:", input$model, "on", d$label),
           subtitle = sprintf("Red triangle: current threshold (%.2f)", input$threshold),
           x = "1 - Specificity",
           y = "Sensitivity") +
      coord_equal() +
      theme_minimal(base_size = 13)
  })
  
  output$calibPlot <- renderPlot({
    d <- dat()
    calib_df <- data.frame(y = d$y, p = d$p)
    
    # Create bins
    calib_df$bin <- cut(calib_df$p, breaks = seq(0, 1, by = 0.1), include.lowest = TRUE)
    calib_summary <- calib_df %>%
      group_by(bin) %>%
      summarise(mean_pred = mean(p), 
                mean_obs = mean(y), 
                n = n(), .groups = "drop")
    
    ggplot(calib_summary, aes(x = mean_pred, y = mean_obs)) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      geom_point(aes(size = n), color = "#d95f02", alpha = 0.8) +
      scale_size_continuous(range = c(2, 8), name = "N cases") +
      labs(title = paste("Calibration:", input$model, "on", d$label),
           x = "Mean Predicted Probability",
           y = "Observed Proportion (Malignant)") +
      xlim(0, 1) + ylim(0, 1) +
      theme_minimal(base_size = 13)
  })
  
  output$cmPlot <- renderPlot({
    d <- dat()
    pred_class <- ifelse(d$p >= input$threshold, 1, 0)
    cm <- factor(pred_class, levels = c(1, 0), labels = c("Pred Malignant", "Pred Benign"))
    true_class <- factor(d$y, levels = c(1, 0), labels = c("True Malignant", "True Benign"))
    cm_df <- as.data.frame(table(True = true_class, Pred = cm))
    
    ggplot(cm_df, aes(x = True, y = Pred, fill = Freq)) +
      geom_tile(color = "white", size = 2) +
      geom_text(aes(label = Freq), size = 8, color = "white", fontface = "bold") +
      scale_fill_gradient(low = "#66c2a5", high = "#b2182b") +
      labs(title = sprintf("Confusion Matrix (th=%.2f), %s", input$threshold, d$label),
           x = "", y = "") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none", panel.grid.major = element_blank())
  })
  
  output$metricsTable <- renderTable({
    d <- dat()
    m <- classification_metrics(d$y, d$p, threshold = input$threshold)
    m_df <- data.frame(Metric = names(m), Value = round(as.numeric(m), 3))
    m_df
  }, striped = TRUE, hover = TRUE, width = "80%")
}

shinyApp(ui, server)

Try it yourself.

Select the svm_rbf model. Look at its Calibration plot on the External set. You will likely see that all predictions are clustered in a narrow range (e.g., 0.8 to 1.0). This means SVM’s “probabilities” are rank-ordering signals, not calibrated risks.
Compare the logistic and elastic_net models. Does the penalty improve or worsen the external AUC?
Switch between Internal and External datasets for the random_forest model. Does its ROC curve degrade more gracefully than the logistic regression’s, or does it collapse entirely? (This tells you how sensitive the tree ensemble is to acquisition shift).

7.6 Continuous-outcome modeling: postoperative renal-function decline

Clinical Context: Why eGFR matters. For localized kidney tumors, partial nephrectomy (removing only the tumor) is preferred over radical nephrectomy (removing the whole kidney) to preserve renal function. Modeling the expected decline in estimated glomerular filtration rate (eGFR) helps quantify the functional cost of a surgical plan. If a model predicts a catastrophic decline for a radical approach, it may justify the increased technical difficulty of a partial nephrectomy.

Suppose the model is used after a surgical plan has been selected but before surgery. Operative time and blood loss are not yet known, so they are excluded. We model

\[\Delta\mathrm{eGFR}=\mathrm{eGFR}_{\mathrm{pre}}- \mathrm{eGFR}_{\mathrm{post}}.\]

## Continuous outcome: postoperative decline in estimated glomerular filtration
## rate, computed from REAL pre- and post-operative laboratory values.
regression_predictors <- c(
  "preop_egfr", "radiographic_size_cm", "age_at_nephrectomy",
  "gender_male", "radical_planned", "open_planned", "body_mass_index"
)

egfr_complete <- which(is.finite(kidney_model$egfr_decline) &
                         is.finite(kidney_model$preop_egfr))
cat("cases with both eGFR measurements:", length(egfr_complete),
    "of", nrow(kidney_model), "\n")

## cases with both eGFR measurements: 119 of 210

cat("truncated (\">=90\") values inside this subset:",
    sum(kidney_model$preop_egfr_truncated[egfr_complete] |
          kidney_model$postop_egfr_truncated[egfr_complete]), "\n")

## truncated (">=90") values inside this subset: 26

round(summary(kidney_model$egfr_decline[egfr_complete]), 2)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  -30.00    0.00   11.00   11.41   22.00   70.00

reg_split <- stratified_split(
  kidney_model$surgery_type[egfr_complete], proportion = 0.7, seed = 24
)
reg_train_idx    <- egfr_complete[reg_split$train]
reg_internal_idx <- egfr_complete[reg_split$test]

reg_prep <- fit_numeric_preprocessor(kidney_model[reg_train_idx, ],
                                     regression_predictors)
XR_train    <- apply_numeric_preprocessor(reg_prep, kidney_model[reg_train_idx, ])
XR_internal <- apply_numeric_preprocessor(reg_prep, kidney_model[reg_internal_idx, ])

egfr_fit <- lm(egfr_decline ~ .,
               data = data.frame(egfr_decline = kidney_model$egfr_decline[reg_train_idx],
                                 XR_train))
round(summary(egfr_fit)$coefficients, 3)

##                      Estimate Std. Error t value Pr(>|t|)
## (Intercept)            12.159      1.448   8.396    0.000
## preop_egfr              6.274      1.589   3.950    0.000
## radiographic_size_cm   -7.217      2.145  -3.364    0.001
## age_at_nephrectomy      2.240      1.605   1.396    0.167
## gender_male             1.619      1.536   1.054    0.295
## radical_planned        13.547      2.118   6.396    0.000
## open_planned            3.333      1.559   2.138    0.036
## body_mass_index         1.148      1.504   0.764    0.448

cat("training R^2 =", round(summary(egfr_fit)$r.squared, 3), "\n")

## training R^2 = 0.491

egfr_pred <- predict(egfr_fit, data.frame(XR_internal))
round(regression_metrics(kidney_model$egfr_decline[reg_internal_idx], egfr_pred), 3)

##         n       mae      rmse      bias r_squared 
##    37.000    13.044    15.852     2.935    -0.364

The dominant term is surgical extent, since a radical nephrectomy removes an entire kidney, and the fitted coefficient recovers that physiology directly from the data rather than assuming it.

Baseline eGFR is the second driver, partly through regression to the mean, as patients starting higher have more to lose.

## Upgraded visualization using ggplot2 and patchwork
library(ggplot2)
library(patchwork)

obs_reg <- kidney_model$egfr_decline[reg_internal_idx]
plot_df <- data.frame(
  pred = egfr_pred,
  obs = obs_reg,
  resid = obs_reg - egfr_pred,
  surg = kidney_model$surgery_type[reg_internal_idx]
)

p1 <- ggplot(plot_df, aes(x = pred, y = obs)) +
  geom_point(size = 2, alpha = 0.6, color = "#2c7fb8") +
  geom_abline(slope = 1, intercept = 0, lty = 2, color = "red") +
  labs(title = "Predicted vs. Observed eGFR Decline",
       x = "Predicted decline (mL/min/1.73m2)", 
       y = "Observed decline") +
  theme_minimal(base_size = 12)

p2 <- ggplot(plot_df, aes(x = pred, y = resid)) +
  geom_point(size = 2, alpha = 0.6, color = "#d95f02") +
  geom_hline(yintercept = 0, lty = 2, color = "red") +
  geom_smooth(method = "loess", se = FALSE, color = "grey30", size = 0.8) +
  labs(title = "Residuals vs. Fitted",
       x = "Predicted decline", 
       y = "Residual") +
  theme_minimal(base_size = 12)

p3 <- ggplot(plot_df, aes(x = surg, y = obs, fill = surg)) +
  geom_boxplot(alpha = 0.7) +
  scale_fill_manual(values = c("#cfe3f7", "#f7d9cf")) +
  labs(title = "Decline by Surgical Extent",
       x = "", 
       y = "Observed decline") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "none")

p1 + p2 + p3

A truncated covariate is not a measured one. Every patient whose baseline eGFR was reported as ">=90" enters this model at exactly 90, which compresses the top of the predictor range and biases the preop_egfr slope toward zero. Options include discarding those rows (losing real patients), modeling the outcome as interval-censored, or restricting the estimand to patients with quantified baseline function. Reporting the slope without mentioning the truncation is not one of the options.

Residual plots should assess nonlinearity, heteroscedasticity, influential cases, and distributional assumptions. Prediction intervals should describe uncertainty for a new patient, while confidence intervals for the mean response answer a different question.

Interactive Exploration: Functional Cost of Surgery

The app below supports modifying the surgical plan for the internal test cohort and observing the predicted change in renal function. Toggling the radical_planned variable shows exactly how much kidney function the model attributes to surgical extent, independent of tumor size or patient age.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("eGFR Decline: Surgical Plan Explorer"),
  sidebarLayout(
    sidebarPanel(
      radioButtons("surg_plan", "Force Surgical Plan for All Test Patients:",
                   choices = c("As Planned (Original)", 
                               "Force Partial Nephrectomy", 
                               "Force Radical Nephrectomy"),
                   selected = "As Planned (Original)"),
      hr(),
      helpText("This app refits the model on the training set, alters the 
               surgical plan variable for the test set, and predicts the 
               eGFR decline. Observe the shift in the distribution to 
               understand the weight the model places on surgical extent.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Distribution of Predictions", 
                 plotOutput("distPlot", height = "400px")),
        tabPanel("Predicted vs Observed", 
                 plotOutput("scatterPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  pred_data <- reactive({
    # Copy the internal test set
    XR_test_mod <- XR_internal
    
    # Modify the surgical plan based on user input
    if (input$surg_plan == "Force Partial Nephrectomy") {
      XR_test_mod[, "radical_planned"] <- 0
    } else if (input$surg_plan == "Force Radical Nephrectomy") {
      XR_test_mod[, "radical_planned"] <- 1
    }
    
    # Predict using the original egfr_fit
    preds <- predict(egfr_fit, data.frame(XR_test_mod))
    
    data.frame(
      pred = preds,
      obs = obs_reg,
      plan = ifelse(XR_test_mod[, "radical_planned"] == 1, "Radical", "Partial")
    )
  })
  
  output$distPlot <- renderPlot({
    d <- pred_data()
    ggplot(d, aes(x = pred, fill = plan)) +
      geom_density(alpha = 0.6) +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Predicted eGFR Decline Distribution",
           subtitle = input$surg_plan,
           x = "Predicted Decline (mL/min/1.73m2)",
           y = "Density",
           fill = "Surgical Plan") +
      theme_minimal(base_size = 13) +
      xlim(-20, 60)
  })
  
  output$scatterPlot <- renderPlot({
    d <- pred_data()
    ggplot(d, aes(x = obs, y = pred, color = plan)) +
      geom_point(size = 3, alpha = 0.7) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      scale_color_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Predicted vs. Observed eGFR Decline",
           subtitle = input$surg_plan,
           x = "Observed Decline",
           y = "Predicted Decline",
           color = "Surgical Plan") +
      theme_minimal(base_size = 13) +
      coord_equal()
  })
}

shinyApp(ui, server)

7.7 Nested cross-validation for honest algorithm selection

A generic pseudo-algorithm is described below.

for each outer fold o:
    hold out outer assessment patients
    for each candidate model and hyperparameter setting:
        evaluate it in inner folds using only outer-analysis patients
        repeat imputation, scaling, feature selection, and augmentation inside each fold
    select the inner-loop winner
    refit that complete pipeline on all outer-analysis patients
    predict the untouched outer-assessment patients
aggregate the outer predictions once

All data-adaptive choices belong inside the loop: feature stability filtering, number of principal components, regularization strength, tree depth, kernel width, image augmentation, early stopping, and threshold selection.

Visualizing the Nested Resampling Architecture

Optimization Bias (The “Winner’s Curse”). If you use a single cross-validation loop to tune hyperparameters and also to report final performance, your metric is biased optimistic. The model has effectively “seen” the validation data through the tuning process, and it will select the configuration that capitalized on noise in that specific split. Nested CV prevents this by strictly separating the tuning data (inner) from the performance estimation data (outer).

Interactive Exploration: Proving the Winner’s Curse

It is hard to believe that non-nested CV can severely inflate performance until you see it. The app below runs a live simulation on data with zero true signal (random noise).

Method 1 (Non-Nested): Tunes the regularization parameter lambda on the entire dataset, then evaluates performance using the same data.
Method 2 (Nested): Tunes lambda on inner folds, then evaluates on a held-out outer fold that was never seen during tuning.

Watch how the non-nested AUC routinely exceeds $0.5$ (often hitting $0.6-0.7$) simply by exploiting noise, while the nested AUC correctly centers around $0.$5 (random guessing).

library(shiny)
library(ggplot2)
library(glmnet)
library(pROC)

ui <- fluidPage(
  titlePanel("Nested vs. Non-Nested CV: Noise Simulation"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("n_samples", "Number of Samples (n):",
                  min = 50, max = 500, value = 100, step = 50),
      sliderInput("n_features", "Number of Features (p):",
                  min = 50, max = 2000, value = 500, step = 50),
      actionButton("simulate", "Simulate New Noise Dataset"),
      hr(),
      helpText("This app generates purely random noise (Y ~ Bernoulli(0.5), 
               X ~ Normal(0,1)). There is no true signal. An honest model 
               should report AUC = 0.5. Watch the non-nested method report 
               falsely optimistic AUC due to optimization bias.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Simulation Results", 
                 plotOutput("resultsPlot", height = "400px"),
                 verbatimTextOutput("summaryText")),
        tabPanel("How it Works", 
                 uiOutput("explanation"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  sim_data <- eventReactive(input$simulate, {
    # Generate pure noise data
    set.seed(Sys.time())
    n <- input$n_samples
    p <- input$n_features
    X <- matrix(rnorm(n * p), n, p)
    y <- rbinom(n, 1, 0.5)
    
    # 1. Non-Nested: CV on full data, evaluate on full data
    cv_full <- cv.glmnet(X, y, family = "binomial", alpha = 0.5, nfolds = 5)
    p_non_nested <- as.numeric(predict(cv_full, X, s = "lambda.min", type = "response"))
    auc_non_nested <- auc_rank(y, p_non_nested)
    
    # 2. Nested: Split into outer train/test (50/50)
    outer_idx <- sample(seq_len(n), size = floor(n/2))
    X_train <- X[outer_idx, ]
    y_train <- y[outer_idx]
    X_test <- X[-outer_idx, ]
    y_test <- y[-outer_idx]
    
    # Tune on inner train
    cv_inner <- cv.glmnet(X_train, y_train, family = "binomial", alpha = 0.5, nfolds = 5)
    
    # Predict on outer test
    p_nested <- as.numeric(predict(cv_inner, X_test, s = "lambda.min", type = "response"))
    auc_nested <- auc_rank(y_test, p_nested)
    
    # Return data for plotting
    list(
      results = data.frame(
        Method = c("Non-Nested (Biased)", "Nested (Honest)"),
        AUC = c(auc_non_nested, auc_nested)
      )
    )
  })
  
  output$resultsPlot <- renderPlot({
    req(sim_data())
    ggplot(sim_data()$results, aes(x = Method, y = AUC, fill = Method)) +
      geom_col(width = 0.5) +
      geom_hline(yintercept = 0.5, lty = 2, color = "red", size = 1) +
      geom_text(aes(label = round(AUC, 3)), vjust = -0.5, size = 6) +
      scale_fill_manual(values = c("#d95f02", "#1b9e77")) +
      ylim(0, 1) +
      labs(title = "AUC on Pure Noise Data",
           subtitle = "Red line is true performance (0.5 = random guessing)",
           x = "", y = "Area Under ROC Curve") +
      theme_minimal(base_size = 14) +
      theme(legend.position = "none")
  })
  
  output$summaryText <- renderPrint({
    req(sim_data())
    d <- sim_data()$results
    cat("--- Simulation Summary ---\n")
    cat("Data: 100% random noise (no true signal).\n\n")
    cat("Non-Nested AUC:", d$AUC[1], "\n")
    cat("Nested AUC:     ", d$AUC[2], "\n\n")
    if (d$AUC[1] > 0.6) {
      cat("⚠️  Notice how the Non-Nested method claims to find signal (>0.6 AUC)!\n")
      cat("This is because it selected the lambda that best fit the noise in the validation folds.\n")
    }
  })
  
  output$explanation <- renderUI({
    tagList(
      h4("Why does this happen?"),
      p("When you have high-dimensional data (many features) and small sample sizes,
        there are many possible models. By chance, some hyperparameter settings will
        align perfectly with the random noise in your cross-validation folds."),
      p(strong("Non-Nested CV:"), "Uses the same data to both select the best hyperparameters
        and evaluate the final model. It essentially 'memorizes' the noise, leading to an
        optimistic bias (the Winner's Curse)."),
      p(strong("Nested CV:"), "Strictly separates the data used for tuning (inner loop) from
        the data used for final evaluation (outer loop). The outer loop evaluates how well
        the *entire tuning procedure* generalizes to truly unseen data, preventing the bias.")
    )
  })
}

shinyApp(ui, server)

Here is a proposed enhancement for Sections 7.8 and 7.9. The enhancements add concrete clinical cost scenarios, precision-recall analysis, causal DAGs, and an interactive Shiny app that lets learners explore how the cost ratio dictates the operating threshold and how confounding by indication distorts treatment effect estimates.

7.8 Class imbalance and asymmetric error costs

Accuracy can be misleading when disease is rare. Remedies include class-weighted losses, balanced resampling inside training folds, threshold selection based on consequences, and precision-recall analysis. Artificially balancing the test set changes prevalence and invalidates direct estimates of predictive value.

The KiTS imbalance is extreme. With $92.5\%$ malignant cases in training, a model that predicts “malignant” for everyone achieves $92.5\%$ accuracy and $100\%$ sensitivity. Accuracy is useless here. The clinically informative question is: can we identify the rare benign case? This is why specificity, PPV, and precision-recall curves are more informative than accuracy or even ROC-AUC alone.

Cost-Sensitive Decision Rules

A cost-sensitive decision rule predicts positive when

\[\widehat p(x)> \frac{C_{FP}}{C_{FP}+C_{FN}},\]

under a simple two-action loss with false-positive cost $C_{FP}$ and false-negative cost $C_{FN}$. Real clinical decisions may involve multiple actions, test harms, resource constraints, and treatment effects.

Clinical Scenario	$C_{FP}$	$C_{FN}$	Threshold	Rationale
Screening asymptomatic patients	Low (unnecessary biopsy)	High (missed cancer)	Low ($$0.05) \| Tolerate false alarms to catch every cancer \| \| Preoperative surgical planning \| High (unnecessary radical surgery) \| Moderate (delayed surgery) \| Moderate ($$0.5) \| Balance overtreatment vs. undertreatment \| \| Active surveillance enrollment \| High (unnecessary monitoring) \| High (missed progression) \| High ($$0.8)	Both errors carry serious consequences

## Compare ROC and Precision-Recall curves on the out-of-fold predictions.
## PR curves are far more informative than ROC when prevalence is extreme.
library(ggplot2)
library(pROC)

# Out-of-fold predictions from the logistic model
oof_df <- data.frame(y = y_train, p = oof_probability)

# ROC curve
roc_obj <- roc(oof_df$y, oof_df$p, quiet = TRUE)
roc_df <- data.frame(
  x = 1 - roc_obj$specificities,
  y = roc_obj$sensitivities
)

# Precision-Recall curve (manual computation)
threshold_seq <- seq(0.01, 0.99, by = 0.01)
pr_data <- sapply(threshold_seq, function(th) {
  pred <- as.integer(oof_df$p >= th)
  tp <- sum(pred == 1 & oof_df$y == 1)
  fp <- sum(pred == 1 & oof_df$y == 0)
  fn <- sum(pred == 0 & oof_df$y == 1)
  precision <- if (tp + fp == 0) NA else tp / (tp + fp)
  recall <- if (tp + fn == 0) NA else tp / (tp + fn)
  c(precision = precision, recall = recall)
})
pr_df <- data.frame(t(pr_data))
pr_df$threshold <- threshold_seq

p1 <- ggplot(roc_df, aes(x = x, y = y)) +
  geom_line(color = "#2166ac", size = 1) +
  geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
  labs(title = "ROC Curve (looks acceptable)",
       subtitle = sprintf("AUC = %.3f", auc_rank(y_train, oof_probability)),
       x = "1 - Specificity",
       y = "Sensitivity") +
  coord_equal() +
  theme_minimal(base_size = 12)

p2 <- ggplot(pr_df, aes(x = recall, y = precision)) +
  geom_line(color = "#b2182b", size = 1) +
  geom_hline(yintercept = mean(y_train), lty = 2, color = "grey50") +
  labs(title = "Precision-Recall Curve (reveals the truth)",
       subtitle = sprintf("Prevalence = %.3f (dashed line = baseline)", mean(y_train)),
       x = "Recall (Sensitivity)",
       y = "Precision (PPV)") +
  ylim(0, 1) +
  theme_minimal(base_size = 12)

library(patchwork)
p1 + p2

Review the PR curve carefully. The dashed horizontal line is the “no-skill” baseline (predicting the prevalence). The ROC curve looks acceptable (AUC $\approx$ 0.67), but the PR curve reveals that achieving high recall (sensitivity) requires accepting very low precision (PPV). In other words, to catch every benign case, you must flag an enormous number of malignant cases as “possibly benign.” This is the cost of operating in an extreme-prevalence regime.

Interactive Exploration: Cost Ratio and Operating Threshold

The next app allows control of the relative costs of false positives and false negatives and shows the optimal threshold changes. The cost ratio directly determines where on the ROC curve we should operate.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Cost-Sensitive Threshold Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("cost_fp", "Cost of False Positive (unnecessary surgery/biopsy):",
                  min = 1, max = 20, value = 5, step = 1),
      sliderInput("cost_fn", "Cost of False Negative (missed malignancy):",
                  min = 1, max = 20, value = 10, step = 1),
      hr(),
      helpText("The optimal threshold is C_FP / (C_FP + C_FN). 
               When missing a cancer is twice as costly as unnecessary surgery, 
               the threshold drops, casting a wider net for malignancy."),
      hr(),
      radioButtons("dataset", "Evaluate on:",
                   choices = c("Out-of-fold (train)" = "oof",
                               "Internal test" = "internal",
                               "External test" = "external"),
                   selected = "oof")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("ROC with Operating Point", 
                 plotOutput("rocPlot", height = "400px")),
        tabPanel("Cost vs Threshold", 
                 plotOutput("costPlot", height = "400px")),
        tabPanel("Confusion Matrix & Metrics", 
                 plotOutput("cmPlot", height = "300px"),
                 tableOutput("metricsTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  dat <- reactive({
    switch(input$dataset,
           "oof"      = list(y = y_train, p = oof_probability, label = "Out-of-fold"),
           "internal" = list(y = y_internal, p = p_internal, label = "Internal test"),
           "external" = list(y = y_external, p = p_external, label = "External test"))
  })
  
  optimal_threshold <- reactive({
    input$cost_fp / (input$cost_fp + input$cost_fn)
  })
  
  output$rocPlot <- renderPlot({
    d <- dat()
    roc_obj <- roc(d$y, d$p, quiet = TRUE)
    roc_df <- data.frame(
      fpr = 1 - roc_obj$specificities,
      tpr = roc_obj$sensitivities
    )
    
    th <- optimal_threshold()
    pred <- as.integer(d$p >= th)
    tp <- sum(pred == 1 & d$y == 1); fn <- sum(pred == 0 & d$y == 1)
    tn <- sum(pred == 0 & d$y == 0); fp <- sum(pred == 1 & d$y == 0)
    curr_sens <- if (tp + fn > 0) tp / (tp + fn) else 0
    curr_spec <- if (tn + fp > 0) tn / (tn + fp) else 0
    
    ggplot(roc_df, aes(x = fpr, y = tpr)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      geom_point(aes(x = 1 - curr_spec, y = curr_sens), 
                 color = "#e41a1c", size = 5, shape = 17) +
      annotate("text", x = 1 - curr_spec + 0.1, y = curr_sens - 0.1,
               label = sprintf("th = %.2f", th), color = "#e41a1c", size = 4) +
      labs(title = paste("ROC:", d$label),
           subtitle = sprintf("Cost ratio FP:FN = %d:%d → threshold = %.3f",
                              input$cost_fp, input$cost_fn, th),
           x = "1 - Specificity (FP rate)",
           y = "Sensitivity (TP rate)") +
      coord_equal() +
      theme_minimal(base_size = 13)
  })
  
  output$costPlot <- renderPlot({
    d <- dat()
    th_seq <- seq(0.01, 0.99, by = 0.01)
    costs <- sapply(th_seq, function(th) {
      pred <- as.integer(d$p >= th)
      fp <- sum(pred == 1 & d$y == 0)
      fn <- sum(pred == 0 & d$y == 1)
      input$cost_fp * fp + input$cost_fn * fn
    })
    cost_df <- data.frame(threshold = th_seq, total_cost = costs)
    
    ggplot(cost_df, aes(x = threshold, y = total_cost)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_vline(xintercept = optimal_threshold(), lty = 2, color = "#e41a1c", size = 1) +
      annotate("text", x = optimal_threshold() + 0.05, y = max(costs) * 0.9,
               label = sprintf("Optimal th = %.3f", optimal_threshold()),
               color = "#e41a1c", size = 4) +
      labs(title = "Total Expected Cost vs. Threshold",
           subtitle = paste("Dataset:", d$label),
           x = "Decision Threshold",
           y = "Total Cost (arbitrary units)") +
      theme_minimal(base_size = 13)
  })
  
  output$cmPlot <- renderPlot({
    d <- dat()
    th <- optimal_threshold()
    pred_class <- ifelse(d$p >= th, 1, 0)
    cm <- factor(pred_class, levels = c(1, 0), labels = c("Pred Malignant", "Pred Benign"))
    true_class <- factor(d$y, levels = c(1, 0), labels = c("True Malignant", "True Benign"))
    cm_df <- as.data.frame(table(True = true_class, Pred = cm))
    
    ggplot(cm_df, aes(x = True, y = Pred, fill = Freq)) +
      geom_tile(color = "white", size = 2) +
      geom_text(aes(label = Freq), size = 8, color = "white", fontface = "bold") +
      scale_fill_gradient(low = "#66c2a5", high = "#b2182b") +
      labs(title = sprintf("Confusion Matrix (th=%.2f)", th),
           x = "", y = "") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none", panel.grid.major = element_blank())
  })
  
  output$metricsTable <- renderTable({
    d <- dat()
    m <- classification_metrics(d$y, d$p, threshold = optimal_threshold())
    m_df <- data.frame(Metric = names(m), Value = round(as.numeric(m), 3))
    m_df
  }, striped = TRUE, hover = TRUE, width = "80%")
}

shinyApp(ui, server)

7.9 Prediction, association, and causation

A predictive model estimates $P(Y\mid X)$ under a target distribution. A causal question asks what would happen under an intervention, such as

\[ \mathbb{E}\{Y(\text{partial nephrectomy})-Y(\text{radical nephrectomy})\}. \]

Including treatment in a prognostic model does not identify treatment effect. Confounding by indication, time-varying treatment, selection, and competing events require a causal design. Predictors may be useful without being causes, and causal variables may be weak predictors. The scientific claim must match the design.

Causal Diagrams: Why Prediction ≠ Causation

In the predictive model, tumor size and age are associated with malignancy. We do not claim they cause malignancy, rather we use them to predict it. In the causal model, surgical approach causes a change in renal function, but tumor size, surgeon preference, and patient fitness all influence both the treatment choice and the outcome. This is confounding by indication. Sicker patients or patients with larger tumors may be steered toward radical nephrectomy, creating a spurious association between radical surgery and worse outcomes.

Interactive Exploration: Confounding by Indication

The app below simulates a scenario where partial nephrectomy has no true causal effect on renal function decline, but confounding by indication makes it look protective. The simulation demonstrates why simply including surgery_type in a regression model does not estimate a causal effect.

library(shiny)
library(ggplot2)
library(dplyr)

ui <- fluidPage(
  titlePanel("Confounding by Indication Simulator"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("true_effect", "True Causal Effect of Partial vs. Radical (mL/min):",
                  min = -20, max = 20, value = 0, step = 1),
      sliderInput("confound_strength", "Confound Strength (tumor size → surgery choice):",
                  min = 0, max = 1, value = 0.7, step = 0.1),
      sliderInput("n_sims", "Number of Simulated Patients:",
                  min = 100, max = 2000, value = 500, step = 100),
      actionButton("simulate", "Simulate"),
      hr(),
      helpText("Set the true causal effect to 0 (no benefit). 
               Then increase confound strength. Watch the naive estimate 
               become increasingly biased, suggesting partial nephrectomy 
               is protective even when it has zero true effect.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Results", 
                 plotOutput("resultsPlot", height = "400px"),
                 verbatimTextOutput("summaryText")),
        tabPanel("How It Works", uiOutput("explanation"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  sim_data <- eventReactive(input$simulate, {
    set.seed(42)
    n <- input$n_sims
    
    # Tumor size influences both surgery choice and outcome (confounder)
    tumor_size <- rnorm(n, mean = 5, sd = 2)
    
    # Probability of partial nephrectomy decreases with tumor size (indication)
    # confound_strength controls how strong this is
    p_partial <- plogis(2 - input$confound_strength * tumor_size)
    surgery <- rbinom(n, 1, p_partial)  # 1 = partial, 0 = radical
    
    # Renal function decline depends on tumor size and TRUE causal effect
    # The true effect is input$true_effect (negative = partial is better)
    decline <- 10 + 2 * tumor_size + 
               input$true_effect * surgery +  # TRUE causal effect
               rnorm(n, sd = 3)
    
    df <- data.frame(
      tumor_size = tumor_size,
      surgery = factor(surgery, levels = c(0, 1), labels = c("Radical", "Partial")),
      decline = decline
    )
    
    # 1. Naive comparison (ignores confounding)
    naive_diff <- mean(df$decline[df$surgery == "Partial"]) - 
                  mean(df$decline[df$surgery == "Radical"])
    
    # 2. Adjusted model (includes tumor_size)
    fit_adj <- lm(decline ~ surgery + tumor_size, data = df)
    adj_diff <- coef(fit_adj)["surgeryPartial"]
    
    list(
      df = df,
      naive_diff = naive_diff,
      adj_diff = adj_diff,
      true_effect = input$true_effect
    )
  })
  
  output$resultsPlot <- renderPlot({
    d <- sim_data()
    
    # Boxplot of decline by surgery type
    ggplot(d$df, aes(x = surgery, y = decline, fill = surgery)) +
      geom_boxplot(alpha = 0.7) +
      scale_fill_manual(values = c("#d95f02", "#1b9e77")) +
      labs(title = "Simulated eGFR Decline by Surgical Approach",
           subtitle = sprintf("True causal effect = %d mL/min | Naive estimate = %.1f | Adjusted = %.1f",
                              d$true_effect, d$naive_diff, d$adj_diff),
           x = "Surgical Approach",
           y = "eGFR Decline (mL/min)") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none")
  })
  
  output$summaryText <- renderPrint({
    d <- sim_data()
    cat("--- Simulation Summary ---\n")
    cat("True causal effect (partial - radical):", d$true_effect, "mL/min\n")
    cat("Naive estimate (unadjusted):           ", round(d$naive_diff, 2), "mL/min\n")
    cat("Adjusted estimate (controls for tumor):", round(d$adj_diff, 2), "mL/min\n\n")
    
    if (abs(d$naive_diff - d$true_effect) > 2) {
      cat("⚠️  The naive estimate is severely biased!\n")
      cat("Confounding by indication makes partial nephrectomy look protective\n")
      cat("even when the true effect is zero. Why? Because patients with small\n")
      cat("tumors (who would decline less anyway) are preferentially selected\n")
      cat("for partial nephrectomy.\n")
    }
    
    if (abs(d$adj_diff - d$true_effect) < 2) {
      cat("\n✓ The adjusted model recovers the true effect more accurately,\n")
      cat("but only because we correctly specified the confounder.\n")
      cat("In real data, unmeasured confounders remain.")
    }
  })
  
  output$explanation <- renderUI({
    tagList(
      h4("The Simulation Logic"),
      tags$ol(
        tags$li(strong("Confounder:"), " Tumor size influences BOTH the treatment 
                choice (larger tumors → radical surgery) and the outcome 
                (larger tumors → more decline)."),
        tags$li(strong("Treatment:"), " Surgery type is determined by tumor size 
                (confounding by indication). Surgeons select partial nephrectomy 
                for smaller, easier tumors."),
        tags$li(strong("Outcome:"), " Decline is determined by tumor size + 
                TRUE causal effect + noise."),
        tags$li(strong("Naive estimate:"), " Simply comparing mean decline between 
                surgery groups. Biased because it conflates treatment effect 
                with tumor size effect."),
        tags$li(strong("Adjusted estimate:"), " Linear model including tumor size. 
                Recovers the true effect if all confounders are measured and 
                correctly modeled.")
      ),
      hr(),
      h4("Key Takeaway"),
      p("Including 'surgery_type' in a predictive model (like our eGFR regression 
        in Section 7.6) estimates an ", strong("association"), ", it tells you 
        that patients who received partial nephrectomy had less decline, 
        adjusting for measured covariates. It does ", strong("not"), " tell you 
        what would happen if you ", em("assigned"), " a patient to partial vs. 
        radical nephrectomy. That requires a causal design: randomization, 
        instrumental variables, or carefully constructed observational methods 
        with sensitivity analyses for unmeasured confounding.")
    )
  })
}

shinyApp(ui, server)

Try it yourself (Section 7). Three experiments, each of which should make performance worse in an instructive way:

Add pathologic_size_cm to classification_predictors and re-run. Discrimination will jump. Explain which rule from Section 3.6 this violates and at what moment in the clinical timeline the variable becomes available. (Hint: pathologic size is measured on the resected specimen, it is not available preoperatively. Including it is a form of information leakage.)
Replace the stratified folds with sample()-based random folds and repeat the run several times. How much does the out-of-fold AUC move purely from fold assignment? (Hint: with only 9 benign cases in training, random folds may put 0 or 1 benign cases in some folds. The AUC can swing by $\pm 0.10$ or more. This is resampling instability.)
Set the operating threshold to 0.5 instead of the out-of-fold Youden value. Recompute sensitivity and specificity, and decide which threshold you would defend to a surgeon. (Hint: at threshold 0.5, you may achieve slightly higher specificity at the cost of sensitivity. But given 92.5% prevalence, the “cost” of missing a malignancy is high, you may prefer the Youden threshold that maintains 100% sensitivity.)

8. Time-to-Event and Longitudinal Modeling

Imaging biomarkers frequently predict when an event will occur or how a biological quantity changes over time. Collapsing these structures into a single binary or cross-sectional outcome wastes information and can introduce bias.

Why time-to-event analysis? Consider two patients: one who dies at 6 months and another who dies at 5 years. A binary “dead at 5 years” outcome treats them identically, discarding clinically critical information. Time-to-event methods use the full follow-up duration and correctly handle patients who are still alive at last contact (right-censored). In oncology, this is the difference between estimating “5-year survival” and modeling the entire survival experience.

8.1 Survival, hazard, and cumulative incidence

For event time $T\ge 0$, define the survival function

\[ S(t)=P(T>t), \qquad F(t)=P(T\le t)=1-S(t), \]

and the hazard function

\[ h(t)=\lim_{\Delta t\to 0} \frac{P(t\le T<t+\Delta t\mid T\ge t)}{\Delta t}. \]

When differentiable,

\[h(t)=-\frac{d}{dt}\log S(t), \qquad S(t)=\exp\left\{-\int_0^t h(u)\,du\right\}. \]

Visualizing the Survival-Hazard Relationship

The three quantities, survival $S(t)$, cumulative hazard $H(t) = \int_0^t h(u)\,du$, and hazard $h(t)$, are mathematically linked but tell different clinical stories.

Survival answers “what fraction are still alive?”
Cumulative hazard answers “how much risk has accumulated?”
Hazard answers “what is the instantaneous risk right now?”.

## Visualize how S(t), H(t), and h(t) relate for a simple Weibull model.
library(ggplot2)
library(patchwork)
library(dplyr)

t_seq <- seq(0, 5, by = 0.05)

# Weibull: h(t) = shape * scale^shape * t^(shape-1)
# shape > 1: hazard increases over time (aging, tumor progression)
# shape < 1: hazard decreases (post-surgical recovery)
shape <- 1.5
scale <- 1.0

hazard <- shape * (scale^shape) * (t_seq^(shape - 1))
cum_hazard <- (t_seq / scale)^shape
survival <- exp(-cum_hazard)

viz_df <- data.frame(
  t = rep(t_seq, 3),
  value = c(survival, cum_hazard, hazard),
  quantity = rep(c("S(t): Survival", "H(t): Cumulative Hazard", "h(t): Instantaneous Hazard"), each = length(t_seq))
)

ggplot(viz_df, aes(x = t, y = value, color = quantity)) +
  geom_line(size = 1.2) +
  facet_wrap(~ quantity, scales = "free_y", ncol = 3) +
  scale_color_manual(values = c("#2166ac", "#b2182b", "#d95f02")) +
  geom_hline(data = data.frame(quantity = "S(t): Survival", yint = 0.5),
             aes(yintercept = yint), lty = 2, color = "grey50") +
  labs(title = "Survival, Cumulative Hazard, and Instantaneous Hazard (Weibull model)",
       subtitle = "shape = 1.5 (hazard increases over time, e.g., tumor progression)",
       x = "Time since surgery (years)",
       y = "Value") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "none")

A hazard ratio is not a ratio of event probabilities. If a treatment has a hazard ratio (HR) of 0.5, this does not mean the treatment halves the probability of death. It means the instantaneous risk at any given time is halved. The cumulative effect on survival depends on the entire hazard function over time. A constant HR of 0.5 might reduce 5-year mortality from 60% to 37% (not 30%), depending on the baseline hazard shape. This is why reporting HRs without survival curves is misleading.

8.2 Kaplan–Meier estimation

At ordered event times $t_j$, let $d_j$ be the number of events and $n_j$ the number at risk immediately before $t_j$. The Kaplan-Meier estimator is

\[\widehat S(t)=\prod_{t_j\le t}\left(1-\frac{d_j}{n_j}\right).\]

## REAL right-censored survival: 'censored' vs 'dead' with follow-up in days.
km_time  <- kidney_model$followup_days / 365.25
km_event <- kidney_model$event_observed

## Kaplan-Meier estimator computed from first principles.
km_estimate <- function(time, event) {
  ord <- order(time); time <- time[ord]; event <- event[ord]
  n <- length(time); at_risk <- n; surv <- 1
  out <- data.frame(time = 0, n_risk = n, n_event = 0, survival = 1)
  for (tt in unique(time[event == 1])) {
    d <- sum(time == tt & event == 1)
    r <- sum(time >= tt)
    surv <- surv * (1 - d / r)
    out <- rbind(out, data.frame(time = tt, n_risk = r, n_event = d,
                                 survival = surv))
  }
  out
}
km_manual <- km_estimate(km_time, km_event)

op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
## x-range must cover CENSORED follow-up, which extends past the last death.
plot(km_manual$time, km_manual$survival, type = "s", lwd = 2, col = "#2c7fb8",
     xlim = c(0, max(km_time)), ylim = c(0.7, 1), xlab = "Years since surgery",
     ylab = "Overall survival", main = "Kaplan-Meier (from scratch)")
rug(km_time[km_event == 0], col = "grey60")   # tick marks = censoring times

## Stratified by tumor size above/below the cohort median.
size_group <- ifelse(kidney_model$radiographic_size_cm >
                       median(kidney_model$radiographic_size_cm, na.rm = TRUE),
                     "large", "small")
plot(NA, xlim = range(km_time), ylim = c(0.6, 1), xlab = "Years since surgery",
     ylab = "Overall survival", main = "Stratified by tumor size")
cols <- c(small = "#1b9e77", large = "#d95f02")
for (g in names(cols)) {
  kk <- km_estimate(km_time[size_group == g], km_event[size_group == g])
  lines(kk$time, kk$survival, type = "s", lwd = 2, col = cols[g])
}
legend("bottomleft", names(cols), col = cols, lwd = 2, bty = "n")

par(op)

if (has_pkg("survival")) {
  fit_km <- survival::survfit(
    survival::Surv(km_time, km_event) ~ 1)
  print(summary(fit_km, times = c(1, 2, 3))[c("time", "n.risk", "surv", "lower", "upper")])
}

## $time
## [1] 1 2 3
## 
## $n.risk
## [1] 152 118  71
## 
## $surv
## [1] 0.9492560 0.9000829 0.8702635
## 
## $lower
## [1] 0.9174074 0.8542941 0.8156969
## 
## $upper
## [1] 0.9822102 0.9483259 0.9284803

c(n = length(km_time), deaths = sum(km_event),
  censored = sum(km_event == 0),
  median_followup_years = round(median(km_time), 2))

##                     n                deaths              censored 
##                210.00                 21.00                189.00 
## median_followup_years 
##                  2.16

Visualization of Numbers at Risk

A proper survival plot must display the numbers at risk at key time points. Without this, the viewer cannot judge whether the tail of the curve is based on 50 patients or 5. The visualization below uses ggplot2 to combine the KM curve, censoring marks, confidence bands, and a risk table.

library(ggplot2)
library(dplyr)
library(survival)
library(patchwork)

# Prepare data with stratification
surv_df <- data.frame(
  time = km_time,
  event = km_event,
  group = size_group
)

# Fit survival curves
surv_fit <- survfit(Surv(time, event) ~ group, data = surv_df)

# Extract data for plotting
plot_data <- data.frame(
  time = surv_fit$time,
  surv = surv_fit$surv,
  upper = surv_fit$upper,
  lower = surv_fit$lower,
  n.event = surv_fit$n.event,
  n.censor = surv_fit$n.censor,
  group = rep(names(surv_fit$strata), surv_fit$strata)
)

# Clean group labels for legend/table
plot_data$group <- gsub("group=", "", plot_data$group)

# Censoring times
censor_data <- plot_data[plot_data$n.censor > 0, ]

# Numbers at risk table
risk_times <- c(0, 1, 2, 3, 4, 5)
risk_table <- data.frame()
for (g in unique(surv_df$group)) {
  sub <- surv_df[surv_df$group == g, ]
  for (t in risk_times) {
    n_risk <- sum(sub$time >= t)
    risk_table <- rbind(risk_table, data.frame(time = t, n_risk = n_risk, group = g))
  }
}

# Clean group names and labels
risk_table$group <- factor(risk_table$group, levels = c("large", "small"))

# Log-rank test
logrank <- survdiff(Surv(time, event) ~ group, data = surv_df)
p_value <- 1 - pchisq(logrank$chisq, df = length(logrank$n) - 1)

# Main plot
p_main <- ggplot(plot_data, aes(x = time, y = surv, color = group)) +
  geom_step(linewidth = 1.2) +
  geom_ribbon(aes(ymin = lower, ymax = upper, fill = group), 
              alpha = 0.15, color = NA) +
  geom_point(data = censor_data, aes(y = surv), shape = 3, size = 2) +
  annotate("text", x = 4, y = 0.95, 
           label = sprintf("Log-rank p = %.3f", p_value),
           size = 4, hjust = 0) +
  scale_color_manual(values = c("small" = "#1b9e77", "large" = "#d95f02"),
                     labels = c("Small tumor (< median)", "Large tumor (≥ median)")) +
  scale_fill_manual(values = c("small" = "#1b9e77", "large" = "#d95f02")) +
  scale_x_continuous(breaks = risk_times) +
  coord_cartesian(xlim = c(0, 5)) +
  labs(title = "Kaplan-Meier Survival: Stratified by Tumor Size",
       subtitle = "Cross marks = censored observations | Shaded bands = 95% CI",
       x = NULL, # Removed x-axis title from main plot so it stays clean
       y = "Overall survival probability") +
  ylim(0.5, 1) +
  theme_minimal(base_size = 13) +
  theme(legend.position = "bottom",
        legend.title = element_blank(),
        axis.text.x = element_blank()) # Hide x-axis labels on main plot

# Risk table (Separated by group rows)
p_risk <- ggplot(risk_table, aes(x = time, y = group, label = n_risk, color = group)) +
  geom_text(size = 3.8, fontface = "bold") +
  scale_color_manual(values = c("small" = "#1b9e77", "large" = "#d95f02")) +
  scale_x_continuous(breaks = risk_times) +
  coord_cartesian(xlim = c(0, 5)) +
  scale_y_discrete(labels = c("large" = "Large", "small" = "Small")) +
  labs(x = "Years since surgery", y = "") +
  theme_minimal(base_size = 11) +
  theme(panel.grid = element_blank(),
        legend.position = "none",
        axis.text.x = element_text(size = 11, face = "bold"),
        axis.text.y = element_text(size = 11, face = "bold", color = "grey30"),
        plot.margin = margin(t = -10, r = 10, b = 10, l = 10))

# Combine with patchwork (aligning x-axes cleanly)
p_main / p_risk + plot_layout(heights = c(4, 1.2))

Censoring is not missing data. A patient recorded as censored at 1,420 days is known to have survived at least that long. Deleting them or treating them as event-free at a fixed horizon both distort the estimate. Note also that with 21 deaths among 210 patients, the survival curve is precise early and very uncertain in its tail, the risk set thins quickly.

A visual separation is descriptive. Confounding, nonproportional hazards, small risk sets, and informative censoring can alter interpretation. Always display numbers at risk and uncertainty in a formal report.

Interactive Exploration: Censoring, Risk Sets, and Stratification

The next app supports exploring how censoring patterns and stratification variables affect the KM estimate

Adjust the censoring pattern to see how informative vs. non-informative censoring changes the curve
Stratify by different variables (tumor size, age, surgical approach) to compare groups
View the risk set at different time points to understand where the curve is precise vs. uncertain

library(shiny)
library(ggplot2)
library(dplyr)
library(survival)
library(patchwork)

# Prepare data
surv_app_data <- kidney_model[complete.cases(kidney_model$followup_days, 
                                              kidney_model$event_observed), ]
surv_app_data$time <- surv_app_data$followup_days / 365.25
surv_app_data$event <- surv_app_data$event_observed

# Create stratification variables
surv_app_data$size_group <- ifelse(surv_app_data$radiographic_size_cm > 
                                     median(surv_app_data$radiographic_size_cm, na.rm = TRUE),
                                   "Large tumor", "Small tumor")
surv_app_data$age_group <- ifelse(surv_app_data$age_at_nephrectomy > 
                                    median(surv_app_data$age_at_nephrectomy, na.rm = TRUE),
                                  "Older", "Younger")
surv_app_data$surgery_group <- ifelse(surv_app_data$surgery_type == "radical",
                                      "Radical", "Partial")

ui <- fluidPage(
  titlePanel("Kaplan-Meier Explorer"),
  sidebarLayout(
    sidebarPanel(
      radioButtons("stratify", "Stratify by:",
                   choices = c("None", "Tumor size", "Age", "Surgical approach"),
                   selected = "None"),
      sliderInput("censor_rate", "Additional censoring rate (%):",
                  min = 0, max = 80, value = 0, step = 5),
      checkboxInput("show_ci", "Show 95% confidence intervals", value = TRUE),
      checkboxInput("show_censor_marks", "Show censoring marks", value = TRUE),
      checkboxInput("show_risk_table", "Show numbers at risk table", value = TRUE),
      sliderInput("time_horizon", "Time horizon (years):",
                  min = 1, max = 8, value = 6, step = 0.5),
      hr(),
      helpText("Adjust the censoring rate to simulate loss to follow-up. 
               Higher censoring thins the risk set and widens confidence 
               intervals in the tail of the curve.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Survival Curve", plotOutput("kmPlot", height = "500px")),
        tabPanel("Risk Set Analysis", 
                 plotOutput("riskPlot", height = "400px"),
                 tableOutput("riskTable")),
        tabPanel("Log-rank Test", 
                 verbatimTextOutput("logrankText"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  plot_data <- reactive({
    df <- surv_app_data
    
    # Apply additional censoring
    if (input$censor_rate > 0) {
      set.seed(123)
      n_censor <- floor(nrow(df) * input$censor_rate / 100)
      censor_idx <- sample(seq_len(nrow(df)), n_censor)
      new_time <- runif(n_censor, 0.1, df$time[censor_idx])
      df$event[censor_idx] <- 0
      df$time[censor_idx] <- new_time
    }
    
    # Stratification
    if (input$stratify == "None") {
      df$group <- "All patients"
    } else if (input$stratify == "Tumor size") {
      df$group <- df$size_group
    } else if (input$stratify == "Age") {
      df$group <- df$age_group
    } else if (input$stratify == "Surgical approach") {
      df$group <- df$surgery_group
    }
    
    df
  })
  
  km_fit <- reactive({
    df <- plot_data()
    survfit(Surv(time, event) ~ group, data = df)
  })
  
  output$kmPlot <- renderPlot({
    df <- plot_data()
    fit <- km_fit()
    
    # FIX: Safely construct group vector whether strata exists or not
    if (is.null(fit$strata)) {
      group_vec <- rep("All patients", length(fit$time))
    } else {
      # Strip "group=" prefix generated by survfit formula
      clean_names <- gsub("^group=", "", names(fit$strata))
      group_vec <- rep(clean_names, fit$strata)
    }
    
    # Extract plot data safely
    plot_df <- data.frame(
      time = fit$time,
      surv = fit$surv,
      upper = fit$upper,
      lower = fit$lower,
      n.censor = fit$n.censor,
      group = group_vec,
      stringsAsFactors = FALSE
    )
    
    censor_df <- plot_df[plot_df$n.censor > 0, ]
    
    # Risk table
    risk_times <- seq(0, input$time_horizon, by = 1)
    risk_table <- data.frame()
    for (g in unique(df$group)) {
      sub <- df[df$group == g, ]
      for (t in risk_times) {
        n_risk <- sum(sub$time >= t)
        risk_table <- rbind(risk_table, data.frame(time = t, n_risk = n_risk, group = g))
      }
    }
    
    # Colors
    unique_groups <- unique(df$group)
    n_groups <- length(unique_groups)
    colors <- if (n_groups == 1) c("All patients" = "#2c7fb8") else setNames(c("#1b9e77", "#d95f02"), unique_groups)
    
    # Main plot
    p <- ggplot(plot_df, aes(x = time, y = surv, color = group)) +
      geom_step(linewidth = 1.2)
    
    if (input$show_ci) {
      p <- p + geom_ribbon(aes(ymin = lower, ymax = upper, fill = group), 
                           alpha = 0.15, color = NA)
    }
    
    if (input$show_censor_marks && nrow(censor_df) > 0) {
      p <- p + geom_point(data = censor_df, aes(y = surv), shape = 3, size = 2)
    }
    
    p <- p +
      scale_color_manual(values = colors) +
      scale_fill_manual(values = colors) +
      scale_x_continuous(breaks = risk_times) +
      coord_cartesian(xlim = c(0, input$time_horizon)) +
      labs(title = "Kaplan-Meier Survival Curve",
           subtitle = sprintf("Censoring: %d%% additional | Groups: %s",
                              input$censor_rate,
                              paste(unique_groups, collapse = " vs ")),
           x = NULL,
           y = "Overall survival probability") +
      ylim(0, 1) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom",
            legend.title = element_blank(),
            axis.text.x = if(input$show_risk_table) element_blank() else element_text())
    
    # Log-rank p-value
    if (n_groups > 1) {
      logrank <- survdiff(Surv(time, event) ~ group, data = df)
      p_value <- 1 - pchisq(logrank$chisq, df = n_groups - 1)
      p <- p + annotate("text", x = input$time_horizon * 0.65, y = 0.95,
                        label = sprintf("Log-rank p = %.3f", p_value),
                        size = 4, hjust = 0)
    }
    
    # Risk table (FIX: y = group prevents text overlap across strata)
    if (input$show_risk_table) {
      p_risk <- ggplot(risk_table, aes(x = time, y = group, label = n_risk, color = group)) +
        geom_text(size = 3.8, fontface = "bold") +
        scale_color_manual(values = colors) +
        scale_x_continuous(breaks = risk_times) +
        coord_cartesian(xlim = c(0, input$time_horizon)) +
        labs(x = "Years since surgery", y = "") +
        theme_minimal(base_size = 11) +
        theme(panel.grid = element_blank(),
              legend.position = "none",
              axis.text.x = element_text(size = 11, face = "bold"),
              axis.text.y = element_text(size = 11, face = "bold", color = "grey30"),
              plot.margin = margin(t = -10, r = 10, b = 10, l = 10))
      
      print(p / p_risk + plot_layout(heights = c(4, 1.2)))
    } else {
      print(p)
    }
  })
  
  output$riskPlot <- renderPlot({
    df <- plot_data()
    
    risk_times <- seq(0, input$time_horizon, by = 0.5)
    risk_data <- data.frame()
    for (g in unique(df$group)) {
      sub <- df[df$group == g, ]
      for (t in risk_times) {
        n_risk <- sum(sub$time >= t)
        n_events <- sum(sub$time >= t & sub$event == 1 & sub$time < t + 0.5)
        risk_data <- rbind(risk_data, data.frame(time = t, n_risk = n_risk, 
                                                 n_events = n_events, group = g))
      }
    }
    
    unique_groups <- unique(df$group)
    n_groups <- length(unique_groups)
    colors <- if (n_groups == 1) c("All patients" = "#2c7fb8") else setNames(c("#1b9e77", "#d95f02"), unique_groups)
    
    ggplot(risk_data, aes(x = time, y = n_risk, color = group)) +
      geom_step(linewidth = 1.2) +
      scale_color_manual(values = colors) +
      scale_x_continuous(breaks = seq(0, input$time_horizon, by = 1)) +
      coord_cartesian(xlim = c(0, input$time_horizon)) +
      labs(title = "Risk Set Size Over Time",
           subtitle = "As the risk set shrinks, the KM curve becomes less precise",
           x = "Years since surgery",
           y = "Number at risk") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom",
            legend.title = element_blank())
  })
  
  output$riskTable <- renderTable({
    df <- plot_data()
    risk_times <- seq(0, input$time_horizon, by = 1)
    
    table_data <- data.frame(Time = risk_times)
    for (g in unique(df$group)) {
      sub <- df[df$group == g, ]
      n_risk <- sapply(risk_times, function(t) sum(sub$time >= t))
      table_data[[g]] <- n_risk
    }
    table_data
  }, striped = TRUE, hover = TRUE, width = "100%")
  
  output$logrankText <- renderPrint({
    df <- plot_data()
    n_groups <- length(unique(df$group))
    
    if (n_groups == 1) {
      cat("No log-rank test performed (only one group).\n")
      cat("Select a stratification variable to compare groups.\n")
      return()
    }
    
    cat("Log-Rank Test for Difference in Survival\n")
    cat("=========================================\n\n")
    
    logrank <- survdiff(Surv(time, event) ~ group, data = df)
    p_value <- 1 - pchisq(logrank$chisq, df = n_groups - 1)
    
    cat("Groups:", paste(names(logrank$n), collapse = " vs "), "\n")
    cat("Events per group:", paste(logrank$obs, collapse = " vs "), "\n")
    cat("Expected events:", paste(round(logrank$exp, 1), collapse = " vs "), "\n")
    cat("\nChi-square statistic:", round(logrank$chisq, 3), "\n")
    cat("Degrees of freedom:", n_groups - 1, "\n")
    cat("p-value:", round(p_value, 4), "\n\n")
    
    if (p_value < 0.05) {
      cat("✓ Statistically significant difference in survival (p < 0.05).\n")
      cat("This suggests the groups have different survival experiences,\n")
      cat("but does NOT imply causation (confounding may be present).\n")
    } else {
      cat("✗ No statistically significant difference detected (p ≥ 0.05).\n")
      cat("This may be due to small sample size, so absence of evidence\n")
      cat("is not evidence of absence.\n")
    }
    
    cat("\n--- Interpretation ---\n")
    cat("The log-rank test compares observed vs expected events under the\n")
    cat("null hypothesis that both groups have the same survival function.\n")
    cat("It is most powerful when hazards are proportional over time.\n")
  })
}

shinyApp(ui, server)

Discussion Questions

Censoring assumptions. Increase the additional censoring rate to 40%. Where does the confidence interval widen most? Why? Does the point estimate of the survival curve change, or just its uncertainty?
Risk set depletion. Look at the “Risk Set Analysis” tab. At what time point does the risk set become too small (< 10 patients) to trust the survival estimate? How would you report this in a paper?
Stratification and confounding. Stratify by surgical approach. Does the survival difference look causal? What confounders might explain the observed difference? (Hint: patients selected for partial nephrectomy may have smaller tumors, better baseline health, etc.)
Proportional hazards. If the two KM curves cross, does the log-rank test still make sense? What alternative tests exist for non-proportional hazards?
Clinical relevance. The survival difference between groups may be statistically significant but clinically trivial. How would you decide what magnitude of survival difference matters for clinical decision-making?

Here is a proposed enhancement for Sections 8.3 and 8.4. The enhancements preserve the mathematical foundations and existing code, but add a forest plot with confidence intervals, a callout on the proportional hazards assumption, a visual schematic of landmark analysis, and an interactive Shiny app that lets learners manipulate landmark times and view how the risk set and predictions change dynamically.

8.3 Cox proportional-hazards modeling

The Cox model is

\[h(t\mid X)=h_0(t)\exp(X^\top\beta).\]

The hazard ratio for a one-unit change in $X_j$ is $e^{\beta_j}$ when the proportional-hazards assumption holds. The baseline hazard $h_0(t)$ is left unspecified.

Why Cox PH as a baseline? The Cox model is the workhorse of survival analysis because it estimates the effect of covariates on the hazard function without requiring us to specify the shape of the baseline hazard. This semi-parametric property makes it robust: it does not assume a specific distribution of survival times (unlike parametric models), but it does assume that hazard ratios are constant over time (proportional hazards). If this assumption is violated, the model can give misleading average effects.

The example below is explicitly a postoperative prognostic update among malignant tumors because it includes pathology and invasion. It is not a preoperative model.

if (has_pkg("survival")) {
  surv_obj <- survival::Surv(kidney_model$followup_days / 365.25,
                             kidney_model$event_observed)

  cox_fit <- survival::coxph(
    surv_obj ~ radiographic_size_cm + age_at_nephrectomy + gender +
      chronic_kidney_disease,
    data = kidney_model
  )
  print(summary(cox_fit)$coefficients)
  cat("\nconcordance =", round(summary(cox_fit)$concordance[1], 3), "\n")

  ## Events-per-variable: the binding constraint in this cohort.
  epv <- sum(kidney_model$event_observed) / length(coef(cox_fit))
  cat("events per estimated parameter =", round(epv, 1),
      "(a common rule of thumb asks for >= 10)\n")

  ## Proportional-hazards diagnostic: does any effect drift with time?
  ph_test <- survival::cox.zph(cox_fit)
  print(ph_test$table)
}

##                                  coef exp(coef)   se(coef)          z
## radiographic_size_cm       0.15451476  1.167092 0.05482832  2.8181563
## age_at_nephrectomy         0.02445571  1.024757 0.01836194  1.3318697
## gendermale                 0.66009490  1.934976 0.48637463  1.3571738
## chronic_kidney_diseaseyes -0.12061511  0.886375 0.76961063 -0.1567223
##                              Pr(>|z|)
## radiographic_size_cm      0.004830029
## age_at_nephrectomy        0.182903025
## gendermale                0.174725998
## chronic_kidney_diseaseyes 0.875463746
## 
## concordance = 0.735 
## events per estimated parameter = 5.2 (a common rule of thumb asks for >= 10)
##                            chisq df         p
## radiographic_size_cm   0.8887236  1 0.3458234
## age_at_nephrectomy     2.0169700  1 0.1555493
## gender                 0.1746120  1 0.6760451
## chronic_kidney_disease 0.4251526  1 0.5143771
## GLOBAL                 3.3572349  4 0.4999153

## Forest plot with confidence intervals for hazard ratios.
library(ggplot2)
library(dplyr)

if (has_pkg("survival")) {
  cox_sum <- summary(cox_fit)$coefficients
  
  forest_data <- data.frame(
    term = rownames(cox_sum),
    hr = exp(cox_sum[, "coef"]),
    lower = exp(cox_sum[, "coef"] - 1.96 * cox_sum[, "se(coef)"]),
    upper = exp(cox_sum[, "coef"] + 1.96 * cox_sum[, "se(coef)"]),
    p = cox_sum[, "Pr(>|z|)"]
  )
  
  # Cleanly rename specific levels
  forest_data$term <- dplyr::recode(forest_data$term,
    "gendermale" = "genderMale",
    "chronic_kidney_diseaseyes" = "ckdYes"
  )
  
  # Order factors by hazard ratio safely
  forest_data$term <- factor(forest_data$term, 
                             levels = forest_data$term[order(forest_data$hr)])
  
  ggplot(forest_data, aes(x = hr, y = term)) +
    geom_vline(xintercept = 1, lty = 2, color = "grey50") +
    geom_errorbarh(aes(xmin = lower, xmax = upper), height = 0.2, color = "#2166ac") +
    geom_point(size = 3, color = "#2166ac") +
    scale_x_log10() +
    annotation_logticks(sides = "b") +
    labs(title = "Cox Model: Hazard Ratios with 95% CI",
         subtitle = "Log scale. CI crossing 1 indicates non-significance.",
         x = "Hazard Ratio (log scale)",
         y = "Predictor") +
    theme_minimal(base_size = 12)
}

Tumor size carries a clear, statistically supported hazard: each additional centimeter multiplies the instantaneous death rate by roughly the reported hazard ratio, adjusted for age, sex, and baseline kidney disease. That is a real prognostic signal recovered from real censored follow-up.

if (has_pkg("survival")) {
  op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
  ## Baseline cumulative hazard and survival for an average covariate profile.
  bh <- survival::basehaz(cox_fit, centered = TRUE)
  plot(bh$time, bh$hazard, type = "s", lwd = 2, col = "#2c7fb8",
       xlab = "Years", ylab = "Cumulative hazard",
       main = "Baseline cumulative hazard")

  ## Predicted survival for contrasting real covariate profiles.
  newpat <- data.frame(
    radiographic_size_cm = quantile(kidney_model$radiographic_size_cm,
                                    c(0.1, 0.5, 0.9), na.rm = TRUE),
    age_at_nephrectomy = median(kidney_model$age_at_nephrectomy, na.rm = TRUE),
    gender = factor("male", levels = levels(kidney_model$gender)),
    chronic_kidney_disease = factor("no",
      levels = levels(kidney_model$chronic_kidney_disease))
  )
  sf <- survival::survfit(cox_fit, newdata = newpat)
  plot(sf, col = c("#1b9e77", "#2c7fb8", "#d95f02"), lwd = 2, ylim = c(0.6, 1),
       xlab = "Years since surgery", ylab = "Predicted survival",
       main = "Risk profiles (10th/50th/90th size pct)")
  legend("bottomleft", paste0(c("10th", "50th", "90th"), " pct size"),
         col = c("#1b9e77", "#2c7fb8", "#d95f02"), lwd = 2, bty = "n", cex = 0.8)
  par(op)
}

The Proportional Hazards Assumption is not guaranteed. The cox.zph test checks whether each covariate’s effect changes over time. If a test is significant (p < 0.05), the PH assumption is violated for that variable. This often happens with

Treatments whose effects wane or grow over time.
Age, where very old patients may experience a different hazard trajectory.
Biomarkers measured at baseline but whose predictive value decays (e.g., tumor markers that rise as disease progresses).

If PH is violated, you can stratify by the offending variable, use time-varying coefficients, or switch to a model that allows non-proportional effects.

Try it yourself. Add tumor_isup_grade to the Cox model. It is missing for 38 patients, so coxph() will silently drop them and change the risk set. Compare the hazard ratio for tumor size before and after. How much of any change is biology, and how much is the altered analysis sample?

Discrimination is not enough. Prognostic models require calibration of absolute risk at clinically relevant horizons, assessment of proportional hazards, and evaluation under competing risks. Bootstrap or cross-validation should include the entire model-development process.

8.4 Time-dependent prediction and landmarking

When imaging or laboratory values are updated during follow-up, a model can predict from a landmark time $s$

\[ P(T>s+\tau\mid T>s,\mathcal H(s)), \]

where $\mathcal H(s)$ is information observed up to $s$. Measurements after $s$ are forbidden. Repeating landmark models at several $s$ values creates dynamic predictions without treating future observations as baseline predictors.

Time-dependent AUC and Brier scores account for censoring. Their definition depends on the horizon and weighting scheme, so a report should state precisely which estimator was used.

Visualizing the Landmark Concept

In a baseline (t=0) prediction, we use only information available at surgery to predict future survival. In a landmark prediction, we first condition on the patient having survived to time $s$ (e.g., 1 year post-surgery). We then update their risk factors using information collected up to $s$ (e.g., pathology results, imaging recurrences) and predict survival for the next $\tau$ years. This prevents using information from after $s$ to predict survival from baseline, which would be leakage.

Interactive Exploration: Landmark Analysis and Dynamic Risk

The app below lets you set a landmark time $s$ and prediction window $\tau$. It visualizes which patients are eligible for the landmark prediction (those who survive to $s$) and how their predicted survival differs from the baseline model.

library(shiny)
library(ggplot2)
library(survival)
library(dplyr)

# Ensure cox_fit exists from the previous section
# If for some reason it doesn't exist, we create a dummy fit to prevent app crash
if (!exists("cox_fit") && has_pkg("survival")) {
  surv_obj <- survival::Surv(kidney_model$followup_days / 365.25, kidney_model$event_observed)
  cox_fit <- survival::coxph(surv_obj ~ radiographic_size_cm + age_at_nephrectomy, data = kidney_model)
}

ui <- fluidPage(
  titlePanel("Landmark Analysis Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("landmark_s", "Landmark time s (years):",
                  min = 0.5, max = 5, value = 1, step = 0.5),
      sliderInput("pred_window", "Prediction window τ (years):",
                  min = 0.5, max = 5, value = 2, step = 0.5),
      hr(),
      helpText("This app visualizes landmark analysis. Patients who experience 
               the event or are censored before time s are excluded from the 
               landmark risk set. The survival curve is reset to 1.0 at time s 
               to reflect conditional survival.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Survival Prediction", plotOutput("landmarkPlot", height = "400px")),
        tabPanel("Risk Set", 
                 plotOutput("riskSetPlot", height = "300px"),
                 tableOutput("eligibleTable")),
        tabPanel("Concept", uiOutput("formulaText"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  # Reactive to calculate eligible patients and landmark predictions
  landmark_data <- reactive({
    req(has_pkg("survival"))
    s <- input$landmark_s
    
    # 1. Identify eligible patients (survived to s)
    time_yrs <- kidney_model$followup_days / 365.25
    event <- kidney_model$event_observed
    
    # Eligible: follow-up time >= s
    # (In a strict landmark analysis, those censored before s are excluded)
    eligible_idx <- which(time_yrs >= s)
    
    # Create new data for prediction: "average" patient at landmark
    newpat_landmark <- data.frame(
      radiographic_size_cm = median(kidney_model$radiographic_size_cm, na.rm = TRUE),
      age_at_nephrectomy = median(kidney_model$age_at_nephrectomy, na.rm = TRUE),
      gender = factor("male", levels = levels(kidney_model$gender)),
      chronic_kidney_disease = factor("no", levels = levels(kidney_model$chronic_kidney_disease))
    )
    
    # Predict survival from baseline for average patient
    sf_baseline <- survival::survfit(cox_fit, newdata = newpat_landmark)
    
    # For landmark prediction, we need survival conditional on S(t) > s
    # S(t | T > s) = S(t) / S(s) for t > s
    # Find S(s) - the survival probability at the landmark time
    valid_times <- sf_baseline$time[sf_baseline$time <= s]
    if (length(valid_times) > 0) {
      s_idx <- max(which(sf_baseline$time <= s))
      surv_at_s <- sf_baseline$surv[s_idx]
    } else {
      surv_at_s <- 1
    }
    
    # Adjust survival curve for times >= s
    lm_idx <- sf_baseline$time >= s
    lm_time <- sf_baseline$time[lm_idx] - s
    lm_surv <- sf_baseline$surv[lm_idx] / surv_at_s
    
    list(
      sf_baseline = sf_baseline,
      lm_time = lm_time,
      lm_surv = lm_surv,
      eligible_n = length(eligible_idx),
      total_n = nrow(kidney_model)
    )
  })
  
  output$landmarkPlot <- renderPlot({
    d <- landmark_data()
    
    # Baseline survival (from t=0)
    base_df <- data.frame(
      time = d$sf_baseline$time,
      surv = d$sf_baseline$surv,
      type = "Baseline (from t=0)"
    )
    
    # Landmark survival (conditional on T > s)
    # Shift time back by s so the landmark curve starts at 0 on the plot?
    # No, for visual comparison on the same axis, we keep absolute time.
    lm_df <- data.frame(
      time = d$lm_time + input$landmark_s,
      surv = d$lm_surv,
      type = "Landmark (conditional on T > s)"
    )
    
    plot_df <- rbind(base_df, lm_df)
    
    ggplot(plot_df, aes(x = time, y = surv, color = type)) +
      geom_step(size = 1.2) +
      geom_vline(xintercept = input$landmark_s, lty = 2, color = "red", size = 1) +
      annotate("text", x = input$landmark_s + 0.1, y = 0.95, 
               label = sprintf("Landmark s = %.1f yrs", input$landmark_s), 
               color = "red", hjust = 0) +
      scale_color_manual(values = c("Baseline (from t=0)" = "#2166ac", 
                                    "Landmark (conditional on T > s)" = "#d95f02")) +
      labs(title = "Baseline vs. Landmark Survival Prediction",
           subtitle = sprintf("Prediction window τ = %.1f years | Eligible: %d of %d patients",
                              input$pred_window, d$eligible_n, d$total_n),
           x = "Years since surgery",
           y = "Survival Probability") +
      ylim(0, 1) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom",
            legend.title = element_blank())
  })
  
  output$riskSetPlot <- renderPlot({
    s <- input$landmark_s
    time_yrs <- kidney_model$followup_days / 365.25
    
    time_seq <- seq(0, 8, by = 0.5)
    risk_set <- sapply(time_seq, function(t) sum(time_yrs >= t))
    
    risk_df <- data.frame(time = time_seq, n_at_risk = risk_set)
    
    ggplot(risk_df, aes(x = time, y = n_at_risk)) +
      geom_step(size = 1.2, color = "#2166ac") +
      geom_vline(xintercept = s, lty = 2, color = "red", size = 1) +
      annotate("text", x = s + 0.1, y = max(risk_set) * 0.9,
               label = sprintf("At s = %.1f yrs: %d eligible", s, sum(time_yrs >= s)),
               color = "red", hjust = 0) +
      labs(title = "Risk Set Size Over Time",
           subtitle = "Patients who die or are censored before the landmark time are excluded",
           x = "Years since surgery",
           y = "Number at risk") +
      theme_minimal(base_size = 13)
  })
  
  output$eligibleTable <- renderTable({
    d <- landmark_data()
    eligible_summary <- data.frame(
      Metric = c("Total patients", "Eligible at landmark s", "Ineligible (died/censored before s)",
                 "Eligibility rate (%)"),
      Value = c(d$total_n, d$eligible_n, 
                d$total_n - d$eligible_n,
                round(100 * d$eligible_n / d$total_n, 1))
    )
    eligible_summary
  }, striped = TRUE, hover = TRUE, width = "100%")
  
  output$formulaText <- renderUI({
    tagList(
      h4("Landmark Prediction Formula"),
      p("P(T > s + τ | T > s, H(s))"),
      p(strong("where:"), 
        "s = ", input$landmark_s, " years (landmark time)",
        tags$br(),
        "τ = ", input$pred_window, " years (prediction window)",
        tags$br(),
        "H(s) is the history observed up to time s.")
    )
  })
}

shinyApp(ui, server)

Try it yourself.

Drag the landmark time $s$ to 1 year. Observe how the risk set shrinks and the landmark curve starts at 1.0 (since we condition on survival to $s$).
Compare the 2-year prediction from baseline vs. landmark. The baseline model predicts survival from surgery, while the landmark model predicts survival conditional on having survived 1 year. Which is more relevant for a patient who presents for a 1-year post-surgery follow-up?
Increase $s$ to 3 years. How does the eligible subset change? Why does the landmark prediction become more uncertain as $s$ increases?

8.5 Competing risks

If death from another cause prevents recurrence, the cumulative incidence for cause $k$ is

\[F_k(t)=P(T\le t,J=k),\]

not $1-S_k(t)$ from a Kaplan-Meier analysis that censors competing events. Cause-specific hazards answer etiologic and instantaneous-rate questions. Sub-distribution approaches target cumulative incidence. The clinical question determines the estimand.

Why competing risks matter in kidney cancer. Patients undergoing nephrectomy are often older with comorbidities (hypertension, diabetes, CKD). A patient who dies of a myocardial infarction at 2 years can never die of kidney cancer. If we censor that death (treat it as “lost to follow-up”) in a Kaplan-Meier curve for cancer-specific mortality, we overestimate the probability of cancer death. The cumulative incidence function (CIF) correctly partitions the total probability mass among all competing causes.

Visualizing the Difference: KM vs. CIF

The simulation below generates competing-risk data where patients can die of cancer or cardiovascular disease. It compares the naive Kaplan-Meier (KM) estimate (which censors competing events) to the proper cumulative incidence function (CIF).

## Simulate competing risks to show why KM overestimates cause-specific incidence.
library(ggplot2)
library(dplyr)
library(tidyr)
library(patchwork)

set.seed(42)
n_sims <- 1000

# Simulate time to cancer death (Weibull) and CV death (exponential)
# Cancer: higher hazard for larger tumors
tumor_size <- rnorm(n_sims, mean = 5, sd = 2)
cancer_haz <- 0.1 * exp(0.2 * tumor_size)  # cause-specific hazard for cancer
cv_haz <- 0.05 + 0.01 * tumor_size          # cause-specific hazard for CV death

# Generate event times from cause-specific hazards
t_cancer <- ifelse(runif(n_sims) < cancer_haz / (cancer_haz + cv_haz + 0.02),
                   rexp(n_sims, cancer_haz), Inf)
t_cv <- ifelse(runif(n_sims) < cv_haz / (cancer_haz + cv_haz + 0.02),
               rexp(n_sims, cv_haz), Inf)
t_admin_censor <- rexp(n_sims, 0.02)  # administrative censoring

# Observed time and cause
obs_time <- pmin(t_cancer, t_cv, t_admin_censor)
obs_cause <- ifelse(obs_time == t_cancer, 1, 
                    ifelse(obs_time == t_cv, 2, 0))  # 0=censored, 1=cancer, 2=CV

sim_df <- data.frame(
  time = obs_time,
  cause = obs_cause,
  tumor_size = tumor_size
)

# 1. Naive Kaplan-Meier for cancer death (censors CV deaths)
km_cancer <- survival::survfit(Surv(time, cause == 1) ~ 1, data = sim_df)
km_df <- data.frame(
  time = km_cancer$time,
  km_incidence = 1 - km_cancer$surv,
  method = "Naive KM (censors competing events)"
)

# 2. Cumulative Incidence Function (Aalen-Johansen estimator)
# Using cuminc from cmprsk or manual calculation
# Manual CIF: F_k(t) = integral_0^t S(u-) * h_k(u) du
# For simplicity, use the relationship: CIF_k(t) = sum over event times of S(t_j-) * d_j/n_j
cancer_events <- sim_df[sim_df$cause == 1, ]
cancer_events <- cancer_events[order(cancer_events$time), ]

cif <- 0
cif_df <- data.frame(time = 0, cif = 0)
for (i in seq_len(nrow(cancer_events))) {
  t_j <- cancer_events$time[i]
  # S(t_j-) = overall survival just before t_j (KM for any event)
  s_before <- km_cancer$surv[max(which(km_cancer$time < t_j))]
  d_j <- sum(sim_df$cause == 1 & abs(sim_df$time - t_j) < 1e-6)
  n_j <- sum(sim_df$time >= t_j)
  cif <- cif + s_before * d_j / n_j
  cif_df <- rbind(cif_df, data.frame(time = t_j, cif = cif))
}

cif_df$method <- "Cumulative Incidence (Aalen-Johansen)"

# Combine for plotting
plot_df <- rbind(
  data.frame(time = km_df$time, incidence = km_df$km_incidence, 
             method = "Naive KM (censors competing events)"),
  data.frame(time = cif_df$time, incidence = cif_df$cif, 
             method = "Cumulative Incidence (Aalen-Johansen)")
)

p1 <- ggplot(plot_df, aes(x = time, y = incidence, color = method)) +
  geom_step(size = 1.2) +
  scale_color_manual(values = c("#d95f02", "#2166ac")) +
  labs(title = "Cancer-Specific Mortality: KM vs. CIF",
       subtitle = "KM overestimates because it treats CV deaths as censored",
       x = "Years since surgery",
       y = "Cumulative incidence of cancer death",
       color = "") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom")

# 2. Show the cause-specific CIFs stacked
cif_cv <- 0
cif_cv_df <- data.frame(time = 0, cif = 0)
cv_events <- sim_df[sim_df$cause == 2, ]
cv_events <- cv_events[order(cv_events$time), ]
for (i in seq_len(nrow(cv_events))) {
  t_j <- cv_events$time[i]
  s_before <- km_cancer$surv[max(which(km_cancer$time < t_j))]
  d_j <- sum(sim_df$cause == 2 & abs(sim_df$time - t_j) < 1e-6)
  n_j <- sum(sim_df$time >= t_j)
  cif_cv <- cif_cv + s_before * d_j / n_j
  cif_cv_df <- rbind(cif_cv_df, data.frame(time = t_j, cif = cif_cv))
}

stacked_df <- data.frame(
  time = c(cif_df$time, cif_cv_df$time),
  incidence = c(cif_df$cif, cif_cv_df$cif),
  cause = c(rep("Cancer death", nrow(cif_df)), 
            rep("CV death", nrow(cif_cv_df)))
)

p2 <- ggplot(stacked_df, aes(x = time, y = incidence, fill = cause)) +
  geom_area(position = "stack", alpha = 0.7) +
  scale_fill_manual(values = c("#2166ac", "#d95f02")) +
  labs(title = "Cumulative Incidence by Cause",
       subtitle = "Total probability mass partitions among competing causes",
       x = "Years since surgery",
       y = "Cumulative incidence",
       fill = "Cause of death") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom")

p1 + p2

The overestimation can be substantial. In this simulation, the naive KM curve overestimates the 5-year cancer mortality by roughly 5-8 percentage points. In an elderly surgical cohort where cardiovascular death is common, the bias can be even larger. Always ask: “What happened to patients who didn’t die of cancer?” If they were censored, your KM curve is biased.

Interactive Exploration: Competing Risks Simulator

This app supports control of the hazard rates for cancer death and competing (cardiovascular, CV) death. Observe how the gap between the naive KM estimate and the true CIF widens as the competing event rate increases.

library(shiny)
library(ggplot2)
library(survival)

ui <- fluidPage(
  titlePanel("Competing Risks: KM vs. CIF Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("cancer_haz", "Cancer hazard rate:",
                  min = 0.01, max = 0.5, value = 0.1, step = 0.01),
      sliderInput("cv_haz", "Competing (CV) hazard rate:",
                  min = 0.01, max = 0.5, value = 0.08, step = 0.01),
      sliderInput("n_sims", "Number of simulated patients:",
                  min = 200, max = 5000, value = 1000, step = 200),
      actionButton("resim", "Re-simulate"),
      hr(),
      helpText("This simulates competing risks (cancer death vs. CV death). 
               The naive KM treats CV deaths as censored, overestimating 
               cancer mortality. The CIF correctly partitions probability.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("KM vs. CIF", plotOutput("mainPlot", height = "400px")),
        tabPanel("Stacked CIF", plotOutput("stackedPlot", height = "400px")),
        tabPanel("Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  sim_data <- eventReactive(input$resim, {
    set.seed(round(runif(1) * 1e6))
    n <- input$n_sims
    
    t_cancer <- rexp(n, input$cancer_haz)
    t_cv <- rexp(n, input$cv_haz)
    t_admin <- rexp(n, 0.02)
    
    obs_time <- pmin(t_cancer, t_cv, t_admin)
    obs_cause <- ifelse(obs_time == t_cancer, 1,
                        ifelse(obs_time == t_cv, 2, 0))
    
    data.frame(time = obs_time, cause = obs_cause)
  })
  
  output$mainPlot <- renderPlot({
    df <- sim_data()
    
    # Naive KM for cancer (censors CV deaths)
    km <- survfit(Surv(time, cause == 1) ~ 1, data = df)
    km_df <- data.frame(time = c(0, km$time), 
                        incidence = c(0, 1 - km$surv),
                        method = "Naive KM (censors CV deaths)")
    
    # CIF via Aalen-Johansen
    cancer_events <- df[df$cause == 1, ]
    cancer_events <- cancer_events[order(cancer_events$time), ]
    
    cif <- 0
    cif_df <- data.frame(time = 0, incidence = 0)
    for (i in seq_len(nrow(cancer_events))) {
      t_j <- cancer_events$time[i]
      idx <- which(km$time < t_j)
      s_before <- if (length(idx) > 0) km$surv[max(idx)] else 1
      d_j <- sum(df$cause == 1 & abs(df$time - t_j) < 1e-6)
      n_j <- sum(df$time >= t_j)
      cif <- cif + s_before * d_j / n_j
      cif_df <- rbind(cif_df, data.frame(time = t_j, incidence = cif))
    }
    cif_df$method <- "Cumulative Incidence (Aalen-Johansen)"
    
    plot_df <- rbind(km_df, cif_df)
    
    ggplot(plot_df, aes(x = time, y = incidence, color = method)) +
      geom_step(size = 1.2) +
      scale_color_manual(values = c("#d95f02", "#2166ac")) +
      labs(title = "Cancer Mortality: Naive KM vs. True CIF",
           subtitle = sprintf("Cancer hazard = %.2f | CV hazard = %.2f",
                              input$cancer_haz, input$cv_haz),
           x = "Years", y = "Cumulative incidence", color = "") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom")
  })
  
  output$stackedPlot <- renderPlot({
    df <- sim_data()
    km <- survfit(Surv(time, cause != 0) ~ 1, data = df)
    
    # CIF for cancer
    cancer_events <- df[df$cause == 1, ]
    cancer_events <- cancer_events[order(cancer_events$time), ]
    cif_c <- 0
    cif_c_df <- data.frame(time = 0, cif = 0)
    for (i in seq_len(nrow(cancer_events))) {
      t_j <- cancer_events$time[i]
      idx <- which(km$time < t_j)
      s_before <- if (length(idx) > 0) km$surv[max(idx)] else 1
      d_j <- sum(df$cause == 1 & abs(df$time - t_j) < 1e-6)
      n_j <- sum(df$time >= t_j)
      cif_c <- cif_c + s_before * d_j / n_j
      cif_c_df <- rbind(cif_c_df, data.frame(time = t_j, cif = cif_c))
    }
    
    # CIF for CV
    cv_events <- df[df$cause == 2, ]
    cv_events <- cv_events[order(cv_events$time), ]
    cif_v <- 0
    cif_v_df <- data.frame(time = 0, cif = 0)
    for (i in seq_len(nrow(cv_events))) {
      t_j <- cv_events$time[i]
      idx <- which(km$time < t_j)
      s_before <- if (length(idx) > 0) km$surv[max(idx)] else 1
      d_j <- sum(df$cause == 2 & abs(df$time - t_j) < 1e-6)
      n_j <- sum(df$time >= t_j)
      cif_v <- cif_v + s_before * d_j / n_j
      cif_v_df <- rbind(cif_v_df, data.frame(time = t_j, cif = cif_v))
    }
    
    stacked <- data.frame(
      time = c(cif_c_df$time, cif_v_df$time),
      incidence = c(cif_c_df$cif, cif_v_df$cif),
      cause = c(rep("Cancer", nrow(cif_c_df)), rep("CV", nrow(cif_v_df)))
    )
    
    ggplot(stacked, aes(x = time, y = incidence, fill = cause)) +
      geom_area(position = "stack", alpha = 0.7) +
      scale_fill_manual(values = c("#2166ac", "#d95f02")) +
      labs(title = "Cumulative Incidence by Cause",
           x = "Years", y = "Cumulative incidence", fill = "Cause") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom")
  })
  
  output$summary <- renderPrint({
    df <- sim_data()
    cat("--- Simulation Summary ---\n")
    cat("Total patients:", nrow(df), "\n")
    cat("Cancer deaths:", sum(df$cause == 1), "\n")
    cat("CV deaths:", sum(df$cause == 2), "\n")
    cat("Censored:", sum(df$cause == 0), "\n\n")
    
    ratio <- input$cv_haz / input$cancer_haz
    if (ratio > 0.5) {
      cat("⚠️  High competing risk ratio (", round(ratio, 2), ").\n", sep = "")
      cat("KM will substantially overestimate cancer-specific mortality.\n")
      cat("The CIF is the appropriate estimand.\n")
    } else {
      cat("✓ Low competing risk ratio. KM and CIF are closer, but CIF is still preferred.\n")
    }
  })
}

shinyApp(ui, server)

8.6 Longitudinal tumor growth as a bridge to differential equations

Chapter 1 introduced exponential and logistic growth. For exponential growth,

\[\frac{dV}{dt}=rV, \qquad V(t)=V_0e^{rt}, \qquad T_d=\frac{\log 2}{r}.\]

A logistic model imposes carrying capacity $K$

\[\frac{dV}{dt}=rV\left(1-\frac{V}{K}\right),\]

\[V(t)=\frac{K}{1+\left(\frac{K-V_0}{V_0}\right)e^{-rt}}.\]

These are mechanistic summaries, not universal tumor laws. Therapy, necrosis, measurement error, and biological regime changes can violate both.

Why growth models matter clinically. The doubling time $T_d$ is a clinically intuitive quantity: a tumor with $T_d = 200$ days is slow-growing and may support active surveillance, while $T_d = 30$ days demands immediate intervention. But doubling time is not constant, it changes as the tumor outgrows its blood supply (logistic deceleration), responds to therapy, or undergoes genetic evolution. A single growth model fitted to serial volumes is a snapshot, not a law.

Visualizing Growth Model Families

## Compare exponential, logistic, and Gompertz growth models.
library(ggplot2)
library(patchwork)

t_seq <- seq(0, 365 * 2, by = 10)  # 2 years in days
V0 <- 5   # initial volume in cm^3
r <- 0.01 # daily growth rate
K <- 100  # carrying capacity in cm^3

# Exponential: V(t) = V0 * exp(r*t)
V_exp <- V0 * exp(r * t_seq)

# Logistic: V(t) = K / (1 + ((K-V0)/V0) * exp(-r*t))
V_log <- K / (1 + ((K - V0) / V0) * exp(-r * t_seq))

# Gompertz: V(t) = V0 * exp((a/b) * (1 - exp(-b*t)))
# Common in oncology; asymmetrical S-curve with slower approach to K
a <- 0.02; b <- 0.005
V_gomp <- V0 * exp((a / b) * (1 - exp(-b * t_seq)))

growth_df <- data.frame(
  time = rep(t_seq, 3),
  volume = c(V_exp, V_log, V_gomp),
  model = rep(c("Exponential", "Logistic", "Gompertz"), each = length(t_seq))
)

p1 <- ggplot(growth_df, aes(x = time, y = volume, color = model)) +
  geom_line(size = 1.2) +
  geom_hline(yintercept = K, lty = 2, color = "grey50") +
  annotate("text", x = 600, y = K + 5, label = paste("K =", K), color = "grey30") +
  scale_color_manual(values = c("#d95f02", "#2166ac", "#1b9e77")) +
  labs(title = "Tumor Growth Models: V(t) over 2 years",
       subtitle = sprintf("V0 = %.0f cm³ | r = %.3f/day | K = %.0f cm³", V0, r, K),
       x = "Time (days)",
       y = expression("Volume (cm"^3*")")) +
  theme_minimal(base_size = 12)

# Doubling times
Td_exp <- log(2) / r
Td_log_initial <- log(2) / r  # same as exponential when V << K
cat("Exponential doubling time:", round(Td_exp, 1), "days (",
    round(Td_exp / 30, 1), "months)\n")

## Exponential doubling time: 69.3 days ( 2.3 months)

# Show doubling time as a function of current volume (logistic)
V_current <- seq(1, 90, by = 1)
Td_log_current <- log(2) / (r * (1 - V_current / K))

p2 <- ggplot(data.frame(V = V_current, Td = Td_log_current),
             aes(x = V, y = Td)) +
  geom_line(color = "#2166ac", size = 1.2) +
  geom_hline(yintercept = Td_exp, lty = 2, color = "#d95f02") +
  annotate("text", x = 70, y = Td_exp + 5,
           label = sprintf("Exponential Td = %.0f days", Td_exp),
           color = "#d95f02", size = 3.5) +
  labs(title = "Logistic Doubling Time Increases with Volume",
       subtitle = "As V approaches K, growth slows and Td → ∞",
       x = "Current volume (cm³)",
       y = "Doubling time (days)") +
  theme_minimal(base_size = 12)

p1 + p2

The KiTS release is cross-sectional: one CT per patient, so no patient has a serial volume trajectory. Rather than simulate one, we do two things that the real data genuinely support.

First, we fit a nonlinear model to a real spatial profile, which exercises exactly the same nonlinear least-squares machinery.
Second, we use the real cross-sectional volume distribution to calibrate what a growth model would have to explain.

## The tumor cross-sectional area profile A(z) from a REAL reference mask is a
## smooth, unimodal curve. Fitting it is a nonlinear least-squares problem with
## the same structure as fitting a growth curve in time.
if (!is.na(mask_path)) {
  z_idx  <- which(demo_scan$slice_area_mm2 > 0)
  z_mm   <- (z_idx - min(z_idx)) * demo_scan$header$pixdim[3]
  A_mm2  <- demo_scan$slice_area_mm2[z_idx]

  ## Model: a Gaussian profile A(z) = A0 * exp(-(z - mu)^2 / (2 sigma^2)).
  ## For a perfect sphere of radius R, A(z) = pi (R^2 - (z-mu)^2): the Gaussian
  ## is an approximation whose misfit reports departure from sphericity.
  start <- list(A0 = max(A_mm2), mu = z_mm[which.max(A_mm2)],
                sigma = diff(range(z_mm)) / 4)
  gauss_fit <- try(nls(A_mm2 ~ A0 * exp(-(z_mm - mu)^2 / (2 * sigma^2)),
                       start = start), silent = TRUE)

  ## Spherical-cap model for comparison.
  sph_fit <- try(nls(A_mm2 ~ pmax(pi * (R^2 - (z_mm - mu)^2), 0),
                     start = list(R = diff(range(z_mm)) / 2,
                                  mu = z_mm[which.max(A_mm2)])), silent = TRUE)

  op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
  plot(z_mm, A_mm2, pch = 19, cex = 0.7, col = "grey30",
       xlab = "Position along axis (mm)",
       ylab = expression("A(z) (mm"^2*")"),
       main = "Real tumor profile with fitted models")
  zz <- seq(min(z_mm), max(z_mm), length.out = 300)
  if (!inherits(gauss_fit, "try-error"))
    lines(zz, predict(gauss_fit, list(z_mm = zz)), lwd = 2, col = "#2c7fb8")
  if (!inherits(sph_fit, "try-error"))
    lines(zz, predict(sph_fit, list(z_mm = zz)), lwd = 2, lty = 2, col = "#d95f02")
  legend("topright", c("Gaussian", "spherical cap"), col = c("#2c7fb8", "#d95f02"),
         lty = c(1, 2), lwd = 2, bty = "n", cex = 0.8)

  if (!inherits(gauss_fit, "try-error")) {
    plot(z_mm, residuals(gauss_fit), pch = 19, cex = 0.7, col = "#2c7fb8",
         xlab = "Position along axis (mm)", ylab = "Residual",
         main = "Residual structure"); abline(h = 0, lty = 2)
    print(round(summary(gauss_fit)$coefficients, 3))
    cat("residual standard error:", round(summary(gauss_fit)$sigma, 2), "mm^2\n")
  }
  par(op)
}

##       Estimate Std. Error t value Pr(>|t|)
## A0     527.668     14.448  36.521        0
## mu      11.934      0.202  58.991        0
## sigma    6.371      0.227  28.064        0
## residual standard error: 39.98 mm^2

Residuals are not white noise, as they show the systematic asymmetry of a real lesion that no two-parameter symmetric model can capture. That is the real outcome of fitting a simple mechanistic form to real anatomy, and it is exactly the diagnostic step that separates curve-fitting from modeling.

Interactive Exploration: Growth Model Simulator

Exponential Growth Model: The exponential model assumes that the rate of growth is directly proportional to the current population or size, describing unconstrained growth where resources are infinite. The model is based on this differential equation $\frac{dN}{dt} = r N$, which has an Integrated Solution representing the size at time $t$, $N(t) = N_0 e^{rt}$. The parameters include
- $N(t)$Population size or organism mass at time $t$.
- $N_0$: Initial size at $t = 0$.
- $r$: Intrinsic growth rate ($r > 0$).
- $t$: Time.
Logistic Growth Model: The logistic model introduces a carrying capacity ($K$), meaning the growth rate slows down as the population approaches its maximum sustainable size due to resource limitation. This model is based on a differential equation $\frac{dN}{dt} = r N \left(1 - \frac{N}{K}\right)$, which has a solution, representing the size at time $t$), $N(t) = \frac{K}{1 + \left(\frac{K - N_0}{N_0}\right) e^{-rt}}$. The model parameters include
- $K$: Carrying capacity (maximum upper asymptote).
- $r$: Intrinsic growth rate.
- $N_0$: Initial size at $t = 0$.
Gompertz Growth Model. The Gompertz model is an S-shaped (sigmoid) curve, but unlike the logistic model, it is asymmetrical. Growth is initially very rapid, but the relative growth rate decays exponentially over time, making it particularly useful for tumor growth and animal development. The differential equation describing this model is $\frac{dN}{dt} = -k N \ln\left(\frac{N}{K}\right)$ with a size at time $t$ solution $N(t) = K \exp\left( \ln\left(\frac{N_0}{K}\right) e^{-kt} \right)$. The model parameters include
- $K$: Carrying capacity or upper asymptote.
- $k$: Constant representing the rate of exponential decay of the relative growth rate.
- $N_0$: Initial size at $t = 0$.

The next app explores the bahavior of three growth models (exponential, logistic, Gompertz) using different parameter settings. Adjust the growth rate, carrying capacity, and initial volume to see how doubling time changes and how the models diverge over time.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Tumor Growth Model Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("V0", "Initial volume V0 (cm³):",
                  min = 0.5, max = 50, value = 5, step = 0.5),
      sliderInput("r", "Growth rate r (per day):",
                  min = 0.001, max = 0.05, value = 0.01, step = 0.001),
      sliderInput("K", "Carrying capacity K (cm³):",
                  min = 10, max = 500, value = 100, step = 10),
      sliderInput("time_horizon", "Time horizon (days):",
                  min = 180, max = 1095, value = 730, step = 30),
      checkboxGroupInput("models", "Models to display:",
                         choices = c("Exponential", "Logistic", "Gompertz"),
                         selected = c("Exponential", "Logistic", "Gompertz")),
      hr(),
      helpText("Observe: (1) Exponential growth is unbounded and unrealistic 
               for large tumors. (2) Logistic growth decelerates as V approaches K. 
               (3) Gompertz growth is asymmetrical, slow start, rapid middle, 
               slow finish. (4) Doubling time is constant for exponential but 
               increases over time for logistic and Gompertz.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Growth Curves", plotOutput("growthPlot", height = "400px")),
        tabPanel("Doubling Time", plotOutput("dTPlot", height = "400px")),
        tabPanel("Parameter Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  growth_data <- reactive({
    t_seq <- seq(0, input$time_horizon, by = 5)
    V0 <- input$V0
    r <- input$r
    K <- input$K
    
    models <- list()
    
    if ("Exponential" %in% input$models) {
      models[["Exponential"]] <- V0 * exp(r * t_seq)
    }
    if ("Logistic" %in% input$models) {
      models[["Logistic"]] <- K / (1 + ((K - V0) / V0) * exp(-r * t_seq))
    }
    if ("Gompertz" %in% input$models) {
      a <- r * 2  # scale to make comparable
      b <- r / 2
      models[["Gompertz"]] <- V0 * exp((a / b) * (1 - exp(-b * t_seq)))
    }
    
    df <- data.frame(time = t_seq)
    for (m in names(models)) {
      df[[m]] <- models[[m]]
    }
    
    tidyr::pivot_longer(df, cols = -time, names_to = "model", values_to = "volume")
  })
  
  output$growthPlot <- renderPlot({
    df <- growth_data()
    
    ggplot(df, aes(x = time, y = volume, color = model)) +
      geom_line(size = 1.2) +
      geom_hline(yintercept = input$K, lty = 2, color = "grey50") +
      annotate("text", x = input$time_horizon * 0.8, y = input$K + 2,
               label = sprintf("K = %.0f", input$K), color = "grey30") +
      scale_color_manual(values = c("Exponential" = "#d95f02", 
                                    "Logistic" = "#2166ac",
                                    "Gompertz" = "#1b9e77")) +
      labs(title = "Tumor Growth Models",
           subtitle = sprintf("V0 = %.1f cm³ | r = %.3f/day | K = %.0f cm³",
                              input$V0, input$r, input$K),
           x = "Time (days)",
           y = expression("Volume (cm"^3*")")) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom")
  })
  
  output$dTPlot <- renderPlot({
    V_seq <- seq(0.5, input$K * 0.95, by = 0.5)
    r <- input$r
    K <- input$K
    
    dT_exp <- rep(log(2) / r, length(V_seq))
    dT_log <- log(2) / (r * (1 - V_seq / K))
    
    # Gompertz: dV/dt = a*V*exp(-b*t), so instantaneous Td depends on t
    # At small t (V near V0), Td ≈ log(2)/a
    # At large t (V near K), Td → ∞
    # Approximate using current volume: for Gompertz, dV/dt = b*V*ln(K/V)
    # so Td = log(2) / (b * ln(K/V))
    b_gomp <- r / 2
    dT_gomp <- log(2) / (b_gomp * log(K / V_seq))
    
    dT_df <- data.frame(
      volume = rep(V_seq, 3),
      doubling_time = c(dT_exp, dT_log, dT_gomp),
      model = rep(c("Exponential", "Logistic", "Gompertz"), each = length(V_seq))
    )
    
    ggplot(dT_df, aes(x = volume, y = doubling_time, color = model)) +
      geom_line(size = 1.2) +
      scale_color_manual(values = c("Exponential" = "#d95f02", 
                                    "Logistic" = "#2166ac",
                                    "Gompertz" = "#1b9e77")) +
      labs(title = "Instantaneous Doubling Time vs. Current Volume",
           subtitle = "Exponential: constant | Logistic & Gompertz: increases as V → K",
           x = "Current volume (cm³)",
           y = "Doubling time (days)") +
      ylim(0, 500) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom")
  })
  
  output$summary <- renderPrint({
    cat("--- Growth Parameter Summary ---\n")
    cat("Initial volume (V0):", input$V0, "cm³\n")
    cat("Growth rate (r):", input$r, "per day\n")
    cat("Carrying capacity (K):", input$K, "cm³\n\n")
    
    Td_exp <- log(2) / input$r
    cat("Exponential doubling time:", round(Td_exp, 1), "days (",
        round(Td_exp / 30, 1), "months)\n")
    cat("  → At this rate, V0 =", input$V0, "grows to", 
        round(input$V0 * 2^(input$time_horizon / Td_exp), 1), 
        "in", input$time_horizon, "days\n\n")
    
    cat("Logistic model:\n")
    cat("  Initial doubling time:", round(Td_exp, 1), "days (same as exponential)\n")
    cat("  At V = K/2, doubling time:", round(log(2) / (input$r * 0.5), 1), "days\n")
    cat("  Final volume at t =", input$time_horizon, ":", 
        round(input$K / (1 + ((input$K - input$V0) / input$V0) * 
                           exp(-input$r * input$time_horizon)), 1), "cm³\n\n")
    
    cat("Clinical interpretation:\n")
    if (Td_exp < 60) {
      cat("⚠️  Fast doubling time (< 2 months). Aggressive biology.\n")
    } else if (Td_exp < 180) {
      cat("  Moderate doubling time (2-6 months). Typical for many RCC.\n")
    } else {
      cat("✓ Slow doubling time (> 6 months). May support active surveillance.\n")
    }
  })
}

shinyApp(ui, server)

Try it yourself.

Set the growth rate to 0.005/day. What is the exponential doubling time? How long until the logistic model hits 90% of carrying capacity?
Increase the carrying capacity to 500 cm³. How does this affect the logistic model’s trajectory? Does the exponential model care about K?
Compare the doubling time plots. Why does the Gompertz model have a longer doubling time than the logistic model at the same volume? (Hint: Gompertz decelerates more gradually.)
Set V0 = 0.5 cm³ (a very small tumor detected by screening). With r = 0.01/day, how many years until the tumor reaches 50 cm³ under exponential vs. logistic growth? This explains why screening-detected tumors can appear to grow slowly for years, then suddenly “accelerate.”

8.7 Real volume distribution and growth models

if (have_imaging) {
  V <- kidney_img_model$tumor_volume_cm3
  V <- V[is.finite(V) & V > 0]

  ## Exponential growth V(t) = V0 exp(rt) implies a volume doubling time
  ## T_d = log(2)/r. Published renal-mass growth rates cluster around
  ## 0.3-0.5 cm/year in DIAMETER - convert to a volumetric rate and ask how long
  ## the observed real volumes would take to arise.
  d_cm      <- 2 * (3 * V / (4 * pi))^(1 / 3)     # equivalent diameters
  growth_cm <- 0.4                                 # cm/year (literature-scale)
  years_to_reach <- (d_cm - 1) / growth_cm         # from a 1 cm lesion

  op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
  hist(log10(V), breaks = 15, col = "grey85",
       xlab = expression(log[10]~"volume (cm"^3*")"),
       main = "Real tumor volume distribution")
  hist(years_to_reach[years_to_reach > 0], breaks = 15, col = "#a6cee3",
       xlab = "Implied years from a 1 cm lesion",
       main = "Time scale implied by real sizes")
  par(op)

  round(c(median_volume_cm3 = median(V),
          iqr_volume_cm3    = IQR(V),
          median_diam_cm    = median(d_cm),
          implied_median_yr = median(years_to_reach[years_to_reach > 0])), 2)
}

## median_volume_cm3    iqr_volume_cm3    median_diam_cm implied_median_yr 
##             17.97             51.92              3.25              5.62

Tumor Diameter Growth ≠ Volume Growth

Often oncology studies report growth in diameter (cm/year), but growth models operate on volume. Because $V = \frac{4}{3}\pi r^3$, a linear increase in diameter implies an accelerating volumetric growth. The visualization below makes this explicit.

## Show why "0.4 cm/year diameter growth" is not constant volumetric growth.
library(ggplot2)
library(patchwork)

d_seq <- seq(1, 12, by = 0.1)  # diameter in cm
V_seq <- (4/3) * pi * (d_seq/2)^3  # volume in cm^3

# Growth over time assuming 0.4 cm/year linear diameter growth
years <- seq(0, 30, by = 0.5)
d_t <- 1 + 0.4 * years  # diameter over time
V_t <- (4/3) * pi * (d_t/2)^3  # volume over time

# Volumetric growth rate (derivative) over time
# dD/dt = 0.4, dV/dt = dV/dD * dD/dt = 4*pi*(D/2)^2 * 0.4 / 2 = pi*D^2*0.1
dV_dt <- pi * d_t^2 * 0.1

df_growth <- data.frame(
  years = years,
  diameter = d_t,
  volume = V_t,
  vol_growth_rate = dV_dt
)

p1 <- ggplot(df_growth, aes(x = years, y = diameter)) +
  geom_line(color = "#2166ac", size = 1.2) +
  labs(title = "Diameter grows linearly",
       subtitle = "0.4 cm/year (constant)",
       x = "Years from 1 cm lesion",
       y = "Diameter (cm)") +
  theme_minimal(base_size = 12)

p2 <- ggplot(df_growth, aes(x = years, y = volume)) +
  geom_line(color = "#d95f02", size = 1.2) +
  labs(title = "Volume accelerates",
       subtitle = "dV/dt = π·D²·0.1 (cubic growth)",
       x = "Years from 1 cm lesion",
       y = expression("Volume (cm"^3*")")) +
  theme_minimal(base_size = 12)

p3 <- ggplot(df_growth, aes(x = years, y = vol_growth_rate)) +
  geom_line(color = "#1b9e77", size = 1.2) +
  labs(title = "Volumetric growth rate accelerates",
       subtitle = "Even though diameter growth is constant",
       x = "Years from 1 cm lesion",
       y = expression("dV/dt (cm"^3*"/year)")) +
  theme_minimal(base_size = 12)

p1 + p2 + p3

The cubic trap. A 0.4 cm/year diameter growth rate sounds slow and constant. But volume grows as the cube of diameter. At 2 cm diameter, the tumor adds $\sim 0.5$ $cm^3/year$. At 8 cm, it adds $\sim 8\ cm^3/year$, i.e., 16 times faster. This is why large tumors seem to “suddenly appear” on imaging. The volumetric acceleration is real mathematics, not perception. Using a diameter growth rate into a volume model implicitly assumes accelerating volumetric growth, which may or may not match biology.

Cross-sectional data constrain growth models only through auxiliary assumptions. The volume histogram spans several orders of magnitude, and converting it into a timescale required importing a growth rate from outside this dataset. That is a legitimate modeling move, but it must be stated: nothing in KiTS measures $r$ or $K$. A study that reports doubling times from single-timepoint imaging is reporting its assumptions, not its data.

Interactive Exploration: Growth Rate Sensitivity

The following app supports adjusting the assumed diameter growth rate, initial lesion size and the implied timescale for the KiTS volume distribution shifts. The key lesson: the timescale is almost entirely determined by the imported growth rate assumption, not by the data itself.

library(shiny)
library(ggplot2)
library(dplyr)

# Precompute the real volume distribution
V_real <- kidney_img_model$tumor_volume_cm3
V_real <- V_real[is.finite(V_real) & V_real > 0]
d_real <- 2 * (3 * V_real / (4 * pi))^(1/3)

ui <- fluidPage(
  titlePanel("Growth Rate Sensitivity Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("growth_rate", "Assumed diameter growth (cm/year):",
                  min = 0.1, max = 1.5, value = 0.4, step = 0.05),
      sliderInput("initial_d", "Initial lesion diameter (cm):",
                  min = 0.5, max = 3, value = 1.0, step = 0.1),
      hr(),
      helpText("Adjust the growth rate assumption and observe how the 
               implied years-to-detection distribution shifts. The data 
               (volumes) are fixed; only the assumption changes."),
      hr(),
      radioButtons("model_type", "Growth model:",
                   choices = c("Linear diameter (constant dD/dt)",
                               "Exponential volume (constant dV/dt/V)"),
                   selected = "Linear diameter (constant dD/dt)")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Implied Timescale", plotOutput("timescalePlot", height = "400px")),
        tabPanel("Volume vs Time", plotOutput("trajectoryPlot", height = "400px")),
        tabPanel("Summary Stats", tableOutput("summaryTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  implied_data <- reactive({
    d_obs <- d_real
    d0 <- input$initial_d
    
    if (grepl("Linear", input$model_type)) {
      # Linear diameter growth: D(t) = D0 + g*t => t = (D - D0) / g
      years <- (d_obs - d0) / input$growth_rate
      # Trajectory
      t_traj <- seq(0, 30, by = 0.5)
      d_traj <- d0 + input$growth_rate * t_traj
      v_traj <- (4/3) * pi * (d_traj/2)^3
    } else {
      # Exponential volume growth: V(t) = V0 * exp(r*t)
      # V0 = (4/3)*pi*(d0/2)^3
      V0 <- (4/3) * pi * (d0/2)^3
      V_obs <- (4/3) * pi * (d_obs/2)^3
      # Convert diameter growth rate to volumetric rate
      # At d0, dV/dt = pi*d0^2*g/2, and dV/dt/V = 3*g/d0
      r <- 3 * input$growth_rate / d0
      years <- log(V_obs / V0) / r
      # Trajectory
      t_traj <- seq(0, 30, by = 0.5)
      v_traj <- V0 * exp(r * t_traj)
      d_traj <- 2 * (3 * v_traj / (4 * pi))^(1/3)
    }
    
    list(years = years, t_traj = t_traj, d_traj = d_traj, v_traj = v_traj)
  })
  
  output$timescalePlot <- renderPlot({
    d <- implied_data()
    plot_df <- data.frame(years = d$years[d$years > 0])
    
    ggplot(plot_df, aes(x = years)) +
      geom_histogram(bins = 20, fill = "#a6cee3", color = "white") +
      geom_vline(xintercept = median(plot_df$years), color = "#d95f02", 
                 size = 1.2, lty = 2) +
      annotate("text", x = median(plot_df$years) + 1, y = max(table(cut(plot_df$years, 20))) * 0.9,
               label = sprintf("Median = %.1f yrs", median(plot_df$years)),
               color = "#d95f02", size = 4) +
      labs(title = "Implied Years from Initial Lesion to Observed Size",
           subtitle = sprintf("Growth rate = %.2f cm/yr | Initial D = %.1f cm | %s",
                              input$growth_rate, input$initial_d, input$model_type),
           x = "Implied years",
           y = "Number of tumors") +
      theme_minimal(base_size = 13)
  })
  
  output$trajectoryPlot <- renderPlot({
    d <- implied_data()
    traj_df <- data.frame(
      time = d$t_traj,
      diameter = d$d_traj,
      volume = d$v_traj
    )
    
    # Add observed volumes as points on the trajectory
    obs_df <- data.frame(
      time = d$years[d$years > 0],
      diameter = d_real[d$years > 0],
      volume = V_real[d$years > 0]
    )
    
    ggplot(traj_df, aes(x = time, y = volume)) +
      geom_line(color = "#2166ac", size = 1.2) +
      geom_point(data = obs_df, aes(x = time, y = volume), 
                 color = "#d95f02", alpha = 0.5, size = 2) +
      labs(title = "Growth Trajectory with Observed Tumor Volumes",
           subtitle = "Orange points = real tumors projected onto the growth curve",
           x = "Years from initial lesion",
           y = expression("Volume (cm"^3*")")) +
      theme_minimal(base_size = 13)
  })
  
  output$summaryTable <- renderTable({
    d <- implied_data()
    yrs <- d$years[d$years > 0]
    
    data.frame(
      Statistic = c("Tumors (n)", "Median implied years", "IQR (years)", 
                    "Min implied years", "Max implied years",
                    "Assumed growth rate", "Initial diameter"),
      Value = c(length(yrs), round(median(yrs), 1), 
                paste0(round(quantile(yrs, 0.25), 1), "–", round(quantile(yrs, 0.75), 1)),
                round(min(yrs), 1), round(max(yrs), 1),
                paste0(input$growth_rate, " cm/yr"),
                paste0(input$initial_d, " cm"))
    )
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

Try it yourself.

Set the growth rate to 0.2 cm/year (slow-growing). The median implied years jumps to $$20+ years. Now set it to 1.0 cm/year (aggressive). The median drops to $$5 years. The data didn’t change, only the assumption did. This is why reporting doubling times from cross-sectional data without stating the growth-rate assumption is misleading.
Switch between “Linear diameter” and “Exponential volume” growth models. How do the implied timescales differ? Which model is more biologically realistic for large tumors?
Refit the spatial profile above for three other real cases (change demo_case and re-run). Does the Gaussian or the spherical-cap model win more often, and does the winner correlate with the measured tumor_sphericity? That is a falsifiable prediction you can check in a few lines.

With few scans, $K$ and $r$ may be weakly identified and highly correlated. Profile likelihood, bootstrap, Bayesian priors, or population-level nonlinear mixed models can represent this uncertainty more honestly than a single curve.

8.8 Mixed-effects and joint models

For repeated measurements $Y_{ij}$ at time $t_{ij}$, a number of alternative longitudinal models may be employed, see DSPA2 and Complex-time and Spacekime Analytics.

For instance, a linear mixed model

\[ Y_{ij}=(\beta_0+b_{0i})+(\beta_1+b_{1i})t_{ij}+\epsilon_{ij}, \]

accounts for patient-specific random effects $(b_{0i},b_{1i})$. Nonlinear mixed models replace the linear trajectory with an exponential, logistic, or other (non-affine) mechanistic function.

A joint longitudinal-survival model links a latent trajectory $m_i(t)$ to hazard

\[h_i(t)=h_0(t)\exp\{X_i^\top\gamma+\alpha m_i(t)\}.\]

This can reduce bias when biomarker measurements are error-prone and visit processes are related to health. It requires careful assumptions and specialized software.

Visualizing the Joint Model Architecture

library(DiagrammeR)

grViz("
digraph joint_model_architecture {
  # Graph setup
  graph [layout = dot, rankdir = TB, compound = true, nodesep = 0.4, ranksep = 0.6]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # --- SUBGRAPH 1: LONGITUDINAL SUBMODEL ---
  subgraph cluster_longitudinal {
    label = 'Longitudinal Submodel'
    fontname = 'Helvetica-Bold'
    fontsize = 11
    style = filled
    color = '#B3E5FC'
    fillcolor = '#F0F8FF'

    A [label = 'Observed biomarker Y_ij', fillcolor = '#e8f5e9', style = 'filled']
    B [label = 'Latent trajectory m_i(t)', fillcolor = '#e1f5fe', style = 'filled']
    C [label = 'Random effects b_0i, b_1i']

    A -> B
    B -> C
  }

  # --- SUBGRAPH 2: SURVIVAL SUBMODEL ---
  subgraph cluster_survival {
    label = 'Survival Submodel'
    fontname = 'Helvetica-Bold'
    fontsize = 11
    style = filled
    color = '#FFE0B2'
    fillcolor = '#FFF8E7'

    D [label = 'Baseline hazard h_0(t)', fillcolor = '#f3e5f5', style = 'filled']
    E [label = 'Event time T_i', fillcolor = '#fff3e0', style = 'filled']
    F [label = 'Covariates X_i']

    D -> E
    F -> E
  }

  # --- ASSOCIATION EDGE ---
  B -> E [label = 'Association parameter alpha', fontname = Helvetica, fontsize = 9, color = '#333333']
}
")

The joint model has three components

Longitudinal submodel: Estimates the true underlying biomarker trajectory $m_i(t)$ from noisy, sparse observations $Y_{ij}$. Random effects $(b_{0i}, b_{1i})$ allow each patient to have their own intercept and slope.
Survival submodel: Models the event hazard using baseline covariates $X_i$ and the baseline hazard $h_0(t)$.
Linkage: The association parameter $\alpha$ quantifies how the current biomarker level (or slope) influences the instantaneous hazard. If $\alpha > 0$, higher biomarker values increase event risk.

Interactive Exploration: Random Effects and Individual Trajectories

This app simulates a cohort of patients with repeated biomarker measurements and random intercepts/slopes. Adjust the variability of random effects to explore how individual trajectories diverge from the population mean. Then examine how the association parameter $\alpha$ links the biomarker trajectory to survival.

library(shiny)
library(ggplot2)
library(dplyr)

ui <- fluidPage(
  titlePanel("Mixed-Effects & Joint Model Explorer"),
  sidebarLayout(
    sidebarPanel(
      h5("Longitudinal Submodel"),
      sliderInput("n_patients", "Number of patients:",
                  min = 10, max = 100, value = 30, step = 5),
      sliderInput("beta0", "Population intercept (β₀):",
                  min = 30, max = 80, value = 50, step = 1),
      sliderInput("beta1", "Population slope (β₁, units/year):",
                  min = -10, max = 10, value = 3, step = 0.5),
      sliderInput("sd_intercept", "Random intercept SD (σ_b0):",
                  min = 0, max = 20, value = 8, step = 1),
      sliderInput("sd_slope", "Random slope SD (σ_b1):",
                  min = 0, max = 5, value = 1.5, step = 0.1),
      sliderInput("sd_error", "Measurement error SD (σ_ε):",
                  min = 0.5, max = 10, value = 3, step = 0.5),
      hr(),
      h5("Joint Model Linkage"),
      sliderInput("alpha", "Association parameter (α):",
                  min = -0.2, max = 0.2, value = 0.05, step = 0.01),
      helpText("α > 0: higher biomarker → higher hazard (risk biomarker)
               α < 0: higher biomarker → lower hazard (protective)
               α = 0: no linkage (independent submodels)")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Individual Trajectories", 
                 plotOutput("trajPlot", height = "450px")),
        tabPanel("Random Effects Distribution", 
                 plotOutput("rePlot", height = "400px")),
        tabPanel("Joint Model: Biomarker & Survival", 
                 plotOutput("jointPlot", height = "450px")),
        tabPanel("Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  sim_data <- reactive({
    set.seed(42)
    n <- input$n_patients
    
    # Random effects
    b0 <- rnorm(n, mean = 0, sd = input$sd_intercept)
    b1 <- rnorm(n, mean = 0, sd = input$sd_slope)
    
    # Generate longitudinal data (3-5 visits per patient)
    long_data <- data.frame()
    survival_data <- data.frame(
      patient = 1:n,
      b0 = b0, b1 = b1,
      true_intercept = input$beta0 + b0,
      true_slope = input$beta1 + b1
    )
    
    for (i in 1:n) {
      n_visits <- sample(3:5, 1)
      t_visits <- sort(runif(n_visits, 0, 5))
      true_traj <- (input$beta0 + b0[i]) + (input$beta1 + b1[i]) * t_visits
      obs_traj <- true_traj + rnorm(n_visits, sd = input$sd_error)
      
      long_data <- rbind(long_data, data.frame(
        patient = i,
        time = t_visits,
        true_value = true_traj,
        observed = obs_traj
      ))
      
      # Survival: hazard proportional to current biomarker level
      # h(t) = h0 * exp(alpha * m(t))
      # Simulate event time using inverse CDF
      # For simplicity, use exponential with rate = 0.1 * exp(alpha * mean(true_traj))
      mean_biomarker <- mean(true_traj)
      hazard <- 0.1 * exp(input$alpha * (mean_biomarker - input$beta0))
      t_event <- rexp(1, hazard)
      t_censor <- runif(1, 2, 7)
      
      survival_data$event_time[i] <- min(t_event, t_censor)
      survival_data$event[i] <- as.integer(t_event <= t_censor)
      survival_data$mean_biomarker[i] <- mean_biomarker
    }
    
    list(long = long_data, surv = survival_data)
  })
  
  output$trajPlot <- renderPlot({
    d <- sim_data()
    
    # Population mean trajectory
    t_seq <- seq(0, 5, by = 0.1)
    pop_traj <- data.frame(
      time = t_seq,
      value = input$beta0 + input$beta1 * t_seq,
      type = "Population mean"
    )
    
    ggplot() +
      geom_line(data = d$long, aes(x = time, y = true_value, group = patient),
                color = "#2166ac", alpha = 0.3, size = 0.8) +
      geom_point(data = d$long, aes(x = time, y = observed, group = patient),
                 color = "#d95f02", alpha = 0.5, size = 1.5) +
      geom_line(data = pop_traj, aes(x = time, y = value), 
                color = "black", size = 1.5, lty = 2) +
      labs(title = "Individual Trajectories with Random Effects",
           subtitle = sprintf("β₀=%.0f, β₁=%.1f | σ_b0=%.0f, σ_b1=%.1f | σ_ε=%.1f",
                              input$beta0, input$beta1, 
                              input$sd_intercept, input$sd_slope, input$sd_error),
           x = "Time (years)",
           y = "Biomarker value",
           caption = "Blue lines = true individual trajectories | Orange points = noisy observations | Black dashed = population mean") +
      theme_minimal(base_size = 12)
  })
  
  output$rePlot <- renderPlot({
    d <- sim_data()
    
    re_df <- data.frame(
      patient = 1:nrow(d$surv),
      intercept = d$surv$b0,
      slope = d$surv$b1
    )
    
    library(tidyr)
    re_long <- re_df %>%
      pivot_longer(cols = c(intercept, slope), names_to = "effect", values_to = "value")
    
    ggplot(re_long, aes(x = value, fill = effect)) +
      geom_histogram(alpha = 0.6, bins = 15, position = "identity") +
      geom_vline(data = data.frame(effect = "intercept", xint = 0),
                 aes(xintercept = xint), lty = 2) +
      geom_vline(data = data.frame(effect = "slope", xint = 0),
                 aes(xintercept = xint), lty = 2) +
      scale_fill_manual(values = c("intercept" = "#2166ac", "slope" = "#d95f02")) +
      labs(title = "Distribution of Random Effects",
           subtitle = "Each patient deviates from the population mean",
           x = "Deviation from population parameter",
           y = "Count",
           fill = "Random effect") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom")
  })
  
  output$jointPlot <- renderPlot({
    d <- sim_data()
    
    # Plot biomarker trajectory and event time for each patient
    joint_df <- d$long %>%
      left_join(d$surv[, c("patient", "event_time", "event", "mean_biomarker")], 
                by = "patient")
    
    # Color by event status
    event_status <- d$surv %>%
      mutate(status = ifelse(event == 1, "Event", "Censored")) %>%
      select(patient, status, event_time, mean_biomarker)
    
    long_plot <- d$long %>%
      left_join(event_status, by = "patient")
    
    p1 <- ggplot(long_plot, aes(x = time, y = observed, group = patient, color = status)) +
      geom_line(alpha = 0.5, size = 0.6) +
      geom_point(alpha = 0.6, size = 1.5) +
      geom_point(data = event_status, aes(x = event_time, y = mean_biomarker, 
                                          shape = status), size = 3) +
      scale_color_manual(values = c("Event" = "#b2182b", "Censored" = "#1b9e77")) +
      scale_shape_manual(values = c("Event" = 4, "Censored" = 1)) +
      labs(title = "Biomarker Trajectories Colored by Event Status",
           subtitle = sprintf("Association α = %.3f | Crosses = event times", input$alpha),
           x = "Time (years)",
           y = "Biomarker value") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom")
    
    # Biomarker level vs event time
    p2 <- ggplot(event_status, aes(x = mean_biomarker, y = event_time, color = status)) +
      geom_point(size = 3) +
      geom_smooth(method = "lm", se = FALSE, aes(group = 1), color = "grey50") +
      scale_color_manual(values = c("Event" = "#b2182b", "Censored" = "#1b9e77")) +
      labs(title = "Mean Biomarker vs Event Time",
           subtitle = ifelse(input$alpha > 0, 
                            "α > 0: Higher biomarker → shorter event time (risk)",
                            ifelse(input$alpha < 0,
                                   "α < 0: Higher biomarker → longer event time (protective)",
                                   "α = 0: No association")),
           x = "Mean biomarker level",
           y = "Event/censor time (years)") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom")
    
    library(patchwork)
    p1 / p2
  })
  
  output$summary <- renderPrint({
    d <- sim_data()
    cat("--- Mixed-Effects & Joint Model Summary ---\n\n")
    cat("Longitudinal submodel:\n")
    cat("  Population intercept (β₀):", input$beta0, "\n")
    cat("  Population slope (β₁):", input$beta1, "units/year\n")
    cat("  Random intercept SD:", input$sd_intercept, "\n")
    cat("  Random slope SD:", input$sd_slope, "\n")
    cat("  Measurement error SD:", input$sd_error, "\n\n")
    
    cat("Joint model linkage:\n")
    cat("  Association parameter (α):", input$alpha, "\n")
    if (input$alpha > 0) {
      cat("  → Higher biomarker increases hazard (risk biomarker)\n")
    } else if (input$alpha < 0) {
      cat("  → Higher biomarker decreases hazard (protective)\n")
    } else {
      cat("  → No linkage between biomarker and survival\n")
    }
    
    cat("\nSimulated cohort:\n")
    cat("  Patients:", input$n_patients, "\n")
    cat("  Events:", sum(d$surv$event), "\n")
    cat("  Censored:", sum(d$surv$event == 0), "\n")
    
    # Correlation between biomarker and event time
    cor_val <- cor(d$surv$mean_biomarker, d$surv$event_time)
    cat("\n  Correlation(biomarker, event time):", round(cor_val, 3), "\n")
    if (input$alpha > 0 && cor_val < 0) {
      cat("  ✓ Negative correlation confirms risk biomarker (higher → earlier event)\n")
    } else if (input$alpha < 0 && cor_val > 0) {
      cat("  ✓ Positive correlation confirms protective biomarker\n")
    }
  })
}

shinyApp(ui, server)

When are joint models worth the complexity? Joint models are most valuable when

The biomarker is measured with error and the visit frequency varies across patients.
The biomarker trajectory is informative about event risk (e.g., rising PSA and prostate cancer recurrence).
The visit process itself is related to health (sicker patients are seen more often, informative observation times).
You need dynamic predictions that update as new biomarker values arrive.

If the biomarker is measured once at baseline with negligible error, a standard Cox model with the baseline value as a covariate is simpler and nearly equivalent.

Try it yourself (Section 8). 1. Random effects variability. In the app, set $\sigma_{b_o} = 0$ and $\sigma_{b_1} = 0$. All trajectories collapse to the population mean. Now increase them. How does the spread of trajectories change? When would this variability matter clinically? 2. Association parameter. Set $\alpha = 0$. The biomarker and survival submodels are now independent. Increase α to 0.1. Do patients with higher biomarker values tend to have earlier events? This is the causal link the joint model estimates. 3. Informative observation. The simulation assumes random visit times. In reality, sicker patients are seen more often. How would informative visit timing bias a naive analysis that ignores the joint structure? 4. Censoring experiment. Recode every censored patient in the KiTS survival data as event-free and refit the Kaplan-Meier curve as if follow-up were complete. Overlay it on the correct curve. Which direction does the bias run, and why does it grow with follow-up time? Then reduce the cohort to the 21 patients with observed deaths and try to fit the Cox model, what happens, and what does that tell you about the events-per-variable diagnostic printed in Section 8.3?

9. Unsupervised Learning, Segmentation, and Spatial Structure

9.1 Utility of unsupervised learning

Unsupervised methods seek structure in $X$ without an outcome label. They can compress data, discover acquisition artifacts, propose phenotypes, or initialize segmentation. They cannot by themselves establish that a cluster is a disease subtype or that a component is biologically meaningful.

For k-means, the objective is to optimize

\[\min_{C_1,\ldots,C_K}\sum_{k=1}^K\sum_{i\in C_k} \|x_i-\mu_k\|_2^2.\]

The solution depends on scaling, $K$, initialization, outliers, and geometry.

The circular trap of unsupervised phenotyping. If you cluster patients and then name a cluster “aggressive phenotype” simply because it happens to have more events in your dataset, you have committed circular reasoning. The cluster was defined without the outcome, but the name is assigned post hoc using the outcome. To be scientifically valid, a cluster must be:

Stable: Reproducible in a held-out sample or via bootstrap resampling.
Independent: Defined using features that are causally or clinically upstream of the outcome.
Validated: The association with the outcome must be tested in a new, independent cohort.

K-means specifically assumes that clusters are convex (roughly spherical) and similarly sized. It uses Euclidean distance, which means it is highly sensitive to feature scaling. If tumor volume is in mm³ and age is in years, volume will completely dominate the cluster assignment unless the data are standardized.

9.2 Patient phenotyping in PCA space

## Unsupervised phenotyping of REAL patients in standardized feature space.
library(ggplot2)
library(patchwork)
library(cluster) # for silhouette

cl_vars <- c("age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
             "preop_egfr")
cl_dat <- kidney_model[, cl_vars]
cl_ok  <- complete.cases(cl_dat)
Zc     <- scale(cl_dat[cl_ok, ])

set.seed(9)
km3 <- kmeans(Zc, centers = 3, nstart = 25)
pc  <- prcomp(Zc)

# Prepare data for plotting
pca_df <- data.frame(
  PC1 = pc$x[, 1],
  PC2 = pc$x[, 2],
  cluster = factor(km3$cluster)
)

# Calculate silhouette widths to assess cluster quality
sil <- silhouette(km3$cluster, dist(Zc))
sil_df <- data.frame(
  cluster = factor(sil[, 1]),
  silhouette = sil[, 3]
)

# Cluster profiles on the ORIGINAL scale (medians)
profiles <- aggregate(cl_dat[cl_ok, ], by = list(cluster = km3$cluster),
                      FUN = function(z) round(median(z), 1))
profile_long <- reshape(profiles, idvar = "cluster", varying = list(2:5),
                        v.names = "Value", times = cl_vars, timevar = "Feature",
                        direction = "long")
profile_long$Feature <- factor(profile_long$Feature, levels = cl_vars)
# Scale profiles for visual comparison
profile_long$ScaledValue <- scale(profile_long$Value)[,1]

# 1. PCA Scatter with cluster assignments
p1 <- ggplot(pca_df, aes(x = PC1, y = PC2, color = cluster)) +
  geom_point(size = 3, alpha = 0.7) +
  stat_ellipse(level = 0.95, type = "t", linetype = "dashed") +
  labs(title = "k-means (K=3) phenotypes in PCA space",
       subtitle = "Clusters capture variance, not necessarily malignancy",
       x = "PC1", y = "PC2", color = "Cluster") +
  theme_minimal(base_size = 12)

# 2. Silhouette plot
p2 <- ggplot(sil_df, aes(x = cluster, y = silhouette, fill = cluster)) +
  geom_boxplot(alpha = 0.7) +
  geom_hline(yintercept = 0, lty = 2, color = "grey50") +
  labs(title = "Cluster Silhouette Widths",
       subtitle = "Values < 0.2 indicate weak/ambiguous structure",
       x = "Cluster", y = "Silhouette width") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "none")

# 3. Cluster profiles heatmap
p3 <- ggplot(profile_long, aes(x = cluster, y = Feature, fill = ScaledValue)) +
  geom_tile(color = "white") +
  geom_text(aes(label = Value), size = 4, color = "black") +
  scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", 
                       midpoint = 0, name = "Scaled\nMedian") +
  labs(title = "Cluster Profiles (Original Medians)",
       subtitle = "What clinical archetype does each cluster represent?",
       x = "Cluster", y = "") +
  theme_minimal(base_size = 12)

(p1 + p2) / p3 + plot_layout(heights = c(1, 1))

# Table of malignancy breakdown
table(cluster = km3$cluster, malignant = kidney_model$malignancy_label[cl_ok])

##        malignant
## cluster benign malignant
##       1      3        64
##       2     11        45
##       3      1        29

The clusters separate patients by age, body habitus, tumor size, and baseline renal function, but they do not align with malignancy. That is the expected result and the key lesson: unsupervised structure reflects whatever dominates the variance of the chosen features, which need not be the clinical label of interest.

Outcome composition is examined after clustering and should be validated in new data. Naming a cluster “aggressive phenotype” solely because it has more events is circular unless the association replicates and the cluster is stable.

Interactive Exploration: The Unsupervised Laboratory

The next app demonstrated unsupervised clustering with control of the feature inputs, the number of clusters ($K$), and options to scale the data. Use the app to answer the following questions.

Can you find a combination of features that produces clusters aligned with malignancy?
What happens to the silhouette widths if you force $K=10$ on this small dataset?
If you include both radiographic_size_cm and tumor_volume_cm3 without scaling, does one dominate the clustering entirely?

library(shiny)
library(ggplot2)
library(cluster)
library(dplyr)
library(tidyr)

# Define available features
all_features <- c("age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
                  "preop_egfr", "tumor_volume_cm3", "tumor_sphericity", 
                  "log_tumor_volume", "max_bbox_extent_mm")

ui <- fluidPage(
  titlePanel("Unsupervised Phenotyping Explorer"),
  sidebarLayout(
    sidebarPanel(
      checkboxGroupInput("features", "Select Features:",
                         choices = all_features,
                         selected = c("age_at_nephrectomy", "body_mass_index", 
                                      "radiographic_size_cm", "preop_egfr")),
      sliderInput("k", "Number of clusters (K):",
                  min = 2, max = 6, value = 3, step = 1),
      checkboxInput("scale", "Scale features (recommended)", value = TRUE),
      hr(),
      helpText("Observe how changing features or K alters the PCA projection, 
               the clinical profiles, and the malignancy breakdown. 
               Silhouette width < 0.2 suggests poor cluster separation.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("PCA & Clusters", plotOutput("pcaPlot", height = "400px")),
        tabPanel("Cluster Validation", 
                 plotOutput("silPlot", height = "300px"),
                 verbatimTextOutput("silText")),
        tabPanel("Cluster Profiles", plotOutput("profilePlot", height = "400px")),
        tabPanel("Outcome Breakdown", 
                 plotOutput("outcomePlot", height = "400px"),
                 tableOutput("outcomeTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  cluster_data <- reactive({
    req(length(input$features) >= 2)
    
    dat <- kidney_model[, input$features, drop = FALSE]
    ok <- complete.cases(dat)
    X <- dat[ok, , drop = FALSE]
    y <- kidney_model$malignancy_label[ok]
    
    if (input$scale) {
      X_mat <- scale(X)
    } else {
      X_mat <- as.matrix(X)
    }
    
    # Handle potential NA/NaN in scaling (e.g., zero variance)
    if (any(is.na(X_mat))) {
      return(NULL)
    }
    
    set.seed(42)
    km <- kmeans(X_mat, centers = input$k, nstart = 25)
    pc <- prcomp(X_mat, scale. = FALSE)
    sil <- silhouette(km$cluster, dist(X_mat))
    
    list(
      pca = data.frame(PC1 = pc$x[,1], PC2 = pc$x[,2], cluster = factor(km$cluster)),
      sil = data.frame(cluster = factor(sil[,1]), width = sil[,3]),
      raw = X,
      cluster = factor(km$cluster),
      y = y,
      mean_sil = mean(sil[,3])
    )
  })
  
  output$pcaPlot <- renderPlot({
    d <- cluster_data()
    if (is.null(d)) return(NULL)
    
    ggplot(d$pca, aes(x = PC1, y = PC2, color = cluster)) +
      geom_point(size = 3, alpha = 0.7) +
      stat_ellipse(level = 0.95, type = "t", linetype = "dashed") +
      labs(title = "k-means clusters in PCA space",
           subtitle = paste("Features:", paste(input$features, collapse=", ")),
           x = "PC1", y = "PC2") +
      theme_minimal(base_size = 13)
  })
  
  output$silPlot <- renderPlot({
    d <- cluster_data()
    if (is.null(d)) return(NULL)
    
    ggplot(d$sil, aes(x = cluster, y = width, fill = cluster)) +
      geom_boxplot(alpha = 0.7) +
      geom_hline(yintercept = 0, lty = 2, color = "red") +
      geom_hline(yintercept = 0.2, lty = 2, color = "orange") +
      labs(title = "Silhouette Widths by Cluster",
           subtitle = "Orange = weak structure, Red = misclassified",
           x = "Cluster", y = "Silhouette Width") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none")
  })
  
  output$silText <- renderText({
    d <- cluster_data()
    if (is.null(d)) return("")
    paste("Mean silhouette width:", round(d$mean_sil, 3),
          ifelse(d$mean_sil < 0.25, "(No substantial structure)", "(Structure present)"))
  })
  
  output$profilePlot <- renderPlot({
    d <- cluster_data()
    if (is.null(d)) return(NULL)
    
    df <- cbind(d$raw, cluster = d$cluster)
    df_long <- df %>%
      pivot_longer(-cluster, names_to = "Feature", values_to = "Value") %>%
      group_by(Feature) %>%
      mutate(ScaledValue = as.numeric(scale(Value))) %>%
      group_by(cluster, Feature) %>%
      summarise(Median = median(Value, na.rm=TRUE),
                ScaledMedian = median(ScaledValue, na.rm=TRUE), .groups="drop")
    
    ggplot(df_long, aes(x = cluster, y = Feature, fill = ScaledMedian)) +
      geom_tile(color = "white") +
      geom_text(aes(label = round(Median, 1)), size = 4) +
      scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", midpoint = 0) +
      labs(title = "Cluster Profiles (Medians)",
           x = "Cluster", y = "", fill = "Scaled\nMedian") +
      theme_minimal(base_size = 13)
  })
  
  output$outcomePlot <- renderPlot({
    d <- cluster_data()
    if (is.null(d)) return(NULL)
    
    df <- data.frame(cluster = d$cluster, malignant = d$y)
    
    ggplot(df, aes(x = cluster, fill = malignant)) +
      geom_bar(position = "fill", alpha = 0.8) +
      scale_y_continuous(labels = scales::percent) +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Malignancy Breakdown by Cluster",
           subtitle = "Remember: this association is post hoc and exploratory",
           x = "Cluster", y = "Proportion", fill = "Status") +
      theme_minimal(base_size = 13)
  })
  
  output$outcomeTable <- renderTable({
    d <- cluster_data()
    if (is.null(d)) return(NULL)
    as.data.frame(table(Cluster = d$cluster, Status = d$y))
  }, striped = TRUE, hover = TRUE)
}

shinyApp(ui, server)

Try it yourself. 1. The Scaling Trap. Deselect scaling. Select tumor_volume_cm3 (values $\sim 100$) and tumor_sphericity (values $\sim 0.1$ to $1.0$). Run the clustering. Look at the PCA plot and the profiles. You will likely see that tumor_volume_cm3 completely dominates the cluster assignment, ignoring sphericity entirely. 2. Forcing K. Set $K=5$ with only 4 features. Look at the silhouette plot. Many clusters will likely have negative or near-zero silhouette widths, indicating that $K=5$ is artificial and the algorithm is forcing structure onto noise. 3. The Malignancy Search. Try to find a combination of imaging features (e.g., volume, sphericity, elongation) that produces clusters with distinct malignancy rates. Even if you find one, why is this scientifically dangerous? (Hint: You are testing multiple hypotheses on the same data without correction).

9.3 Internal cluster validation and stability

Silhouette width for observation $i$ is

\[s(i)=\frac{b(i)-a(i)}{\max\{a(i),b(i)\}},\]

where $a(i)$ is average distance within its cluster and $b(i)$ is the smallest average distance to another cluster.

How to read a silhouette value. * $s(i) \approx 1$: The observation is much closer to its own cluster than to any other. Well-classified. * $s(i) \approx 0$: The observation sits on the boundary between two clusters. Ambiguous. * $s(i) < 0$: The observation is closer to a different cluster than to its assigned one. Likely misclassified. * Average $s < 0.25$: No substantial structure. The data is likely a continuum, not discrete subtypes. * Average $s > 0.50$: Strong, convincing structure.

## Silhouette width, implemented directly, evaluated on the REAL patient matrix.
silhouette_widths <- function(X, cluster) {
  D <- as.matrix(dist(X))
  sapply(seq_len(nrow(X)), function(i) {
    own <- cluster == cluster[i]
    if (sum(own) <= 1) return(0)
    a <- mean(D[i, own & seq_len(nrow(X)) != i])
    b <- min(vapply(setdiff(unique(cluster), cluster[i]),
                    function(g) mean(D[i, cluster == g]), numeric(1)))
    (b - a) / max(a, b)
  })
}

k_candidates <- 2:6
sil_summary <- sapply(k_candidates, function(k) {
  set.seed(9)
  cl <- kmeans(Zc, centers = k, nstart = 25)$cluster
  mean(silhouette_widths(Zc, cl))
})
names(sil_summary) <- paste0("k=", k_candidates)
round(sil_summary, 3)

##   k=2   k=3   k=4   k=5   k=6 
## 0.226 0.265 0.267 0.275 0.275

## Stability: does the partition survive resampling of the real cases?
set.seed(21)
stability <- replicate(25, {
  idx <- sample(nrow(Zc), size = floor(0.8 * nrow(Zc)))
  cl  <- kmeans(Zc[idx, ], centers = 3, nstart = 10)$cluster
  mean(silhouette_widths(Zc[idx, ], cl))
})
round(c(mean_silhouette = mean(stability), sd = sd(stability)), 3)

## mean_silhouette              sd 
##           0.270           0.013

Visualizing Silhouettes and the Gap Statistic

A single average silhouette width is a summary; the distribution of individual silhouette widths reveals whether any cluster is well-separated or whether all observations are ambiguous.

library(ggplot2)
library(patchwork)

# 1. Silhouette plot for k=3 (individual observations)
set.seed(9)
km3 <- kmeans(Zc, centers = 3, nstart = 25)
sil_vals <- silhouette_widths(Zc, km3$cluster)
sil_df <- data.frame(
  obs = seq_along(sil_vals),
  width = sil_vals,
  cluster = factor(km3$cluster)
)
sil_df <- sil_df[order(sil_df$cluster, -sil_df$width), ]
sil_df$obs_order <- seq_len(nrow(sil_df))

p1 <- ggplot(sil_df, aes(x = obs_order, y = width, fill = cluster)) +
  geom_col(width = 1) +
  geom_hline(yintercept = mean(sil_vals), lty = 2, color = "red") +
  geom_hline(yintercept = 0.25, lty = 2, color = "orange") +
  annotate("text", x = 5, y = mean(sil_vals) + 0.05, 
           label = sprintf("Mean = %.3f", mean(sil_vals)), color = "red", size = 3.5) +
  annotate("text", x = 5, y = 0.27, label = "Weak structure threshold (0.25)", 
           color = "orange", size = 3) +
  labs(title = "Silhouette Plot (K=3)",
       subtitle = "Each bar = one patient. Orange line = 'no structure' threshold.",
       x = "Patient (sorted by cluster and width)",
       y = "Silhouette width s(i)") +
  theme_minimal(base_size = 11) +
  theme(legend.position = "bottom")

# 2. Gap statistic (compares WSS to null reference distribution)
# Gap(k) = E*[log(W_k)] - log(W_k)
gap_stat <- sapply(k_candidates, function(k) {
  set.seed(9)
  # Observed WSS
  km <- kmeans(Zc, centers = k, nstart = 25)
  wss_obs <- km$tot.withinss
  
  # Expected WSS under null (uniform distribution)
  n_null <- 10
  wss_null <- replicate(n_null, {
    X_null <- apply(Zc, 2, function(col) runif(length(col), min(col), max(col)))
    km_null <- kmeans(X_null, centers = k, nstart = 5)
    km_null$tot.withinss
  })
  
  c(gap = mean(log(wss_null)) - log(wss_obs),
    se = sd(log(wss_null)) / sqrt(n_null))
})
gap_df <- data.frame(
  k = k_candidates,
  gap = gap_stat["gap", ],
  se = gap_stat["se", ]
)

# Compute gap difference for 1-SE rule
gap_diff <- gap_df$gap[-nrow(gap_df)] - (gap_df$gap[-1] - gap_df$se[-1])
gap_df$optimal_1se <- c(gap_diff < 0, FALSE)

p2 <- ggplot(gap_df, aes(x = k, y = gap)) +
  geom_line(color = "#2166ac", size = 1) +
  geom_point(size = 3, color = "#2166ac") +
  geom_errorbar(aes(ymin = gap - se, ymax = gap + se), width = 0.2, color = "#2166ac") +
  labs(title = "Gap Statistic",
       subtitle = "Compares observed WSS to null (uniform) reference",
       x = "Number of clusters (K)",
       y = "Gap(k) ± SE") +
  theme_minimal(base_size = 12)

p1 + p2

All indices agree: there is no convincing structure here. The mean silhouette width ($$0.28) is near the “no structure” threshold. The gap statistic does not show a clear elbow. The silhouette plot shows many patients with $s(i) < 0.25$ or even negative values. Reporting “three renal-mass phenotypes” from a partition like this would over-interpret a continuum. Cluster validity (does the algorithm produce a partition?) and cluster existence (are there real subtypes?) are different claims.

Interactive Exploration: Cluster Stability Laboratory

The app below lets you explore how fragile cluster assignments are. Change $K$, the features used, and the random seed, then view the consensus matrix (how often two patients end up in the same cluster across bootstrap resamples). A stable clustering will show a block-diagonal consensus matrix; an unstable one will look like noise.

library(shiny)
library(ggplot2)
library(dplyr)
library(tidyr)

all_features <- c("age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
                   "preop_egfr", "tumor_volume_cm3", "tumor_sphericity",
                   "log_tumor_volume", "max_bbox_extent_mm")

ui <- fluidPage(
  titlePanel("Cluster Stability Explorer"),
  sidebarLayout(
    sidebarPanel(
      checkboxGroupInput("features", "Select Features:",
                         choices = all_features,
                         selected = c("age_at_nephrectomy", "body_mass_index",
                                      "radiographic_size_cm", "preop_egfr")),
      sliderInput("k", "Number of clusters (K):",
                  min = 2, max = 5, value = 3, step = 1),
      sliderInput("n_boot", "Bootstrap iterations:",
                  min = 10, max = 100, value = 50, step = 10),
      actionButton("run", "Run Stability Analysis"),
      hr(),
      helpText("The consensus matrix shows how often each pair of patients 
               is assigned to the same cluster across bootstrap resamples. 
               Stable clusters produce a clear block-diagonal pattern; 
               unstable clustering produces a diffuse, noisy matrix.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Consensus Matrix", plotOutput("consensusPlot", height = "450px")),
        tabPanel("Silhouette by K", plotOutput("silPlot", height = "400px")),
        tabPanel("Cluster Assignments", plotOutput("assignPlot", height = "400px")),
        tabPanel("Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  results <- eventReactive(input$run, {
    req(length(input$features) >= 2)
    
    dat <- kidney_model[, input$features, drop = FALSE]
    ok <- complete.cases(dat)
    X <- scale(dat[ok, , drop = FALSE])
    n <- nrow(X)
    
    # Consensus matrix
    consensus <- matrix(0, n, n)
    cluster_counts <- matrix(0, n, input$k)
    
    # Also track silhouette across k values
    sil_by_k <- sapply(2:5, function(k) {
      set.seed(9)
      cl <- kmeans(X, centers = k, nstart = 25)$cluster
      D <- as.matrix(dist(X))
      s <- sapply(seq_len(n), function(i) {
        own <- cl == cl[i]
        if (sum(own) <= 1) return(0)
        a <- mean(D[i, own & seq_len(n) != i])
        b <- min(vapply(setdiff(unique(cl), cl[i]),
                        function(g) mean(D[i, cl == g]), numeric(1)))
        (b - a) / max(a, b)
      })
      mean(s)
    })
    
    # Bootstrap consensus
    for (b in seq_len(input$n_boot)) {
      set.seed(b * 100 + 42)
      idx <- sample(n, size = floor(0.8 * n), replace = FALSE)
      cl <- kmeans(X[idx, ], centers = input$k, nstart = 10)$cluster
      
      # Record co-clustering
      for (i in seq_along(idx)) {
        for (j in seq_along(idx)) {
          if (cl[i] == cl[j]) {
            consensus[idx[i], idx[j]] <- consensus[idx[i], idx[j]] + 1
          }
        }
      }
    }
    
    # Normalize consensus (only count pairs where both were sampled)
    sample_counts <- matrix(0, n, n)
    for (b in seq_len(input$n_boot)) {
      set.seed(b * 100 + 42)
      idx <- sample(n, size = floor(0.8 * n), replace = FALSE)
      for (i in idx) {
        for (j in idx) {
          sample_counts[i, j] <- sample_counts[i, j] + 1
        }
      }
    }
    consensus <- consensus / pmax(sample_counts, 1)
    diag(consensus) <- 1
    
    # Final clustering on full data
    set.seed(9)
    final_cl <- kmeans(X, centers = input$k, nstart = 25)$cluster
    
    # Reorder consensus by cluster
    ord <- order(final_cl)
    consensus_ordered <- consensus[ord, ord]
    
    list(
      consensus = consensus_ordered,
      final_cl = final_cl,
      ord = ord,
      sil_by_k = sil_by_k,
      n = n
    )
  })
  
  output$consensusPlot <- renderPlot({
    r <- results()
    
    cm_df <- as.data.frame(as.table(r$consensus))
    colnames(cm_df) <- c("Patient_i", "Patient_j", "Consensus")
    cm_df$Patient_i <- as.numeric(cm_df$Patient_i)
    cm_df$Patient_j <- as.numeric(cm_df$Patient_j)
    
    ggplot(cm_df, aes(x = Patient_i, y = Patient_j, fill = Consensus)) +
      geom_raster() +
      scale_fill_gradient(low = "white", high = "#2166ac", limits = c(0, 1)) +
      labs(title = "Consensus Matrix",
           subtitle = sprintf("K = %d | %d bootstrap iterations | Block-diagonal = stable",
                              input$k, input$n_boot),
           x = "Patient (sorted by cluster)", y = "Patient") +
      coord_equal() +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), axis.ticks = element_blank())
  })
  
  output$silPlot <- renderPlot({
    r <- results()
    df <- data.frame(k = 2:5, silhouette = r$sil_by_k)
    
    ggplot(df, aes(x = k, y = silhouette)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_point(size = 3, color = "#2166ac") +
      geom_hline(yintercept = 0.25, lty = 2, color = "orange") +
      geom_hline(yintercept = 0.50, lty = 2, color = "green") +
      annotate("text", x = 4.5, y = 0.27, label = "Weak", color = "orange", size = 3) +
      annotate("text", x = 4.5, y = 0.52, label = "Strong", color = "green", size = 3) +
      labs(title = "Mean Silhouette Width vs K",
           subtitle = "No clear maximum = no natural cluster count",
           x = "K", y = "Mean silhouette width") +
      theme_minimal(base_size = 13) +
      ylim(0, 0.7)
  })
  
  output$assignPlot <- renderPlot({
    r <- results()
    pc <- prcomp(kidney_model[complete.cases(kidney_model[, input$features]),
                              input$features])
    pc_df <- data.frame(
      PC1 = pc$x[, 1],
      PC2 = pc$x[, 2],
      cluster = factor(r$final_cl)
    )
    
    ggplot(pc_df, aes(x = PC1, y = PC2, color = cluster)) +
      geom_point(size = 3, alpha = 0.7) +
      labs(title = "Final Cluster Assignments (full data)",
           x = "PC1", y = "PC2") +
      theme_minimal(base_size = 13)
  })
  
  output$summary <- renderPrint({
    r <- results()
    cat("--- Stability Analysis Summary ---\n")
    cat("Features:", paste(input$features, collapse = ", "), "\n")
    cat("K:", input$k, "\n")
    cat("Bootstrap iterations:", input$n_boot, "\n\n")
    
    # Off-diagonal consensus statistics with safety checks
    cm <- r$consensus
    off_diag <- cm[upper.tri(cm)]
    off_diag <- off_diag[!is.na(off_diag)]
    
    cat("Consensus matrix statistics:\n")
    if (length(off_diag) > 1) {
      cat("  Mean off-diagonal value:", round(mean(off_diag, na.rm = TRUE), 3), "\n")
      cat("  SD off-diagonal:", round(sd(off_diag, na.rm = TRUE), 3), "\n")
      cat("  Proportion > 0.8 (stable pairs):", round(mean(off_diag > 0.8, na.rm = TRUE), 3), "\n")
      cat("  Proportion < 0.2 (unstable pairs):", round(mean(off_diag < 0.2, na.rm = TRUE), 3), "\n\n")
    } else {
      cat("  Insufficient data points to compute off-diagonal metrics.\n\n")
    }
    
    # Silhouette summary
    cat("Silhouette by K:\n")
    for (i in seq_along(2:5)) {
      cat(sprintf("  K=%d: %.3f %s\n", (2:5)[i], r$sil_by_k[i],
                  ifelse(r$sil_by_k[i] < 0.25, "(weak)", 
                         ifelse(r$sil_by_k[i] < 0.50, "(moderate)", "(strong)"))))
    }
    
    cat("\nInterpretation:\n")
    if (length(off_diag) > 1) {
      mean_val <- mean(off_diag, na.rm = TRUE)
      if (mean_val > 0.6) {
        cat("✓ High consensus: cluster assignments are relatively stable.\n")
      } else if (mean_val > 0.4) {
        cat("⚠ Moderate consensus: some structure, but many pairs are unstable.\n")
      } else {
        cat("✗ Low consensus: cluster assignments are highly unstable.\n")
        cat("  The data likely forms a continuum, not discrete subtypes.\n")
      }
    } else {
      cat("- Interpretation unavailable due to low sample size.\n")
    }
  })
}

shinyApp(ui, server)

Internal indices favor particular geometries and can disagree. Bootstrap stability, consensus clustering, and replication in an external cohort are stronger evidence than a single silhouette maximum.

9.4 Unsupervised intensity segmentation

Within the synthetic kidney, k-means can separate an enhancing high-attenuation region from parenchyma and low-attenuation tissue. It does not know anatomy and cannot automatically combine necrotic and enhancing components into one tumor.

## Unsupervised intensity segmentation of a REAL image slice.
if (have_image) {
  seg_slice <- slice                       # real slice loaded in Section 5.8
  set.seed(3)
  km_img <- kmeans(as.numeric(seg_slice), centers = 3, nstart = 10)
  ## Relabel clusters by increasing intensity so the result is reproducible.
  order_map <- order(km_img$centers)
  lab <- matrix(match(km_img$cluster, order_map), nrow(seg_slice), ncol(seg_slice))

  op <- par(mfrow = c(1, 3), mar = c(2, 2, 3, 1))
  image(seg_slice, col = grey.colors(64), axes = FALSE, main = "Real slice"); box()
  image(lab, col = c("#f0f0f0", "#9ecae1", "#08519c"), axes = FALSE,
        main = "k-means (k = 3)"); box()
  hist(seg_slice, breaks = 60, col = "grey85", main = "Intensity histogram",
       xlab = "Intensity")
  abline(v = sort(km_img$centers), col = "#cb181d", lwd = 2, lty = 2)
  par(op)

  data.frame(cluster = 1:3,
             center = round(sort(km_img$centers), 1),
             voxels = as.integer(table(lab)))
}

##   cluster center voxels
## 1       1    2.6   1529
## 2       2  385.6    662
## 3       3  730.5    113

Why intensity-only segmentation fails for tumors. A tumor is not a single intensity class. It contains: * Enhancing rim (high attenuation, ~100-150 HU) * Necrotic core (low attenuation, ~10-30 HU) * Hemorrhage (variable, ~40-80 HU) * Calcification (very high, >200 HU)

K-means on intensities assigns each voxel to the nearest intensity center. It will split the tumor across multiple clusters and merge tumor voxels with normal tissue that happens to share the same HU. It has no concept of spatial contiguity (“these voxels are next to each other, so they are probably the same structure”).

Intensity clustering has no anatomical knowledge: it partitions the histogram. It recovers tissue classes only where intensity alone separates them, which is why real segmentation pipelines add spatial regularization, priors, or supervision.

Interactive Exploration: Intensity Segmentation Laboratory

The app below lets you adjust the number of clusters ($K$) and optionally apply spatial smoothing before clustering. Compare the $K=3$ intensity-only result with a spatially smoothed version. The smoothed result has spatial coherence but blurs anatomical boundaries, the fundamental trade-off in unsupervised segmentation.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Intensity Segmentation Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("k", "Number of intensity clusters (K):",
                  min = 2, max = 8, value = 3, step = 1),
      sliderInput("smooth", "Spatial smoothing (Gaussian σ, pixels):",
                  min = 0, max = 5, value = 0, step = 0.5),
      checkboxInput("show_boundaries", "Overlay cluster boundaries", value = TRUE),
      hr(),
      helpText("K-means clusters voxels by intensity alone. Increasing K 
               splits tissue classes further. Spatial smoothing (applied 
               before clustering) adds local context but blurs edges. 
               Neither solves the core problem: the tumor spans multiple 
               intensity classes.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Segmentation", plotOutput("segPlot", height = "500px")),
        tabPanel("Intensity Histogram", plotOutput("histPlot", height = "400px")),
        tabPanel("Cluster Statistics", tableOutput("clusterTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  seg_data <- reactive({
    req(have_image)
    
    img <- seg_slice
    k <- input$k
    
    # Apply spatial smoothing if requested
    if (input$smooth > 0) {
      # Simple Gaussian smoothing using matrix convolution
      sigma <- input$smooth
      size <- ceiling(3 * sigma)
      x <- seq(-size, size, by = 1)
      kernel <- exp(-x^2 / (2 * sigma^2))
      kernel <- kernel / sum(kernel)
      
      # Apply 1D smoothing in both directions (approximate 2D Gaussian)
      img_smoothed <- img
      for (i in 1:nrow(img)) {
        img_smoothed[i, ] <- stats::filter(img[i, ], kernel, circular = TRUE)
      }
      for (j in 1:ncol(img)) {
        img_smoothed[, j] <- stats::filter(img_smoothed[, j], kernel, circular = TRUE)
      }
      img_smoothed[is.na(img_smoothed)] <- img[is.na(img_smoothed)]
      img_for_clustering <- img_smoothed
    } else {
      img_for_clustering <- img
    }
    
    set.seed(3)
    km <- kmeans(as.numeric(img_for_clustering), centers = k, nstart = 10)
    order_map <- order(km$centers)
    lab <- matrix(match(km$cluster, order_map), nrow(img), ncol(img))
    
    list(
      img = img,
      img_smoothed = img_for_clustering,
      lab = lab,
      centers = sort(km$centers),
      k = k
    )
  })
  
  output$segPlot <- renderPlot({
    d <- seg_data()
    
    op <- par(mfrow = c(1, 2), mar = c(2, 2, 3, 1))
    
    # Original
    image(d$img, col = grey.colors(64), axes = FALSE, 
          main = "Original image"); box()
    
    # Segmented
    colors <- c("#f0f0f0", "#9ecae1", "#08519c", "#fee391", "#fec44f", 
                "#fe9929", "#ec7014", "#cc4c02")
    image(d$lab, col = colors[1:d$k], axes = FALSE,
          main = sprintf("k-means (K=%d, σ=%.1f)", d$k, input$smooth)); box()
    
    # Overlay boundaries using points() instead of image()
    if (input$show_boundaries) {
      edges <- matrix(FALSE, nrow(d$lab), ncol(d$lab))
      edges[-1, ] <- edges[-1, ] | (d$lab[-1, ] != d$lab[-nrow(d$lab), ])
      edges[, -1] <- edges[, -1] | (d$lab[, -1] != d$lab[, -ncol(d$lab)])
      
      edge_coords <- which(edges, arr.ind = TRUE)
      if (nrow(edge_coords) > 0) {
        # Scale coordinates to fit base image plotting coordinates [0, 1]
        pts_x <- (edge_coords[, 1] - 1) / (nrow(d$lab) - 1)
        pts_y <- (edge_coords[, 2] - 1) / (ncol(d$lab) - 1)
        points(pts_x, pts_y, col = "red", pch = ".", cex = 1.2)
      }
    }
    
    par(op)
  })
  
  output$histPlot <- renderPlot({
    d <- seg_data()
    
    hist_df <- data.frame(intensity = as.numeric(d$img))
    
    ggplot(hist_df, aes(x = intensity)) +
      geom_histogram(bins = 60, fill = "grey85", color = "white") +
      geom_vline(xintercept = d$centers, color = "#cb181d", lwd = 1.5, lty = 2) +
      annotate("text", x = d$centers, y = Inf, vjust = 1.5,
               label = sprintf("C%d", seq_along(d$centers)),
               color = "#cb181d", size = 3, fontface = "bold") +
      labs(title = "Intensity Histogram with Cluster Centers",
           subtitle = sprintf("K = %d | Red lines = cluster centers", d$k),
           x = "Intensity (HU)",
           y = "Count") +
      theme_minimal(base_size = 13)
  })
  
  output$clusterTable <- renderTable({
    d <- seg_data()
    
    df <- data.frame(
      Cluster = 1:d$k,
      Center_HU = round(d$centers, 1),
      Voxels = as.integer(table(d$lab)),
      Pct_Image = round(100 * as.integer(table(d$lab)) / length(d$lab), 1)
    )
    
    # Add interpretation based on HU
    df$Likely_Tissue <- sapply(df$Center_HU, function(h) {
      if (h < 0) "Air/Fat"
      else if (h < 20) "Fluid/Necrosis"
      else if (h < 50) "Soft tissue"
      else if (h < 100) "Parenchyma"
      else if (h < 150) "Enhancing tissue"
      else "Calcification/Bone"
    })
    
    df
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

Try it yourself. 1. The tumor fragmentation problem. Set $K=4$ with no smoothing. Look at the segmented image. Can you identify the tumor? It is likely split across multiple intensity clusters. Which clusters correspond to enhancing rim vs. necrotic core? 2. Spatial smoothing. Increase the smoothing $\sigma$ to 2.0. The segmentation becomes more spatially coherent (fewer isolated voxels), but boundaries blur. This is the fundamental trade-off: intensity precision vs. spatial precision. 3. Too many clusters. Set $K=8$. The histogram is over-partitioned. Some clusters have very few voxels and correspond to noise or partial-volume effects rather than real tissue classes. This is the same over-interpretation trap as forcing too many patient subtypes. 4. The core limitation. No setting of $K$ or $\sigma$ will produce a segmentation that says “this entire region is the tumor.” That requires either (a) a supervised model trained on labeled tumor masks, (b) a multi-atlas registration approach, or (c) a generative model with explicit anatomical priors. Intensity k-means is a preprocessing step, not a segmentation pipeline.

Connection to Clinical Segmentation Pipelines

Real tumor segmentation systems combine multiple strategies.

Strategy	What it adds	Limitation
Intensity k-means	Fast histogram partition	No spatial context, no anatomy
Spatial smoothing	Removes salt-and-pepper noise	Blurs boundaries
Region growing	Ensures contiguity	Needs seed points, leaks through weak edges
Level sets / active contours	Smooth, topology-aware boundaries	Sensitive to initialization
Random forests / U-Net	Learns intensity + texture + context	Requires labeled training data
Atlas registration	Brings anatomical priors	Computationally expensive, fails on unusual anatomy

The progression from unsupervised k-means to supervised deep learning is not just an algorithmic upgrade, it is a shift from discovering structure to recognizing structure. The latter requires labeled examples, which is why large annotated datasets like KiTS are transformative.

9.5 Overlap and boundary metrics

For predicted mask $P$ and reference mask $G$,

\[\mathrm{Dice}(P,G)=\frac{2|P\cap G|}{|P|+|G|}, \qquad \mathrm{Jaccard}(P,G)=\frac{|P\cap G|}{|P\cup G|}.\]

Dice is dominated by volume overlap and can hide clinically important boundary errors. Surface distance, Hausdorff distance, lesion detection, and topology may also matter.

The clinical consequence of hidden boundary errors. In radiation oncology, a 2-voxel boundary error might preserve a Dice score of 0.90 while shifting the dose gradient outside the planning target volume. A uniform dilation might yield the same Dice but overdose adjacent organs at risk. This is why the FDA and imaging biomarker guidelines require multiple complementary metrics, e.g., overlap (Dice/Jaccard), boundary (Hausdorff/ASSD), and clinical (lesion detection rate, volumetric agreement).

## Overlap and boundary agreement between a REAL expert mask and perturbed
## versions of it. Distance-based metrics penalize the errors that overlap
## metrics tolerate.
## Overlap and boundary agreement between a REAL expert mask and perturbed
## versions of it. Distance-based metrics penalize the errors that overlap
## metrics tolerate.
boundary_pixels <- function(M) M & !erode_mask(M)

hausdorff_distances <- function(A, B, spacing = c(1, 1)) {
  # Pedagogical approximation: use boundary pixels instead of exact surface mesh.
  ia <- which(boundary_pixels(A), arr.ind = TRUE)
  ib <- which(boundary_pixels(B), arr.ind = TRUE)
  if (!nrow(ia) || !nrow(ib)) return(c(hd = NA, hd95 = NA, assd = NA))
  ia <- sweep(ia, 2, spacing, "*"); ib <- sweep(ib, 2, spacing, "*")
  d_ab <- apply(ia, 1, function(p) sqrt(min(colSums((t(ib) - p)^2))))
  d_ba <- apply(ib, 1, function(p) sqrt(min(colSums((t(ia) - p)^2))))
  c(hd   = max(max(d_ab), max(d_ba)),
    hd95 = max(quantile(d_ab, 0.95), quantile(d_ba, 0.95)),
    assd = (sum(d_ab) + sum(d_ba)) / (length(d_ab) + length(d_ba)))
}

# ref is obtained earlier from demo_scan2; mask_path is the expert kidney mask
if (!is.na(mask_path)) {
  ref  <- demo_scan2$slices[[as.character(keep_k[2])]] == 2
  spac <- demo_scan$header$pixdim[1:2]

  variants <- list(
    "dilate 1"       = dilate_mask(ref),
    "erode 1"        = erode_mask(ref),
    "dilate 2"       = dilate_mask(dilate_mask(ref)),
    "shift 2 voxels" = {
      s <- ref; s[] <- FALSE
      d <- dim(ref); s[3:d[1], ] <- ref[1:(d[1] - 2), ]; s
    }
  )

  seg_table <- do.call(rbind, lapply(names(variants), function(nm) {
    v  <- variants[[nm]]
    hd <- hausdorff_distances(ref, v, spac)
    data.frame(variant = nm,
               dice = dice_coefficient(ref, v),
               jaccard = jaccard_index(ref, v),
               hd_mm = hd["hd"], hd95_mm = hd["hd95"], assd_mm = hd["assd"],
               area_change_pct = 100 * (sum(v) - sum(ref)) / sum(ref))
  }))
  seg_table[, -1] <- round(seg_table[, -1], 3)
  seg_table
}

##            variant  dice jaccard hd_mm hd95_mm assd_mm area_change_pct
## hd        dilate 1 0.944   0.894 1.047    0.92   0.725          11.900
## hd1        erode 1 0.939   0.885 1.047    0.92   0.728         -11.531
## hd2       dilate 2 0.893   0.806 1.907    1.84   1.370          24.077
## hd3 shift 2 voxels 0.946   0.898 1.000    1.00   0.509           0.000

Metric Deviations

The table above shows numerical values while the plot shows where the errors occur. Each panel overlays the reference boundary (green) with the perturbed boundary (red). A translation (shift) moves every boundary point but preserves volume, while a dilation inflates volume but keeps the boundary near the original. Dice catches the dilation whereas Hausdorff measure catches the translation.

## Visualize boundary disagreements spatially.
if (!is.na(mask_path)) {
  library(ggplot2)
  library(patchwork)
  
  # Create boundary overlay plots for each variant
  plot_list <- lapply(names(variants), function(nm) {
    v <- variants[[nm]]
    ref_b <- which(boundary_pixels(ref), arr.ind = TRUE)
    var_b <- which(boundary_pixels(v), arr.ind = TRUE)
    
    df <- data.frame(
      x = c(ref_b[,1], var_b[,1]),
      y = c(ref_b[,2], var_b[,2]),
      type = c(rep("Reference", nrow(ref_b)), rep("Perturbed", nrow(var_b)))
    )
    
    d_val <- dice_coefficient(ref, v)
    hd_val <- hausdorff_distances(ref, v, spac)["hd"]
    
    ggplot(df, aes(x = x, y = y, color = type)) +
      geom_point(size = 0.8, alpha = 0.7) +
      scale_color_manual(values = c("Reference" = "#1b9e77", "Perturbed" = "#d95f02")) +
      labs(title = nm,
           subtitle = sprintf("Dice=%.3f | HD=%.1fmm", d_val, hd_val),
           x = "", y = "") +
      theme_minimal(base_size = 10) +
      theme(legend.position = "none",
            axis.text = element_blank(),
            panel.grid = element_blank()) +
      coord_equal()
  })
  
  wrap_plots(plot_list, ncol = 4) +
    plot_annotation(title = "Boundary Overlays: Reference (green) vs Perturbed (orange)",
                    subtitle = "Translation moves every point (low Dice, high HD) | Dilation inflates volume (low Dice, low HD)")
}

Overlap and distance metrics disagree by design. A uniform two-voxel translation can preserve shape and volume almost exactly while moving every boundary point. A uniform dilation preserves position while inflating volume. Dice responds mainly to the second, while Hausdorff mainly to the first. Hence, reporting a single number for “segmentation quality” hides whichever failure mode that number is insensitive to, which is why segmentation challenges report overlap and surface distance.

Interactive Exploration: Segmentation Metric Laboratory

The following app offers creating custom perturbations of the reference mask and inspecting the resulting metric changes. Try to find a perturbation that has high Dice but high Hausdorff distance (boundary shift), or low Dice but low Hausdorff (volume error only).

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Segmentation Metric Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("shift_x", "Shift in X (voxels):",
                  min = -5, max = 5, value = 0, step = 1),
      sliderInput("shift_y", "Shift in Y (voxels):",
                  min = -5, max = 5, value = 0, step = 1),
      sliderInput("dilate", "Dilation/erosion (voxels):",
                  min = -3, max = 3, value = 0, step = 1),
      sliderInput("noise_pct", "Boundary noise (%):",
                  min = 0, max = 30, value = 0, step = 5),
      hr(),
      helpText("Create a custom perturbation and observe how Dice, Jaccard, 
               and Hausdorff distance respond. Try to find cases where 
               Dice is high but HD is also high (boundary shift without 
               volume change).")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Mask Comparison", plotOutput("maskPlot", height = "400px")),
        tabPanel("Metric Bar Chart", plotOutput("metricPlot", height = "400px")),
        tabPanel("Metric Table", tableOutput("metricTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  perturbed_mask <- reactive({
    req(!is.na(mask_path))
    m <- ref
    
    # Apply dilation/erosion
    if (input$dilate > 0) {
      for (i in seq_len(input$dilate)) m <- dilate_mask(m)
    } else if (input$dilate < 0) {
      for (i in seq_len(abs(input$dilate))) m <- erode_mask(m)
    }
    
    # Apply shift
    if (input$shift_x != 0 || input$shift_y != 0) {
      shifted <- array(FALSE, dim(m))
      d <- dim(m)
      x_src <- pmax(1, 1 - input$shift_x):pmin(d[1], d[1] - input$shift_x)
      y_src <- pmax(1, 1 - input$shift_y):pmin(d[2], d[2] - input$shift_y)
      x_dst <- pmax(1, 1 + input$shift_x):pmin(d[1], d[1] + input$shift_x)
      y_dst <- pmax(1, 1 + input$shift_y):pmin(d[2], d[2] + input$shift_y)
      shifted[x_dst, y_dst] <- m[x_src, y_src]
      m <- shifted
    }
    
    # Apply boundary noise (capped to available voxels)
    if (input$noise_pct > 0) {
      b <- boundary_pixels(m)
      n_remove <- min(sum(b), floor(sum(b) * input$noise_pct / 100))
      noise_idx <- sample(which(b), n_remove)
      m[noise_idx] <- FALSE
      outside <- dilate_mask(m) & !m
      n_add <- min(sum(outside), n_remove)
      add_idx <- sample(which(outside), n_add)
      m[add_idx] <- TRUE
    }
    
    m
  })
  
  metrics <- reactive({
    v <- perturbed_mask()
    hd <- hausdorff_distances(ref, v, spac)
    data.frame(
      Metric = c("Dice", "Jaccard", "Hausdorff (mm)", "HD95 (mm)", "ASSD (mm)", 
                 "Volume change (%)"),
      Value = c(dice_coefficient(ref, v),
                jaccard_index(ref, v),
                hd["hd"], hd["hd95"], hd["assd"],
                100 * (sum(v) - sum(ref)) / sum(ref))
    )
  })
  
  output$maskPlot <- renderPlot({
    v <- perturbed_mask()
    
    # Create RGB overlay
    d <- dim(ref)
    overlay <- array(0, dim = c(d, 3))
    # Green channel = reference
    overlay[,,2] <- ifelse(ref, 1, 0)
    # Red channel = perturbed
    overlay[,,1] <- ifelse(v, 1, 0)
    # Yellow where both overlap
    
    df <- data.frame(
      x = rep(1:d[1], d[2]),
      y = rep(1:d[2], each = d[1]),
      ref = as.vector(ref),
      pert = as.vector(v)
    )
    df$color <- with(df, ifelse(ref & pert, "Overlap", 
                         ifelse(ref & !pert, "Reference only",
                         ifelse(!ref & pert, "Perturbed only", "Background"))))
    
    ggplot(df, aes(x = x, y = y, fill = color)) +
      geom_raster() +
      scale_fill_manual(values = c("Background" = "black",
                                   "Overlap" = "yellow",
                                   "Reference only" = "green",
                                   "Perturbed only" = "red")) +
      coord_equal() +
      labs(title = "Mask Comparison",
           subtitle = "Green=Ref only | Red=Perturbed only | Yellow=Overlap",
           x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(),
            panel.grid = element_blank())
  })
  
  output$metricPlot <- renderPlot({
    m <- metrics()
    m$Metric <- factor(m$Metric, levels = m$Metric)
    
    ggplot(m, aes(x = Metric, y = Value, fill = Metric)) +
      geom_col(width = 0.6) +
      geom_text(aes(label = round(Value, 3)), vjust = -0.5, size = 4) +
      scale_fill_brewer(palette = "Set2") +
      labs(title = "Segmentation Metrics",
           x = "", y = "Value") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none",
            axis.text.x = element_text(angle = 30, hjust = 1))
  })
  
  output$metricTable <- renderTable({
    m <- metrics()
    m$Value <- round(m$Value, 4)
    m
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

The sampled boundary calculation is just pedagogically illustrative. In practice, validated clinical software should use exact or well-characterized surface algorithms and specify tolerance, connectivity, and empty-mask behavior.

9.6 Hierarchical clustering and mixture models

Agglomerative clustering successively merges observations according to a linkage rule. A Gaussian mixture model instead assumes

\[p(x)=\sum_{k=1}^K\pi_k\,\mathcal N(x\mid\mu_k,\Sigma_k),\]

and produces probabilistic membership. Neither assumption is automatically appropriate for biomedical phenotypes.

Three philosophies of clustering.

K-means: Assumes spherical, equally-sized clusters. Hard assignment. Fast, scalable.
Hierarchical (Ward): Builds a tree by minimizing within-cluster variance at each merge. No $K$ needed upfront; dendrogram reveals structure at multiple scales. Assumes compact clusters.
Hierarchical (Single): Merges nearest neighbors. Can chain through outliers to create elongated, non-compact clusters. Useful for detecting connectivity, not convex shapes.
Gaussian Mixture: Assumes data is generated from $K$ multivariate normal distributions. Soft (probabilistic) assignment. Can model elliptical clusters with different sizes and orientations.

The choice is a modeling assumption, not a technical detail. Each method will find the structure it is designed to find, whether or not that structure exists.

## Hierarchical clustering of REAL imaging-derived tumor phenotypes.
if (have_imaging) {
  library(ggplot2)
  library(patchwork)
  library(dendextend)
  
  hc_vars <- c("log_tumor_volume", "tumor_sphericity", "surface_volume_index",
               "bbox_elongation")
  Hm <- kidney_img_model[, hc_vars]
  Hm <- Hm[complete.cases(Hm), ]
  Zh <- scale(Hm)
  rownames(Zh) <- kidney_img_model$case_id[complete.cases(kidney_img_model[, hc_vars])]

  hc_ward <- hclust(dist(Zh), method = "ward.D2")
  hc_single <- hclust(dist(Zh), method = "single")
  hc_complete <- hclust(dist(Zh), method = "complete")
  
  # Convert to dendrograms and color by 3-cluster cut
  dend_ward <- as.dendrogram(hc_ward) |> 
    color_branches(k = 3, col = c("#1b9e77", "#d95f02", "#2166ac"))
  dend_single <- as.dendrogram(hc_single) |> 
    color_branches(k = 3, col = c("#1b9e77", "#d95f02", "#2166ac"))
  
  op <- par(mfrow = c(2, 1), mar = c(6, 4.5, 3, 1))
  plot(dend_ward, cex = 0.55, main = "Ward linkage (compact clusters)",
       xlab = "", sub = "", ylab = "Height")
  plot(dend_single, cex = 0.55, main = "Single linkage (chaining effect)",
       xlab = "", sub = "", ylab = "Height")
  par(op)
  
  # Compare cluster assignments
  comparison_table <- table(
    ward = cutree(hc_ward, 3),
    single = cutree(hc_single, 3)
  )
  print(comparison_table)
  
  # Visualize in PCA space
  pc_hc <- prcomp(Zh)
  pca_df <- data.frame(
    PC1 = pc_hc$x[, 1],
    PC2 = pc_hc$x[, 2],
    ward = factor(cutree(hc_ward, 3)),
    single = factor(cutree(hc_single, 3))
  )
  
  p1 <- ggplot(pca_df, aes(x = PC1, y = PC2, color = ward)) +
    geom_point(size = 2.5, alpha = 0.7) +
    scale_color_manual(values = c("#1b9e77", "#d95f02", "#2166ac")) +
    labs(title = "Ward linkage (K=3)",
         subtitle = "Compact, balanced clusters",
         x = "PC1", y = "PC2") +
    theme_minimal(base_size = 12)
  
  p2 <- ggplot(pca_df, aes(x = PC1, y = PC2, color = single)) +
    geom_point(size = 2.5, alpha = 0.7) +
    scale_color_manual(values = c("#1b9e77", "#d95f02", "#2166ac")) +
    labs(title = "Single linkage (K=3)",
         subtitle = "Chaining: one large cluster + outliers",
         x = "PC1", y = "PC2") +
    theme_minimal(base_size = 12)
  
  print(p1 + p2)
}

##     single
## ward  1  2  3
##    1 24  0  0
##    2  0  1  0
##    3  4  0  1

The two linkages produce different partitions of identical data

Ward favors compact balanced groups, single linkage chains through near neighbours.
Linkage choice is a modeling assumption, not a detail.

Interactive Exploration: Linkage Laboratory

This app compares four linkage methods side-by-side on the same data. Adjust $K$ and observe how the cluster assignments change in PCA space. The silhouette plot tells you which linkage produces the most defensible partition.

library(shiny)
library(ggplot2)
library(dplyr)

ui <- fluidPage(
  titlePanel("Linkage Method Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("k", "Number of clusters (K):",
                  min = 2, max = 6, value = 3, step = 1),
      checkboxGroupInput("linkages", "Linkage methods to compare:",
                         choices = c("Ward", "Single", "Complete", "Average"),
                         selected = c("Ward", "Single", "Complete")),
      hr(),
      helpText("Ward produces compact, balanced clusters. Single linkage 
               chains through near neighbors. Complete and Average are 
               intermediates. The silhouette plot reveals which (if any) 
               produces defensible structure.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("PCA Clusters", plotOutput("pcaPlot", height = "450px")),
        tabPanel("Dendrograms", plotOutput("dendPlot", height = "450px")),
        tabPanel("Silhouette Comparison", plotOutput("silPlot", height = "400px")),
        tabPanel("Cluster Sizes", tableOutput("sizeTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  cluster_data <- reactive({
    req(have_imaging)
    req(length(input$linkages) > 0)
    
    pc_hc <- prcomp(Zh)
    df <- data.frame(PC1 = pc_hc$x[, 1], PC2 = pc_hc$x[, 2])
    
    results <- list()
    sils <- c()
    
    for (link in input$linkages) {
      method <- switch(link, "Ward" = "ward.D2", "Single" = "single",
                       "Complete" = "complete", "Average" = "average")
      hc <- hclust(dist(Zh), method = method)
      cl <- cutree(hc, input$k)
      df[[link]] <- factor(cl)
      
      # NOTE: Silhouette uses O(N^2) distance matrix. For very large datasets,
      # consider subsampling or using a faster implementation.
      # Silhouette
      D <- as.matrix(dist(Zh))
      s <- sapply(seq_len(nrow(Zh)), function(i) {
        own <- cl == cl[i]
        if (sum(own) <= 1) return(0)
        a <- mean(D[i, own & seq_len(nrow(Zh)) != i])
        b <- min(vapply(setdiff(unique(cl), cl[i]),
                        function(g) mean(D[i, cl == g]), numeric(1)))
        (b - a) / max(a, b)
      })
      sils <- c(sils, mean(s))
      results[[link]] <- list(cl = cl, hc = hc, sil = mean(s))
    }
    
    list(df = df, results = results, sils = sils)
  })
  
  output$pcaPlot <- renderPlot({
    d <- cluster_data()
    
    # Reshape for faceting
    df_long <- do.call(rbind, lapply(input$linkages, function(link) {
      data.frame(PC1 = d$df$PC1, PC2 = d$df$PC2, 
                 cluster = d$df[[link]], method = link)
    }))
    
    ggplot(df_long, aes(x = PC1, y = PC2, color = cluster)) +
      geom_point(size = 2, alpha = 0.7) +
      facet_wrap(~ method, ncol = 2) +
      scale_color_manual(values = c("#1b9e77", "#d95f02", "#2166ac", 
                                    "#e41a1c", "#984ea3", "#ff7f00")) +
      labs(title = sprintf("Cluster Assignments by Linkage (K=%d)", input$k),
           x = "PC1", y = "PC2") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom")
  })
  
  output$dendPlot <- renderPlot({
    d <- cluster_data()
    par(mfrow = c(length(input$linkages), 1), mar = c(4, 4, 2, 1))
    for (link in input$linkages) {
      hc <- d$results[[link]]$hc
      # Height that yields exactly input$k clusters
      cutoff <- hc$height[length(hc$height) - input$k + 2]
      plot(as.dendrogram(hc), cex = 0.4,
           main = paste(link, "linkage"),
           xlab = "", sub = "", ylab = "Height")
      abline(h = cutoff, lty = 2, col = "#d95f02", lwd = 1.5)
    }
  })
  
  output$silPlot <- renderPlot({
    d <- cluster_data()
    sil_df <- data.frame(
      method = input$linkages,
      silhouette = d$sils
    )
    y_min <- min(0, min(sil_df$silhouette) - 0.05)
    y_max <- max(0.7, max(sil_df$silhouette) + 0.1)
    
    ggplot(sil_df, aes(x = method, y = silhouette, fill = method)) +
      geom_col(width = 0.6) +
      geom_hline(yintercept = 0, color = "grey40") +
      geom_hline(yintercept = 0.25, lty = 2, color = "orange") +
      geom_hline(yintercept = 0.50, lty = 2, color = "green") +
      geom_text(aes(label = round(silhouette, 3)), vjust = -0.5, size = 4) +
      scale_fill_brewer(palette = "Set2") +
      labs(title = "Mean Silhouette Width by Linkage",
           subtitle = "Orange = weak structure | Green = strong structure",
           x = "Linkage method", y = "Mean silhouette width") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none") +
      ylim(y_min, y_max)
  })
  
  output$sizeTable <- renderTable({
    d <- cluster_data()
    
    size_list <- lapply(input$linkages, function(link) {
      tab <- table(d$df[[link]])
      data.frame(Method = link, 
                 Sizes = paste(tab, collapse = " / "),
                 Min = min(tab), Max = max(tab),
                 Ratio = round(max(tab) / min(tab), 1))
    })
    do.call(rbind, size_list)
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

9.7 Graph-based and spectral segmentation

Graph-based and spectral segmentation methods represent pixels or superpixels as graph nodes. Let edge weights $w_{ij}$ encode spatial and intensity similarity. With degree matrix $D_{ii}=\sum_jw_{ij}$, the unnormalized graph Laplacian is

\[L=D-W.\]

Low-frequency eigenvectors vary slowly over strongly connected regions. The Fiedler vector, associated with the second-smallest eigenvalue, can induce a bipartition.

Let the set of nodes (vertices) be $V = \{v_1, v_2, \dots, v_n\}$, where each node corresponds to a pixel (or a superpixel, a small region of pixels). The total number of nodes is $n$.

An edge connects two nodes $v_i$ and $v_j$ with a non‑negative weight $w_{ij} \ge 0$. This weight encodes how “similar” the two pixels are. The weights are collected into the weighted adjacency matrix

\[W = [w_{ij}] \in \mathbb{R}^{n \times n}, \qquad w_{ij} = w_{ji} \quad (\text{symmetric}), \quad w_{ii} = 0.\]

In image segmentation tasks, a common choice is a product of a spatial kernel and an intensity kernel

\[w_{ij} = \exp\!\left(-\frac{\|x_i - x_j\|^2}{2\sigma_s^2}\right) \cdot \exp\!\left(-\frac{|I_i - I_j|^2}{2\sigma_i^2}\right),\]

where $x_i$ is the spatial coordinate of pixel $i$, $I_i$ is its intensity, and $\sigma_s, \sigma_i$ are scaling parameters. The kernel ensures that only pixels that are both close in space and similar in intensity are strongly connected.

The degree $d_i$ of a node $v_i$ is the sum of the weights of all edges incident to it

\[d_i = \sum_{j=1}^n w_{ij}.\]

The degree matrix $D$ is the diagonal matrix whose diagonal entries are the degrees

\[D = \operatorname{diag}(d_1, d_2, \dots, d_n) \in \mathbb{R}^{n \times n}, \qquad D_{ii} = d_i = \sum_{j=1}^n w_{ij}, \quad D_{ij} = 0 \text{ for } i \neq j.\]

Thus, each diagonal entry $D_{ii}$ measures how strongly node $i$ is connected to the rest of the graph.

The unnormalized graph Laplacian is defined as

\[L = D - W,\] where the entries of $L$ are

\[L_{ij} = \begin{cases} d_i, & \text{if } i = j, \\ -w_{ij}, & \text{if } i \neq j. \end{cases}\]

Properties of $L$ that make it useful for spectral analysis include

Symmetry: Since $D$ is diagonal and $W$ is symmetric, $L$ is symmetric.
Positive semidefiniteness: For any vector $f \in \mathbb{R}^n$,

\[f^\top L f = \frac{1}{2} \sum_{i=1}^n \sum_{j=1}^n w_{ij} (f_i - f_j)^2 \ge 0.\]

All eigenvalues of $L$ are non‑negative \[0 = \lambda_1 \le \lambda_2 \le \cdots \le \lambda_n .\]

The smallest eigenvalue and eigenvector: The constant vector $\mathbf{1} = (1,1,\dots,1)^\top$ satisfies $L\mathbf{1} = 0$, so $\lambda_1 = 0$ with eigenvector $\mathbf{1}$. The multiplicity of the eigenvalue zero equals the number of connected components of the graph.
Spectral interpretation: The quadratic form $f^\top L f$ is a “smoothness” measure, which penalizes vectors $f$ that vary a lot across strongly connected nodes.

The second smallest eigenvalue $\lambda_2$ and its associated eigenvector $v_2$ (the Fiedler vector) capture the most prominent non‑trivial partition of the graph. Because $v_2$ is orthogonal to $\mathbf{1}$, it has both positive and negative components. A natural binary segmentation is obtained by thresholding the Fiedler vector

\[\text{cluster}_1 = \{i \mid v_2(i) \ge 0\}, \quad \text{cluster}_2 = \{i \mid v_2(i) < 0\}.\]

This partition minimizes the normalized cut cost among all bipartitions that can be approximated by the spectral relaxation. In the BPAD textbook, this is exactly the “spectral cut” illustrated in the code, where the Fiedler vector is computed from $L$ (or its normalized variant). Its sign pattern splits the image into two regions that are internally coherent but weakly connected.

For completeness, the normalized symmetric Laplacian is

\[L_{\text{sym}} = I - D^{-1/2} W D^{-1/2},\]

which has similar properties but accounts for node degrees, making the cut more robust to varying region sizes. The unnormalized version $L = D - W$ is the simplest starting point and is the one introduced in the excerpt you quoted.

The intuition behind spectral clustering. Imagine a graph where pixels are connected by springs. Strong springs connect pixels that are spatially close and have similar intensity. Weak springs connect pixels that are far apart or have different intensities. If you “pluck” this graph, it vibrates at certain frequencies. The lowest frequency (first eigenvector) is a constant. The second lowest frequency (Fiedler vector) is the fundamental mode of vibration. It divides the graph into two regions that are strongly connected internally but weakly connected to each other. This is the spectral cut.

## Graph-based segmentation of a REAL image patch.
## Dense eigendecomposition is O(n^3), so we use a deliberately small patch.
if (have_image) {
  patch <- slice[seq(1, nrow(slice), by = 3), seq(1, ncol(slice), by = 3)]
  n1 <- nrow(patch); n2 <- ncol(patch); N <- n1 * n2

  coords <- expand.grid(row = seq_len(n1), col = seq_len(n2))
  intensity <- as.numeric(patch)
  d_space <- as.matrix(dist(coords))
  d_int   <- as.matrix(dist(intensity / max(abs(intensity))))

  sigma_s <- 3; sigma_i <- 0.15
  W <- exp(-(d_space^2) / (2 * sigma_s^2)) * exp(-(d_int^2) / (2 * sigma_i^2))
  W[d_space > 3 * sigma_s] <- 0            # sparsify
  diag(W) <- 0

  Dg <- rowSums(W)
  L_sym <- diag(N) - diag(1 / sqrt(pmax(Dg, 1e-9))) %*% W %*%
    diag(1 / sqrt(pmax(Dg, 1e-9)))
  eig <- eigen(L_sym, symmetric = TRUE)
  fiedler <- eig$vectors[, N - 1]          # second-smallest eigenvector

  op <- par(mfrow = c(1, 3), mar = c(2, 2, 3, 1))
  image(patch, col = grey.colors(64), axes = FALSE, main = "Real patch"); box()
  image(matrix(fiedler, n1, n2), col = hcl.colors(64, "Blue-Red"), axes = FALSE,
        main = "Fiedler vector"); box()
  image(matrix(as.numeric(fiedler > median(fiedler)), n1, n2),
        col = c("#f0f0f0", "#08519c"), axes = FALSE,
        main = "Spectral cut"); box()
  par(op)

  cat("smallest eigenvalues:", paste(round(rev(eig$values)[1:5], 5), collapse = ", "), "\n")
}

Interactive Exploration: Graph Construction Laboratory

The graph Laplacian depends critically on two parameters, $\sigma_s$ (spatial scale) and $\sigma_i$ (intensity scale). These control which pixels are considered “similar.” The app below lets you adjust these parameters and watch how the Fiedler vector and spectral cut change. Small $\sigma_s$ produces local, fragmented cuts with large $\sigma_s$ producing global, smooth cuts.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Spectral Segmentation Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("sigma_s", "Spatial scale (σ_s):",
                  min = 1, max = 8, value = 3, step = 0.5),
      sliderInput("sigma_i", "Intensity scale (σ_i):",
                  min = 0.05, max = 0.5, value = 0.15, step = 0.05),
      sliderInput("subsample", "Subsample factor:",
                  min = 1, max = 5, value = 3, step = 1),
      radioButtons("n_cuts", "Number of cuts:",
                   choices = c("2 (bipartition)", "3", "4"),
                   selected = "2 (bipartition)"),
      hr(),
      helpText("σ_s controls spatial connectivity: small = local fragments, 
               large = global regions. σ_i controls intensity sensitivity: 
               small = only similar intensities connected, large = tolerant 
               of intensity differences. The eigengap (jump in eigenvalues) 
               suggests the natural number of clusters.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Segmentation", plotOutput("segPlot", height = "450px")),
        tabPanel("Fiedler Vector", plotOutput("fiedlerPlot", height = "400px")),
        tabPanel("Eigenvalue Spectrum", plotOutput("eigPlot", height = "400px")),
        tabPanel("Graph Weight Matrix", plotOutput("graphPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  spec_data <- reactive({
    req(have_image)
    
    patch <- slice[seq(1, nrow(slice), by = input$subsample),
                   seq(1, ncol(slice), by = input$subsample)]
    n1 <- nrow(patch); n2 <- ncol(patch); N <- n1 * n2
    
    coords <- expand.grid(row = seq_len(n1), col = seq_len(n2))
    intensity <- as.numeric(patch)
    d_space <- as.matrix(dist(coords))
    d_int <- as.matrix(dist(intensity / max(abs(intensity))))
    
    W <- exp(-(d_space^2) / (2 * input$sigma_s^2)) * 
         exp(-(d_int^2) / (2 * input$sigma_i^2))
    W[d_space > 3 * input$sigma_s] <- 0
    diag(W) <- 0
    
    Dg <- rowSums(W)
    L_sym <- diag(N) - diag(1 / sqrt(pmax(Dg, 1e-9))) %*% W %*%
      diag(1 / sqrt(pmax(Dg, 1e-9)))
    eig <- eigen(L_sym, symmetric = TRUE)
    
    n_cuts <- as.integer(substr(input$n_cuts, 1, 1))
    # Use eigenvectors corresponding to 2nd through n_cuts+1 smallest eigenvalues
    # Eigenvalues are sorted in descending order by default
    eig_vecs <- eig$vectors[, (N - 1):(N - n_cuts + 1)]
    # K-means on eigenvectors
    set.seed(42)
    km_spec <- kmeans(eig_vecs, centers = n_cuts, nstart = 10)
    
    list(
      patch = patch,
      fiedler = eig$vectors[, N - 1],
      eigvals = rev(eig$values),
      clusters = km_spec$cluster,
      W = W,
      n1 = n1, n2 = n2,
      n_cuts = n_cuts
    )
  })
  
  output$segPlot <- renderPlot({
    d <- spec_data()
    
    df <- data.frame(
      x = rep(1:d$n1, d$n2),
      y = rep(1:d$n2, each = d$n1),
      intensity = as.numeric(d$patch),
      cluster = factor(d$clusters)
    )
    
    p1 <- ggplot(df, aes(x = x, y = y, fill = intensity)) +
      geom_raster() +
      scale_fill_gradient(low = "black", high = "white") +
      coord_equal() +
      labs(title = "Original patch", x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), panel.grid = element_blank(),
            legend.position = "none")
    
    p2 <- ggplot(df, aes(x = x, y = y, fill = cluster)) +
      geom_raster() +
      scale_fill_manual(values = c("#f0f0f0", "#9ecae1", "#08519c", "#6baed6")) +
      coord_equal() +
      labs(title = sprintf("Spectral segmentation (%d regions)", d$n_cuts),
           x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), panel.grid = element_blank())
    
    p1 + p2
  })
  
  output$fiedlerPlot <- renderPlot({
    d <- spec_data()
    
    df <- data.frame(
      x = rep(1:d$n1, d$n2),
      y = rep(1:d$n2, each = d$n1),
      fiedler = d$fiedler
    )
    
    ggplot(df, aes(x = x, y = y, fill = fiedler)) +
      geom_raster() +
      scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b",
                           midpoint = 0) +
      coord_equal() +
      labs(title = "Fiedler Vector (2nd smallest eigenvector)",
           subtitle = "Sign changes indicate the spectral cut boundary",
           x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), panel.grid = element_blank())
  })
  
  output$eigPlot <- renderPlot({
    d <- spec_data()
    
    # Show smallest 10 eigenvalues
    n_show <- min(10, length(d$eigvals))
    eig_df <- data.frame(
      index = 1:n_show,
      eigenvalue = d$eigvals[1:n_show]
    )
    
    ggplot(eig_df, aes(x = index, y = eigenvalue)) +
      geom_line(color = "#2166ac", size = 1) +
      geom_point(size = 3, color = "#2166ac") +
      geom_vline(xintercept = d$n_cuts + 0.5, lty = 2, color = "#d95f02") +
      annotate("text", x = d$n_cuts + 1, y = max(eig_df$eigenvalue) * 0.9,
               label = "Eigengap", color = "#d95f02", size = 4) +
      labs(title = "Smallest Eigenvalues of Graph Laplacian",
           subtitle = "A large gap suggests natural number of clusters",
           x = "Index (1 = smallest)", y = "Eigenvalue") +
      theme_minimal(base_size = 13)
  })
  
  output$graphPlot <- renderPlot({
    d <- spec_data()
    
    # Show a subset of the weight matrix for visualization
    n_show <- min(100, nrow(d$W))
    W_sub <- d$W[1:n_show, 1:n_show]
    
    df <- as.data.frame(as.table(W_sub))
    colnames(df) <- c("Pixel_i", "Pixel_j", "Weight")
    df$Weight <- as.numeric(df$Weight)
    
    ggplot(df, aes(x = Pixel_i, y = Pixel_j, fill = Weight)) +
      geom_raster() +
      scale_fill_gradient(low = "white", high = "#2166ac", limits = c(0, NA)) +
      coord_equal() +
      labs(title = "Graph Weight Matrix (subset)",
           subtitle = sprintf("σ_s=%.1f | σ_i=%.2f | Sparsity: %.1f%% zeros",
                              input$sigma_s, input$sigma_i,
                              100 * mean(d$W == 0)),
           x = "Pixel i", y = "Pixel j") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank())
  })
}

shinyApp(ui, server)

Modern graph methods use sparse matrices, normalized Laplacians, superpixels, and scalable eigensolvers. Note that graph construction is itself a model, which has to be validated.

Try it yourself. 1. Spatial scale. Set $\sigma_s = 1$ (very local). The segmentation becomes fragmented, each small intensity region is its own cluster. Now set $\sigma_s = 8$ (global). The segmentation becomes very smooth but may merge anatomically distinct regions. Where is the clinical sweet spot? 2. Intensity scale. Set $\sigma_i = 0.05$ (strict). Only near-identical intensities are connected, producing many small fragments. Set $\sigma_i = 0.5$ (tolerant). Very different intensities are connected, producing coarse regions that ignore real boundaries. 3. Eigengap. Look at the eigenvalue spectrum. Is there a clear “jump” after the 2nd or 3rd eigenvalue? This gap suggests the natural number of clusters. If there is no gap, the data is a continuum, forcing a partition is arbitrary. 4. Comparison to k-means. How does the spectral cut compare to the intensity k-means from Section 9.4? Spectral clustering respects spatial contiguity (connected regions), while k-means does not. But both require choosing $K$, and both can over-partition.

From Spectral to Deep Learning Segmentation

Era	Method	Key Idea	Limitation
2000s	Spectral / Normalized Cuts	Graph Laplacian eigenvectors	$O(n^3)$ eigendecomposition
2010s	SLIC superpixels + graph cuts	Over-segment then merge	Still intensity-based
2015+	U-Net / FCN	End-to-end learned features	Requires labeled training data
2020+	nnU-Net / Swin-UNETR	Self-configuring transformers	Domain adaptation, explainability

The progression mirrors the move from unsupervised to supervised learning throughout this chapter. Intensity k-means discovers structure, spectral clustering adds spatial priors, and deep learning recognizes structure from examples. Each step requires more labeled data but produces more clinically useful segmentations.

10. Deep Learning and Image-Native AI

Classical radiomics specifies $g(I,M)$ and learns only the final mapping $f$. Deep learning jointly learns representations and predictions

\[\widehat y=f_{\theta}\{g_{\phi}(I)\}.\]

This flexibility can exploit spatial context but raises data, compute, validation, and interpretability requirements.

The two cultures of medical image AI. * Classical radiomics (Chapters 6-9): Human expert defines features $g$ (shape, texture, intensity statistics). Model learns only $f$, e.g., logistic regression, random forest. Advantages: interpretable features, small-sample viable, reproducible across sites. Limitation: features are fixed and may miss predictive patterns humans did not think to encode. * Deep learning (this chapter): Model learns both $g$ (convolutional feature extractors) and $f$ (classifier head) end-to-end. Advantage: can discover subtle spatial patterns invisible to hand-crafted features. Limitation: requires thousands of labeled examples, is sensitive to shortcut learning, and acts as a black box.

The choice is not deep learning vs. radiomics. Rather, it is matching the representation learning strategy to the sample size, label quality, and clinical question.

10.1 Neurons, multilayer networks, and backpropagation

DSPA2 Chapter 14 (DNN) presents multilayer perceptrons (MLP) composed of (artificial) neurons computing

\[a=\sigma(w^\top x+b).\]

For layers $\ell=1,\ldots,L$,

\[h^{(\ell)}=\sigma_{\ell} \left(W^{(\ell)}h^{(\ell-1)}+b^{(\ell)}\right).\]

Backpropagation applies the chain rule to compute gradients of loss (objective function) with respect to all parameters. For a mini-batch $B$,

\[\theta_{t+1}=\theta_t-\frac{\eta_t}{|B|} \sum_{i\in B}\nabla_{\theta}L_i(\theta_t).\]

Automatic differentiation implements this calculation, but it does not validate labels, prevent leakage, or guarantee clinically sensible representations.

Anatomy of a One-Hidden-Layer Network

library(DiagrammeR)

grViz("
digraph neural_network {
  # Graph setup
  graph [layout = dot, rankdir = LR, compound = true, nodesep = 0.4, ranksep = 0.8]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # --- SUBGRAPH 1: INPUT LAYER ---
  subgraph cluster_input {
    label = 'Input Layer (p features)'
    fontname = 'Helvetica-Bold'
    fontsize = 11
    style = filled
    color = '#B3E5FC'
    fillcolor = '#F0F8FF'

    X1 [label = 'x₁', fillcolor = '#e1f5fe', style = 'filled']
    X2 [label = 'x₂', fillcolor = '#e1f5fe', style = 'filled']
    XP [label = 'xp', fillcolor = '#e1f5fe', style = 'filled']
  }

  # --- SUBGRAPH 2: HIDDEN LAYER ---
  subgraph cluster_hidden {
    label = 'Hidden Layer (h units)'
    fontname = 'Helvetica-Bold'
    fontsize = 11
    style = filled
    color = '#FFE0B2'
    fillcolor = '#FFF8E7'

    Z1 [label = 'z₁ = w₁ᵀx + b₁']
    Z2 [label = 'z₂ = w₂ᵀx + b₂']
    ZH [label = 'zh = whᵀx + bh']
    
    A1 [label = 'a₁ = ReLU(z₁)', fillcolor = '#fff3e0', style = 'filled']
    A2 [label = 'a₂ = ReLU(z₂)', fillcolor = '#fff3e0', style = 'filled']
    AH [label = 'ah = ReLU(zh)', fillcolor = '#fff3e0', style = 'filled']

    Z1 -> A1
    Z2 -> A2
    ZH -> AH
  }

  # --- SUBGRAPH 3: OUTPUT LAYER ---
  subgraph cluster_output {
    label = 'Output Layer'
    fontname = 'Helvetica-Bold'
    fontsize = 11
    style = filled
    color = '#C8E6C9'
    fillcolor = '#F1F8E9'

    Y [label = 'ŷ = σ(W₂ᵀa + b₂)', fillcolor = '#e8f5e9', style = 'filled,bold']
  }

  # --- CONNECTIONS: INPUT TO HIDDEN ---
  X1 -> {Z1 Z2 ZH}
  X2 -> {Z1 Z2 ZH}
  XP -> {Z1 Z2 ZH}

  # --- CONNECTIONS: HIDDEN TO OUTPUT ---
  A1 -> Y
  A2 -> Y
  AH -> Y
}
")

The network above has $(p \times h) + h + (h \times 1) + 1 = h(p+2) + 1$ parameters, which need to be estimated during the neural network training (fitting) process using available data. With $p=10$ tabular features and $h=8$ hidden units, that is $97$ parameters, which is already more than the $60$ training cases available in KiTS. This is the fundamental reason deep learning on small tabular data is doomed, the parameter-to-sample ratio guarantees overfitting.

10.2 An executable one-hidden-layer network from first principles

The following base-R network explicated forward-propagation and back-propagation. It is not optimized for production.

## A one-hidden-layer network trained by explicit backpropagation on the REAL
## standardized kidney design matrix. Every gradient is written out.
train_mlp <- function(X, y, hidden = 8, epochs = 400, lr = 0.05,
                      weight_decay = 1e-3, seed = 1, verbose = FALSE) {
  set.seed(seed)
  n <- nrow(X); p <- ncol(X)
  W1 <- matrix(rnorm(p * hidden, sd = sqrt(2 / p)), p, hidden)
  b1 <- rep(0, hidden)
  W2 <- matrix(rnorm(hidden, sd = sqrt(2 / hidden)), hidden, 1)
  b2 <- 0
  loss_history <- numeric(epochs)
  val_loss_history <- numeric(epochs)

  for (e in seq_len(epochs)) {
    ## ---- forward ----
    Z1 <- sweep(X %*% W1, 2, b1, "+")
    A1 <- pmax(Z1, 0)                              # ReLU
    Z2 <- as.numeric(A1 %*% W2) + b2
    P  <- 1 / (1 + exp(-Z2))                       # sigmoid
    P  <- pmin(pmax(P, 1e-9), 1 - 1e-9)
    loss_history[e] <- -mean(y * log(P) + (1 - y) * log(1 - P)) +
      weight_decay * (sum(W1^2) + sum(W2^2))

    ## ---- backward (cross-entropy + sigmoid gives dL/dZ2 = P - y) ----
    dZ2 <- (P - y) / n
    dW2 <- t(A1) %*% dZ2 + 2 * weight_decay * W2
    db2 <- sum(dZ2)
    dA1 <- dZ2 %*% t(W2)
    dZ1 <- dA1 * (Z1 > 0)                          # ReLU derivative
    dW1 <- t(X) %*% dZ1 + 2 * weight_decay * W1
    db1 <- colSums(dZ1)

    W1 <- W1 - lr * dW1; b1 <- b1 - lr * db1
    W2 <- W2 - lr * dW2; b2 <- b2 - lr * db2
  }
  list(W1 = W1, b1 = b1, W2 = W2, b2 = b2, loss = loss_history, 
       hidden = hidden, p = p)
}

predict_mlp <- function(model, X) {
  A1 <- pmax(sweep(X %*% model$W1, 2, model$b1, "+"), 0)
  as.numeric(1 / (1 + exp(-(as.numeric(A1 %*% model$W2) + model$b2))))
}

mlp <- train_mlp(X_train, y_train, hidden = 8, epochs = 400, lr = 0.05)
mlp_internal <- predict_mlp(mlp, X_internal)
mlp_external <- predict_mlp(mlp, X_external)

round(rbind(
  training      = classification_metrics(y_train, predict_mlp(mlp, X_train)),
  internal_test = classification_metrics(y_internal, mlp_internal),
  external_test = classification_metrics(y_external, mlp_external)
)[, c("n", "auc", "brier", "log_loss")], 3)

##                 n   auc brier log_loss
## training      120 0.781 0.064    0.229
## internal_test  41 0.682 0.084    0.286
## external_test  49 0.518 0.095    0.403

Visualizing What the Network Learned

The heatmap below shows the input-layer weights ($W_1$). Each column represents one hidden unit and each row is one input feature. Large positive weights (red) mean the feature activates that hidden unit, whereas large negative weights (blue) suppress it. The key observation is that with only $9$ benign cases, the hidden units have learned to detect noise patterns in the malignant majority, not real benign-vs-malignant distinctions.

## Visualize the learned weights to understand what the network "discovered."
library(ggplot2)
library(tidyr)
library(patchwork)

# W1: p x hidden matrix (input-to-hidden weights)
w1_df <- as.data.frame(mlp$W1)
w1_df$feature <- colnames(X_train)
w1_long <- pivot_longer(w1_df, -feature, names_to = "hidden_unit", values_to = "weight")
w1_long$hidden_unit <- factor(w1_long$hidden_unit, levels = paste0("V", 1:mlp$hidden))

p1 <- ggplot(w1_long, aes(x = hidden_unit, y = feature, fill = weight)) +
  geom_tile(color = "white") +
  scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", 
                       midpoint = 0, name = "Weight") +
  labs(title = "Input-to-Hidden Weights (W1)",
       subtitle = "Each column = one hidden unit. What feature combinations did it learn?",
       x = "Hidden unit", y = "") +
  theme_minimal(base_size = 11) +
  theme(axis.text.x = element_text(angle = 0))

# W2: hidden x 1 vector (hidden-to-output weights)
w2_df <- data.frame(
  hidden_unit = paste0("V", 1:mlp$hidden),
  weight = as.numeric(mlp$W2)
)
p2 <- ggplot(w2_df, aes(x = hidden_unit, y = weight, fill = weight)) +
  geom_col() +
  scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", 
                       midpoint = 0, name = "Weight") +
  labs(title = "Hidden-to-Output Weights (W2)",
       subtitle = "Which hidden units drive the malignancy prediction?",
       x = "Hidden unit", y = "Weight") +
  theme_minimal(base_size = 11) +
  theme(legend.position = "none")

# Training loss
loss_df <- data.frame(epoch = seq_along(mlp$loss), loss = mlp$loss)
p3 <- ggplot(loss_df, aes(x = epoch, y = loss)) +
  geom_line(color = "#2c7fb8", size = 1) +
  labs(title = "Training Loss",
       subtitle = "Cross-entropy + weight decay",
       x = "Epoch", y = "Loss") +
  theme_minimal(base_size = 11)

p1 / (p2 + p3)

op <- par(mfrow = c(1, 2), mar = c(4.5, 4.5, 3, 1))
plot(mlp$loss, type = "l", lwd = 2, col = "#2c7fb8",
     xlab = "Epoch", ylab = "Penalized cross-entropy",
     main = "Training loss (real data)")

## Capacity sweep: more hidden units fit training data better, not test data.
widths <- c(2, 4, 8, 16, 32)
cap <- t(sapply(widths, function(h) {
  m <- train_mlp(X_train, y_train, hidden = h, epochs = 400, lr = 0.05)
  c(train = auc_rank(y_train, predict_mlp(m, X_train)),
    internal = auc_rank(y_internal, predict_mlp(m, X_internal)))
}))
matplot(widths, cap, type = "b", pch = 19, lty = 1, log = "x",
        col = c("#1b9e77", "#d95f02"), xlab = "Hidden units",
        ylab = "AUC", main = "Capacity vs. generalization")
legend("bottomleft", c("training", "internal test"),
       col = c("#1b9e77", "#d95f02"), lty = 1, pch = 19, bty = "n", cex = 0.8)

par(op)
round(cbind(hidden = widths, cap), 3)

##      hidden train internal
## [1,]      2 0.858    0.554
## [2,]      4 0.836    0.649
## [3,]      8 0.781    0.682
## [4,]     16 0.886    0.642
## [5,]     32 0.902    0.581

This is a demonstration of mechanism, not a recommendation. With 120 training cases and 9 benign examples, a neural network has no chance of beating logistic regression, and the capacity sweep shows training AUC climbing while held-out AUC does not. Deep learning earns its keep on raw voxels with thousands of studies, not on ten tabular predictors.

The capacity sweep tells a universal story. Look at the plot on the right, as hidden units increase, training AUC climbs steadily (the network memorizes the training set), but internal test AUC stays flat or degrades. This gap between training and test performance is the generalization gap. It is the single most important diagnostic in deep learning. If the training AUC is $0.95$ but our validation AUC is $0.55$, the network is not learning a generalizable signal, rather, it’s fitting noise, aka, overfitting.

Interactive Exploration: Neural Network Capacity Laboratory

This app supports manipulating the network architecture, its capacity (hidden units), training duration (epochs), learning rate, and regularization strength (weight decay). On small tabular data, no combination of hyperparameters will close the generalization gap, the model simply does not have enough benign examples to learn what distinguishes benign from malignant.

library(shiny)
library(ggplot2)
library(tidyr)
library(patchwork)

ui <- fluidPage(
  titlePanel("Neural Network Capacity Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("hidden", "Hidden units:",
                  min = 1, max = 32, value = 8, step = 1),
      sliderInput("epochs", "Epochs:",
                  min = 50, max = 1000, value = 400, step = 50),
      sliderInput("lr", "Learning rate:",
                  min = 0.001, max = 0.5, value = 0.05, step = 0.01),
      sliderInput("wd", "Weight decay (L2):",
                  min = 0, max = 0.1, value = 0.001, step = 0.001),
      actionButton("train", "Train Network"),
      hr(),
      helpText("Watch the generalization gap: training AUC will climb 
               with more capacity, but test AUC will not follow. 
               This is overfitting in real time.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Training & Performance", 
                 plotOutput("lossPlot", height = "300px"),
                 plotOutput("capacityPlot", height = "300px")),
        tabPanel("Learned Weights", plotOutput("weightPlot", height = "500px")),
        tabPanel("Predictions", 
                 plotOutput("predPlot", height = "400px"),
                 tableOutput("metricsTable")),
        tabPanel("Comparison", tableOutput("comparisonTable"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  model <- eventReactive(input$train, {
    train_mlp(X_train, y_train, hidden = input$hidden, epochs = input$epochs,
              lr = input$lr, weight_decay = input$wd, seed = 42)
  })
  
  output$lossPlot <- renderPlot({
    m <- model()
    loss_df <- data.frame(epoch = seq_along(m$loss), loss = m$loss)
    
    ggplot(loss_df, aes(x = epoch, y = loss)) +
      geom_line(color = "#2c7fb8", size = 1) +
      labs(title = "Training Loss",
           subtitle = sprintf("h=%d | epochs=%d | lr=%.3f | wd=%.4f",
                              input$hidden, input$epochs, input$lr, input$wd),
           x = "Epoch", y = "Cross-entropy loss") +
      theme_minimal(base_size = 12)
  })
  
  output$capacityPlot <- renderPlot({
    m <- model()
    train_auc <- auc_rank(y_train, predict_mlp(m, X_train))
    int_auc <- auc_rank(y_internal, predict_mlp(m, X_internal))
    ext_auc <- auc_rank(y_external, predict_mlp(m, X_external))
    
    perf_df <- data.frame(
      dataset = c("Training", "Internal Test", "External Test"),
      auc = c(train_auc, int_auc, ext_auc)
    )
    perf_df$dataset <- factor(perf_df$dataset, levels = perf_df$dataset)
    
    ggplot(perf_df, aes(x = dataset, y = auc, fill = dataset)) +
      geom_col(width = 0.6) +
      geom_text(aes(label = round(auc, 3)), vjust = -0.5, size = 5) +
      geom_hline(yintercept = 0.5, lty = 2, color = "red") +
      scale_fill_manual(values = c("#1b9e77", "#d95f02", "#b2182b")) +
      labs(title = "Generalization Gap",
           subtitle = "Gap between training and test AUC = overfitting",
           x = "", y = "AUC") +
      ylim(0, 1) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none")
  })
  
  output$weightPlot <- renderPlot({
    m <- model()
    
    # W1 heatmap
    w1_df <- as.data.frame(m$W1)
    w1_df$feature <- colnames(X_train)
    w1_long <- pivot_longer(w1_df, -feature, names_to = "hidden_unit", values_to = "weight")
    
    p1 <- ggplot(w1_long, aes(x = hidden_unit, y = feature, fill = weight)) +
      geom_tile(color = "white") +
      scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", midpoint = 0) +
      labs(title = "W₁: Input-to-Hidden Weights", x = "Hidden unit", y = "") +
      theme_minimal(base_size = 10)
    
    # W2 barplot
    w2_df <- data.frame(
      hidden_unit = paste0("V", 1:m$hidden),
      weight = as.numeric(m$W2)
    )
    p2 <- ggplot(w2_df, aes(x = hidden_unit, y = weight, fill = weight)) +
      geom_col() +
      scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", midpoint = 0) +
      labs(title = "W₂: Hidden-to-Output Weights", x = "Hidden unit", y = "Weight") +
      theme_minimal(base_size = 10) +
      theme(legend.position = "none", axis.text.x = element_text(angle = 45))
    
    p1 / p2
  })
  
  output$predPlot <- renderPlot({
    m <- model()
    p_train <- predict_mlp(m, X_train)
    p_int <- predict_mlp(m, X_internal)
    p_ext <- predict_mlp(m, X_external)
    
    df <- data.frame(
      prob = c(p_train, p_int, p_ext),
      y = c(y_train, y_internal, y_external),
      dataset = c(rep("Training", length(p_train)),
                  rep("Internal", length(p_int)),
                  rep("External", length(p_ext)))
    )
    df$dataset <- factor(df$dataset, levels = c("Training", "Internal", "External"))
    df$status <- ifelse(df$y == 1, "Malignant", "Benign")
    
    ggplot(df, aes(x = prob, fill = status)) +
      geom_dotplot(method = "histodot", binwidth = 0.05, dotsize = 0.8,
                   stackgroups = TRUE, binpositions = "all") +
      facet_wrap(~ dataset, ncol = 3) +
      scale_fill_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Predicted Probability Distributions",
           x = "Predicted probability of malignancy",
           y = "Count") +
      theme_minimal(base_size = 12)
  })
  
  output$metricsTable <- renderTable({
    m <- model()
    rbind(
      training = classification_metrics(y_train, predict_mlp(m, X_train)),
      internal = classification_metrics(y_internal, predict_mlp(m, X_internal)),
      external = classification_metrics(y_external, predict_mlp(m, X_external))
    )[, c("n", "auc", "brier", "log_loss", "sensitivity", "specificity")]
  }, striped = TRUE, hover = TRUE, width = "100%", rownames = TRUE)
  
  output$comparisonTable <- renderTable({
    m <- model()
    data.frame(
      Model = c("Logistic Regression", "KNN", "Neural Network"),
      `Internal AUC` = c(logistic_performance["internal_test", "auc"],
                         knn_results["internal", "auc"],
                         auc_rank(y_internal, predict_mlp(m, X_internal))),
      `External AUC` = c(logistic_performance["external_test", "auc"],
                         knn_results["external", "auc"],
                         auc_rank(y_external, predict_mlp(m, X_external))),
      check.names = FALSE
    )
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)

Try it yourself. 1. The overfitting dial. Set hidden units to 2, train, and note the training AUC. Now increase to 32. Training AUC should climb toward 1.0. Does test AUC improve? This is the capacity sweep made interactive. 2. The regularization dial. Set hidden units to 16 and weight decay to 0. Training AUC will be high. Now increase weight decay to 0.1. Training AUC drops, but does the generalization gap shrink? Regularization trades training performance for generalization. 3. The learning rate dial. Set $lr \to 0.001$. The loss decreases slowly. Set $lr \to 0.5$. The loss may oscillate or diverge. The learning rate controls the step size in gradient descent, too small is slow, too large is unstable. 4. The futility of tabular deep learning. Try every combination. Can you beat the logistic regression $AUC \approx 0.54$ on the internal test set? With 9 benign training cases, the answer is almost certainly no. This is why deep learning on tabular clinical data is rarely worth the complexity.

Training loss is not generalization performance. Early stopping should monitor a validation set nested inside training, not the final test set.

10.3 Convolution and translation-aware feature extraction

For 2D input $X$ and kernel $K$, a discrete convolutional feature map is

\[Y[i,j]=\sum_{u,v}K[u,v]X[i-u,j-v].\]

A convolutional neural network (CNN) learns kernels rather than prescribing them. Weight sharing reduces parameters and creates translation-equivariant feature extraction. Pooling, or striding, changes spatial resolution and padding changes boundary behavior.

Why convolution instead of fully-connected layers for images? A fully-connected layer on a 512×512 CT slice would require $512^2 = 262,144$ input weights per hidden unit. A 3×3 convolution requires only 9 weights, shared across all spatial locations. This gives CNNs two superpowers: 1. Translation equivariance: If a tumor shifts by 10 pixels, the convolution output shifts by 10 pixels, the feature detection is identical. A fully-connected layer would need to relearn the feature at every position. 2. Local receptive fields: Each neuron sees only a small neighborhood, matching the spatial locality of image features (edges, textures, blobs). These are inductive biases, assumptions built into the architecture. They make CNNs dramatically more sample-efficient than fully-connected networks on images.

## Convolution applied to a REAL image slice: the operation a CNN learns.
conv2d <- function(M, K) {
  kd <- dim(K); pad <- (kd - 1) %/% 2; d <- dim(M)
  out <- matrix(0, d[1], d[2])
  for (i in seq_len(kd[1])) for (j in seq_len(kd[2])) {
    ri <- pmin(pmax(seq_len(d[1]) + i - 1 - pad[1], 1), d[1])
    ci <- pmin(pmax(seq_len(d[2]) + j - 1 - pad[2], 1), d[2])
    out <- out + K[i, j] * M[ri, ci]
  }
  out
}

kernels <- list(
  "identity"      = matrix(c(0,0,0, 0,1,0, 0,0,0), 3, 3, byrow = TRUE),
  "box blur"      = matrix(1 / 9, 3, 3),
  "Sobel x"       = matrix(c(-1,0,1, -2,0,2, -1,0,1), 3, 3, byrow = TRUE),
  "Sobel y"       = matrix(c(-1,-2,-1, 0,0,0, 1,2,1), 3, 3, byrow = TRUE),
  "Laplacian"     = matrix(c(0,1,0, 1,-4,1, 0,1,0), 3, 3, byrow = TRUE)
)

target <- if (have_image) slice else
  (demo_scan2$slices[[as.character(keep_k[2])]] > 0) * 1

op <- par(mfrow = c(2, 3), mar = c(2, 2, 3, 1))
image(target, col = grey.colors(64), axes = FALSE, main = "Real input"); box()
for (nm in names(kernels)[-1]) {
  image(conv2d(target, kernels[[nm]]), col = grey.colors(64), axes = FALSE,
        main = nm); box()
}
## Gradient magnitude combines the two Sobel responses.
gx <- conv2d(target, kernels[["Sobel x"]]); gy <- conv2d(target, kernels[["Sobel y"]])
image(sqrt(gx^2 + gy^2), col = grey.colors(64), axes = FALSE,
      main = "gradient magnitude"); box()

par(op)

## A convolution layer is a linear operator: verify additivity numerically.
K <- kernels[["Sobel x"]]
lhs <- conv2d(target + 3 * target, K); rhs <- conv2d(target, K) + 3 * conv2d(target, K)
cat("max |conv(a+3a) - (conv(a)+3conv(a))| =", format(max(abs(lhs - rhs)), digits = 3), "\n")

## max |conv(a+3a) - (conv(a)+3conv(a))| = 0

Blur suppresses high spatial frequencies, Sobel kernels approximate directional derivatives, and the Laplacian responds to curvature. A convolutional network does not invent this vocabulary. It learns the kernel weights, replacing hand-designed filters with data-driven ones while keeping translation equivariance and local support.

Interactive Exploration: Convolution Kernel Laboratory

This app supports designing custom 3×3 kernels and exploring interactively their effects on a real CT slice. You can also select from preset kernels (edge detectors, blurs, emboss) and adjust the input image. A CNN’s first convolutional layer is learning exactly these kinds of filters, but from data, not from an oracle or a specific model.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Convolution Kernel Laboratory"),
  sidebarLayout(
    sidebarPanel(
      selectInput("preset", "Load preset kernel:",
                  choices = c("Custom", "Identity", "Box blur", "Gaussian blur",
                              "Sobel X", "Sobel Y", "Laplacian", "Sharpen", 
                              "Emboss", "Edge enhance")),
      hr(),
      h5("Custom 3×3 Kernel (row-major)"),
      fluidRow(
        column(4, numericInput("k11", "", 0, step = 0.5)),
        column(4, numericInput("k12", "", 0, step = 0.5)),
        column(4, numericInput("k13", "", 0, step = 0.5))
      ),
      fluidRow(
        column(4, numericInput("k21", "", 0, step = 0.5)),
        column(4, numericInput("k22", "", 1, step = 0.5)),
        column(4, numericInput("k23", "", 0, step = 0.5))
      ),
      fluidRow(
        column(4, numericInput("k31", "", 0, step = 0.5)),
        column(4, numericInput("k32", "", 0, step = 0.5)),
        column(4, numericInput("k33", "", 0, step = 0.5))
      ),
      checkboxInput("normalize", "Normalize output to [0, 1]", value = TRUE),
      checkboxInput("abs", "Take absolute value", value = FALSE),
      hr(),
      helpText("Design a kernel and observe its effect. 
               Sobel kernels detect edges (derivatives). 
               Blurs average neighbors (low-pass). 
               Laplacian detects regions of rapid intensity change (second derivative). 
               A CNN learns these filters from data.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Convolution Result", plotOutput("convPlot", height = "450px")),
        tabPanel("Kernel Visualization", plotOutput("kernelPlot", height = "300px")),
        tabPanel("What CNNs Learn", 
                 p("The first layer of a trained CNN typically learns filters that resemble:"),
                 tags$ul(
                   tags$li(strong("Edge detectors:"), " Similar to Sobel kernels"),
                   tags$li(strong("Color/texture blobs:"), " Similar to Gaussian/box blur"),
                   tags$li(strong("Corner detectors:"), " Combinations of edges in multiple directions"),
                   tags$li(strong("Frequency-selective filters:"), " Gabor-like patterns")
                 ),
                 p("The key difference: these filters are "),
                 strong("learned from the data"),
                 p(", not designed by a human. The CNN discovers which spatial patterns 
                   are most predictive for the task. In medical imaging, early CNN layers 
                   often learn to detect tissue boundaries, enhancing regions, and 
                   calcification patterns, the same patterns a radiologist looks for, 
                   but encoded as numerical weights."))
      )
    )
  )
)

server <- function(input, output, session) {
  
  # Update kernel inputs when preset is selected
  observeEvent(input$preset, {
    presets <- list(
      "Identity" = c(0,0,0, 0,1,0, 0,0,0),
      "Box blur" = rep(1/9, 9),
      "Gaussian blur" = c(1,2,1, 2,4,2, 1,2,1) / 16,
      "Sobel X" = c(-1,0,1, -2,0,2, -1,0,1),
      "Sobel Y" = c(-1,-2,-1, 0,0,0, 1,2,1),
      "Laplacian" = c(0,1,0, 1,-4,1, 0,1,0),
      "Sharpen" = c(0,-1,0, -1,5,-1, 0,-1,0),
      "Emboss" = c(-2,-1,0, -1,1,1, 0,1,2),
      "Edge enhance" = c(0,0,0, -1,1,0, 0,0,0)
    )
    
    if (input$preset != "Custom") {
      k <- presets[[input$preset]]
      updateNumericInput(session, "k11", value = k[1])
      updateNumericInput(session, "k12", value = k[2])
      updateNumericInput(session, "k13", value = k[3])
      updateNumericInput(session, "k21", value = k[4])
      updateNumericInput(session, "k22", value = k[5])
      updateNumericInput(session, "k23", value = k[6])
      updateNumericInput(session, "k31", value = k[7])
      updateNumericInput(session, "k32", value = k[8])
      updateNumericInput(session, "k33", value = k[9])
    }
  })
  
  kernel <- reactive({
    matrix(c(input$k11, input$k12, input$k13,
             input$k21, input$k22, input$k23,
             input$k31, input$k32, input$k33), 3, 3, byrow = TRUE)
  })
  
  conv_result <- reactive({
    K <- kernel()
    result <- conv2d(target, K)
    if (input$abs) result <- abs(result)
    if (input$normalize) {
      r <- range(result, na.rm = TRUE)
      if (r[2] > r[1]) result <- (result - r[1]) / (r[2] - r[1])
    }
    result
  })
  
  output$convPlot <- renderPlot({
    result <- conv_result()
    
    df <- data.frame(
      x = rep(1:nrow(target), ncol(target)),
      y = rep(1:ncol(target), each = nrow(target)),
      original = as.vector(target),
      filtered = as.vector(result)
    )
    
    p1 <- ggplot(df, aes(x = x, y = y, fill = original)) +
      geom_raster() +
      scale_fill_gradient(low = "black", high = "white") +
      coord_equal() +
      labs(title = "Original image", x = "", y = "") +
      theme_minimal(base_size = 11) +
      theme(axis.text = element_blank(), legend.position = "none",
            panel.grid = element_blank())
    
    p2 <- ggplot(df, aes(x = x, y = y, fill = filtered)) +
      geom_raster() +
      scale_fill_gradient(low = "black", high = "white") +
      coord_equal() +
      labs(title = "After convolution", x = "", y = "") +
      theme_minimal(base_size = 11) +
      theme(axis.text = element_blank(), legend.position = "none",
            panel.grid = element_blank())
    
    p1 + p2
  })
  
  output$kernelPlot <- renderPlot({
    K <- kernel()
    k_df <- data.frame(
      x = rep(1:3, 3),
      y = rep(1:3, each = 3),
      value = as.vector(K)
    )
    
    ggplot(k_df, aes(x = x, y = y, fill = value)) +
      geom_tile(color = "white", size = 2) +
      geom_text(aes(label = round(value, 2)), size = 6) +
      scale_fill_gradient2(low = "#2166ac", mid = "white", high = "#b2182b", 
                           midpoint = 0) +
      coord_equal() +
      labs(title = "Kernel weights",
           x = "", y = "") +
      theme_minimal(base_size = 13) +
      theme(axis.text = element_blank(), panel.grid = element_blank())
  })
}

shinyApp(ui, server)

Try it yourself. 1. Edge detection. Load the Sobel X preset. The result highlights vertical edges (intensity changes in the horizontal direction). Now try Sobel Y, it highlights horizontal edges. A CNN’s first layer typically learns both orientations. 2. Blur vs. sharpen. Load Box blur, the image becomes smoother (high frequencies suppressed). Load Sharpen, the image becomes crisper (high frequencies amplified). These are opposite operations, and CNNs learn both depending on what the task requires. 3. The zero-sum kernel. Design a kernel where all weights sum to zero (e.g., Laplacian). The result will be zero in flat regions and non-zero at edges. This is a “high-pass filter”, it removes the DC component and responds only to change. 4. Design your own. Try to design a kernel that detects the tumor boundary. What combination of weights highlights the transition from parenchyma to tumor? This is exactly the optimization problem a CNN solves, but with thousands of kernels simultaneously.

The convolution theorem from BPAD Chapter 1 explains why large convolutions can be accelerated in the Fourier domain. CNN training usually uses direct or specialized tensor operations because kernels are small and hardware is optimized for them.

Connection to Modern CNN Architectures

Component	Purpose	Evolution
Convolutional layer	Learn spatial features	3×3 kernels dominate (VGG, ResNet)
Pooling/striding	Reduce spatial resolution	Replaced by strided convolutions (StridedNet)
Batch normalization	Stabilize training	Replaced by layer norm in transformers
Skip connections	Enable deep networks (100+ layers)	ResNet (2015), DenseNet
Attention mechanisms	Weight spatial importance	SENet, CBAM → Vision Transformers
Data augmentation	Expand effective dataset size	Mixup, CutMix, RandAugment

The progression from a single 3×3 convolution to a 100-layer ResNet is not a change in principle, it is a scaling of the same idea, i.e., learn local spatial filters, stack them hierarchically, and let the network discover which patterns matter for the task. The mathematics of convolution, weight sharing, and gradient descent remain identical.

10.4 Receptive field and dimensionality choices

A unit’s receptive field is the input region that can affect it. Stacking convolutions increases receptive field. Dilated convolution expands it without proportional parameter growth.

The trade-off between receptive field and parameters. To classify a 512×512 CT slice, the final classification layer needs a global view of the image. If we only use 3×3 convolutions, each layer adds 2 pixels to the receptive field. To see the whole image (512 pixels) requires $\approx 256$ layers! CNNs solve this via downsampling (pooling/striding), which halves the spatial resolution and thus doubles the effective receptive field of subsequent layers. Dilation (inserting zeros into the kernel) is another tool, e.g., a 3×3 convolution with dilation rate 2 has a 5×5 receptive field but still only 9 parameters.

Medical-image architectures commonly use the following components.

Representation	Advantage	Limitation
2D slices	Efficient; can use pretrained 2D encoders	Loses through-plane context; slice labels may be weak
2.5D adjacent slices	Adds local context at moderate cost	Still incomplete 3D geometry
3D volume/patch	Represents volumetric anatomy	Memory intensive; fewer independent samples
Multi-view	Uses axial/coronal/sagittal views	Fusion and registration choices matter
Radiomics + network	Combines explicit and learned features	Can duplicate information and increase overfitting

Patch-level leakage. Patch sampling must be split by patient first. Otherwise patches from the same lesion can leak across partitions. If patient A’s tumor is split into 10 patches, and 8 go to training and 2 to testing, the model memorizes patient A’s specific acquisition noise and anatomy. The test set is no longer independent. Always split at the patient level before extracting patches.

Interactive Exploration: Receptive Field & Parameter Calculator

Test this app to design a simple stack of convolutional layers. Adjust the number of layers, kernel size, dilation rate, and downsampling (pooling). Observe how the receptive field grows to cover the input image, and how the parameter count explodes with depth.

library(shiny)
library(ggplot2)
library(dplyr)
library(tidyr)

ui <- fluidPage(
  titlePanel("Receptive Field & Parameter Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("n_layers", "Number of Conv Layers:",
                  min = 1, max = 8, value = 3, step = 1),
      sliderInput("kernel", "Kernel size (k):",
                  min = 3, max = 7, value = 3, step = 2),
      sliderInput("dilation", "Dilation rate (d):",
                  min = 1, max = 4, value = 1, step = 1),
      checkboxInput("pooling", "Add 2x2 Pooling after each layer", value = TRUE),
      sliderInput("filters", "Filters per layer:",
                  min = 8, max = 128, value = 32, step = 8),
      hr(),
      helpText("Observe: (1) Pooling rapidly accelerates receptive field growth. 
               (2) Dilation expands the view without adding parameters. 
               (3) Parameter count grows with filters squared.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Receptive Field Map", plotOutput("rfPlot", height = "400px")),
        tabPanel("Growth Curve", plotOutput("growthPlot", height = "400px")),
        tabPanel("Architecture Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  arch_data <- reactive({
    rf <- 1  # Start with 1x1 receptive field
    rf_history <- rf
    param_history <- 0
    spatial_size <- 128  # Assume 128x128 input
    
    # For parameter calculation: Conv params = (k * k * in_filters * out_filters) + out_filters
    # We assume input has 1 channel
    in_ch <- 1
    
    for (l in seq_len(input$n_layers)) {
      out_ch <- input$filters
      
      # Effective kernel size with dilation
      eff_k <- input$kernel + (input$kernel - 1) * (input$dilation - 1)
      
      # Receptive field growth: rf += (eff_k - 1) * (current stride multiplier)
      # If pooling occurred in previous layers, spatial stride increases
      # Simplified RF calculation: rf += eff_k - 1 (assuming stride 1)
      # If pooling, rf doubles effectively in original image space
      if (l > 1 && input$pooling) {
        # Pooling halves resolution, so RF in original image space doubles
        rf <- rf * 2
        spatial_size <- spatial_size / 2
      }
      rf <- rf + (eff_k - 1)
      
      # Parameters for this layer
      params <- (input$kernel * input$kernel * in_ch * out_ch) + out_ch
      param_history <- param_history + params
      
      rf_history <- c(rf_history, rf)
      in_ch <- out_ch
    }
    
    list(
      rf = rf_history,
      params = param_history,
      n_layers = input$n_layers,
      final_rf = rf,
      final_spatial = spatial_size
    )
  })
  
  output$rfPlot <- renderPlot({
    d <- arch_data()
    
    # Create a grid showing the receptive field over a 128x128 image
    grid_size <- 128
    center <- grid_size / 2
    
    # The RF is a square centered at `center`
    rf_half <- floor(d$final_rf / 2)
    
 df <- data.frame(
      x = rep(1:grid_size, grid_size),
      y = rep(1:grid_size, each=grid_size),
      in_rf = FALSE
    )
    df$in_rf <- abs(df$x - center) <= rf_half & abs(df$y - center) <= rf_half
    
    ggplot(df, aes(x = x, y = y, fill = in_rf)) +
      geom_raster() +
      scale_fill_manual(values = c("TRUE" = "#2166ac", "FALSE" = "grey90")) +
      coord_equal() +
      labs(title = sprintf("Final Receptive Field: %dx%d pixels", d$final_rf, d$final_rf),
           subtitle = sprintf("Center pixel's view of a 128x128 input after %d layers", d$n_layers),
           x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), panel.grid = element_blank(),
            legend.position = "none")
  })
  
  output$growthPlot <- renderPlot({
    d <- arch_data()
    df <- data.frame(
      layer = 0:d$n_layers,
      receptive_field = d$rf
    )
    
    ggplot(df, aes(x = layer, y = receptive_field)) +
      geom_line(color = "#2166ac", size = 1.2) +
      geom_point(size = 3, color = "#2166ac") +
      geom_hline(yintercept = 128, lty = 2, color = "red") +
      annotate("text", x = 1, y = 132, label = "Full image (128 px)", color = "red", size=4) +
      labs(title = "Receptive Field Growth vs Depth",
           subtitle = "Pooling causes exponential growth; pure convolution is linear",
           x = "Layer number", y = "Receptive field size (pixels)") +
      theme_minimal(base_size = 13)
  })
  
  output$summary <- renderPrint({
    d <- arch_data()
    cat("--- Architecture Summary ---\n")
    cat("Input size: 128 x 128 x 1\n")
    cat("Layers:", d$n_layers, "\n")
    cat("Kernel:", input$kernel, "x", input$kernel, "\n")
    cat("Dilation rate:", input$dilation, "\n")
    cat("Pooling:", ifelse(input$pooling, "Yes (2x2)", "No"), "\n")
    cat("Filters per layer:", input$filters, "\n\n")
    
    cat("Final spatial resolution:", d$final_spatial, "x", d$final_spatial, "\n")
    cat("Final receptive field:", d$final_rf, "x", d$final_rf, "pixels\n")
    cat("Total conv parameters:", format(d$params, big.mark = ","), "\n\n")
    
    if (d$final_rf < 128) {
      cat("⚠️  Receptive field does not cover the full input.\n")
      cat("The final layer cannot 'see' the whole image at once.\n")
    } else {
      cat("✓ Receptive field covers the input. Global context is available.\n")
    }
    
    if (d$params > 1000000) {
      cat("⚠️  High parameter count (>1M). Risk of overfitting on small datasets.\n")
    }
  })
}

shinyApp(ui, server)

10.5 CNNs for classification

A classification CNN typically alternates convolution, normalization, nonlinear activation, and downsampling before a final probabilistic classification. For class probabilities $p_k$ and one-hot target $y_k$, the categorical cross-entropy measure is

\[L=-\sum_{k=1}^K y_k\log p_k.\]

Class weights, focal loss, or balanced batches may help optimization under imbalance, but test evaluation should preserve target prevalence.

Anatomy of the Classification Skeleton

The Keras 3 skeleton below maps a 128×128 CT slice down to a single malignancy probability. The Mermaid diagram shows the tensor shapes at each step.

library(DiagrammeR)

grViz("
digraph classification_skeleton {
  # Graph setup
  graph [layout = dot, rankdir = LR, compound = true, nodesep = 0.4, ranksep = 0.6]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # Nodes with respective styles and labels
  A [label = 'Input\\n128x128x1', fillcolor = '#e1f5fe']
  B [label = 'Conv2D 16 filters\\n3x3, ReLU']
  C [label = 'MaxPool 2x2\\n64x64x16']
  D [label = 'Conv2D 32 filters\\n3x3, ReLU']
  E [label = 'MaxPool 2x2\\n32x32x32']
  F [label = 'Conv2D 64 filters\\n3x3, ReLU']
  G [label = 'Global Average Pool\\n1D Vector 64', fillcolor = '#fff3e0']
  H [label = 'Dropout 30%']
  I [label = 'Dense 1\\nSigmoid', fillcolor = '#e8f5e9', style = 'filled,bold']

  # Edges
  A -> B -> C -> D -> E -> F -> G -> H -> I
}
")

Below is an optional Keras code-chunk skeleton, which is intentionally small and non-executed (eval=FALSE). A real study would use a separate data loader, augmentation pipeline, validation callbacks, and locked test set. More extensive DNN examples are shown in DSPA Chapter 14.

library(keras3)

inputs <- keras_input(shape = c(128, 128, 1), name = "ct_slice")
outputs <- inputs |>
  layer_conv_2d(filters = 16, kernel_size = 3, padding = "same",
                activation = "relu") |>
  layer_max_pooling_2d(pool_size = 2) |>
  layer_conv_2d(filters = 32, kernel_size = 3, padding = "same",
                activation = "relu") |>
  layer_max_pooling_2d(pool_size = 2) |>
  layer_conv_2d(filters = 64, kernel_size = 3, padding = "same",
                activation = "relu") |>
  layer_global_average_pooling_2d() |>
  layer_dropout(rate = 0.30) |>
  layer_dense(units = 1, activation = "sigmoid")

ct_classifier <- keras_model(inputs = inputs, outputs = outputs)
ct_classifier |> compile(
  optimizer = optimizer_adam(learning_rate = 1e-3),
  loss = "binary_crossentropy",
  metrics = list(metric_auc(name = "auc"), metric_binary_accuracy())
)
summary(ct_classifier)

library(knitr)

model_summary <- data.frame(
  Layer = c(
    "ct_slice (InputLayer)",
    "conv2d (Conv2D)",
    "max_pooling2d (MaxPooling2D)",
    "conv2d_1 (Conv2D)",
    "max_pooling2d_1 (MaxPooling2D)",
    "conv2d_2 (Conv2D)",
    "global_average_pooling2d (GlobalAveragePooling2D)",
    "dropout (Dropout)",
    "dense (Dense)"
  ),
  Output_Shape = c(
    "(None, 128, 128, 1)",
    "(None, 128, 128, 16)",
    "(None, 64, 64, 16)",
    "(None, 64, 64, 32)",
    "(None, 32, 32, 32)",
    "(None, 32, 32, 64)",
    "(None, 64)",
    "(None, 64)",
    "(None, 1)"
  ),
  Param = c("0", "160", "0", "4,640", "0", "18,496", "0", "0", "65"),
  stringsAsFactors = FALSE
)

kable(model_summary, 
      caption = "Model: functional\\_1",
      align = c("l", "c", "r"),
      booktabs = TRUE)

Table 2: Model: functional_1
Layer	Output_Shape	Param
ct_slice (InputLayer)	(None, 128, 128, 1)	0
conv2d (Conv2D)	(None, 128, 128, 16)	160
max_pooling2d (MaxPooling2D)	(None, 64, 64, 16)	0
conv2d_1 (Conv2D)	(None, 64, 64, 32)	4,640
max_pooling2d_1 (MaxPooling2D)	(None, 32, 32, 32)	0
conv2d_2 (Conv2D)	(None, 32, 32, 64)	18,496
global_average_pooling2d (GlobalAveragePooling2D)	(None, 64)	0
dropout (Dropout)	(None, 64)	0
dense (Dense)	(None, 1)	65

# After the table:
cat("\n**Total params:** 23,361 (91.25 KB)  \n")

## 
## **Total params:** 23,361 (91.25 KB)

cat("**Trainable params:** 23,361 (91.25 KB)  \n")

## **Trainable params:** 23,361 (91.25 KB)

cat("**Non‑trainable params:** 0 (0.00 B)\n")

## **Non‑trainable params:** 0 (0.00 B)

Why Global Average Pooling instead of Flatten? Older architectures, like VGG, flattened the final feature map, e.g., 32×32×64 = 65,536 values, and passed it to a Dense layer, resulting in millions of parameters. Global Average Pooling averages each 32×32 feature map to a single number, yielding a 64-length vector.

This drastically reduces parameters and forces the network to learn where a feature is (the convolutional maps) rather than memorizing exact spatial configurations, improving generalization.

10.6 Encoder-decoder networks and U-Net segmentation

U-Net combines a contracting encoder with an expanding decoder and skip connections that restore fine spatial detail. For soft prediction $p_i \in [0,1]$ and binary reference $g_i$, soft Dice is

\[\mathrm{Dice}_{\mathrm{soft}} =\frac{2\sum_i p_ig_i+\epsilon} {\sum_i p_i+\sum_i g_i+\epsilon}.\]

Dice loss is $1-\mathrm{Dice}_{\mathrm{soft}}$. Combining Dice and cross-entropy can balance overlap and voxel-wise calibration.

The U-Net Architecture

library(DiagrammeR)

grViz("
digraph unet {

  # Global settings
  graph [layout = dot, rankdir = TB, newrank = true,
         compound = true, nodesep = 0.3, ranksep = 0.5]
  node [shape = rectangle, style = filled, fontname = Helvetica, fontsize = 10]
  edge [fontname = Helvetica, fontsize = 8]

  # Invisible edges to enforce vertical order inside columns
  edge [style = invis]

  # ---- Encoder column (left) ----
  subgraph cluster_encoder {
    label = 'Encoder'; fontname = Helvetica; fontsize = 12
    style = dashed; color = '#1976D2'
    enc_in [label = 'Input\\n128×128×1', fillcolor = '#E3F2FD']
    enc_conv1 [label = 'Conv3×3+ReLU\\n(×2)\\n128×128×16', fillcolor = '#BBDEFB']
    enc_pool1 [label = 'MaxPool 2×2\\n64×64×16']
    enc_conv2 [label = 'Conv3×3+ReLU\\n(×2)\\n64×64×32', fillcolor = '#90CAF9']
    enc_pool2 [label = 'MaxPool 2×2\\n32×32×32']
    enc_bn [label = 'Bottleneck\\nConv3×3+ReLU\\n(×2)\\n32×32×64', fillcolor = '#FFE0B2',
             shape = 'ellipse']

    enc_in -> enc_conv1 -> enc_pool1 -> enc_conv2 -> enc_pool2 -> enc_bn
  }

  # ---- Decoder column (right) ----
  subgraph cluster_decoder {
    label = 'Decoder'; fontname = Helvetica; fontsize = 12
    style = dashed; color = '#388E3C'
    dec_up1 [label = 'UpConv 2×2\\n64×64×32']
    dec_concat1 [label = 'Concat\\n64×64×64', fillcolor = '#FFF9C4']
    dec_conv1 [label = 'Conv3×3+ReLU\\n(×2)\\n64×64×32', fillcolor = '#C8E6C9']
    dec_up2 [label = 'UpConv 2×2\\n128×128×16']
    dec_concat2 [label = 'Concat\\n128×128×32', fillcolor = '#FFF9C4']
    dec_conv2 [label = 'Conv3×3+ReLU\\n(×2)\\n128×128×16', fillcolor = '#A5D6A7']
    dec_out [label = 'Conv1×1+Sigmoid\\n128×128×1', fillcolor = '#66BB6A']

    dec_up1 -> dec_concat1 -> dec_conv1 -> dec_up2 -> dec_concat2 -> dec_conv2 -> dec_out
  }

  # ---- Force the decoder to sit to the right of the encoder ----
  # Connect the two subgraphs with an invisible edge to keep them side by side
  enc_bn -> dec_up1 [style = invis, minlen = 3]

  # ---- Horizontal alignment of corresponding resolution levels ----
  # Each rank group ensures that encoder and decoder nodes at the same spatial
  # resolution appear on the same row.
  { rank = same; enc_conv1; dec_conv2; dec_out }
  { rank = same; enc_pool1; dec_up2; dec_concat2 }
  { rank = same; enc_conv2; dec_conv1; dec_concat1 }
  { rank = same; enc_pool2; dec_up1 }

  # ---- Real skip connections (dashed) ----
  edge [style = dashed, color = '#F57C00', penwidth = 1.5, constraint = false]
  enc_conv1 -> dec_concat2 [label = 'Skip 1', tailport = 'e', headport = 'w']
  enc_conv2 -> dec_concat1 [label = 'Skip 2', tailport = 'e', headport = 'w']
}
")

The skip connections (dashed lines) pass the high-resolution spatial details from the encoder directly into the decoder. This allows the decoder to draw precise boundaries, while the bottleneck learns the semantic context, e.g., “this region is a tumor”.

The example R code chunk below illustrates the design of another (improved) Keras model, functional_3, which is again not run here.

library(knitr)

# Create the summary data frame
model3 <- data.frame(
  Layer = c(
    "input_layer (InputLayer)",
    "conv2d_3 (Conv2D)",
    "conv2d_4 (Conv2D)",
    "max_pooling2d_2 (MaxPooling2D)",
    "conv2d_5 (Conv2D)",
    "conv2d_6 (Conv2D)",
    "max_pooling2d_3 (MaxPooling2D)",
    "conv2d_7 (Conv2D)",
    "conv2d_8 (Conv2D)",
    "conv2d_transpose (Conv2DTranspose)",
    "concatenate (Concatenate)",
    "conv2d_9 (Conv2D)",
    "conv2d_10 (Conv2D)",
    "conv2d_transpose_1 (Conv2DTranspose)",
    "concatenate_1 (Concatenate)",
    "conv2d_11 (Conv2D)",
    "conv2d_12 (Conv2D)",
    "conv2d_13 (Conv2D)"
  ),
  Output_Shape = c(
    "(None, 128, 128, 1)",
    "(None, 128, 128, 16)",
    "(None, 128, 128, 16)",
    "(None, 64, 64, 16)",
    "(None, 64, 64, 32)",
    "(None, 64, 64, 32)",
    "(None, 32, 32, 32)",
    "(None, 32, 32, 64)",
    "(None, 32, 32, 64)",
    "(None, 64, 64, 32)",
    "(None, 64, 64, 64)",
    "(None, 64, 64, 32)",
    "(None, 64, 64, 32)",
    "(None, 128, 128, 16)",
    "(None, 128, 128, 32)",
    "(None, 128, 128, 16)",
    "(None, 128, 128, 16)",
    "(None, 128, 128, 1)"
  ),
  Param = c(
    "0",
    "160",
    "2,320",
    "0",
    "4,640",
    "9,248",
    "0",
    "18,496",
    "36,928",
    "8,224",
    "0",
    "18,464",
    "9,248",
    "2,064",
    "0",
    "4,624",
    "2,320",
    "17"
  ),
  Connected_to = c(
    "-",
    "input_layer[0][0]",
    "conv2d_3[0][0]",
    "conv2d_4[0][0]",
    "max_pooling2d_2[0][0]",
    "conv2d_5[0][0]",
    "conv2d_6[0][0]",
    "max_pooling2d_3[0][0]",
    "conv2d_7[0][0]",
    "conv2d_8[0][0]",
    "conv2d_transpose[0][0], conv2d_6[0][0]",
    "concatenate[0][0]",
    "conv2d_9[0][0]",
    "conv2d_10[0][0]",
    "conv2d_transpose_1[0][0], conv2d_4[0][0]",
    "concatenate_1[0][0]",
    "conv2d_11[0][0]",
    "conv2d_12[0][0]"
  ),
  stringsAsFactors = FALSE
)

# Render the table
kable(model3,
      caption = "Model: functional\\_3",
      align = c("l", "c", "r", "l"),
      booktabs = TRUE)

Table 3: Model: functional_3
Layer	Output_Shape	Param	Connected_to
input_layer (InputLayer)	(None, 128, 128, 1)	0	-
conv2d_3 (Conv2D)	(None, 128, 128, 16)	160	input_layer[0][0]
conv2d_4 (Conv2D)	(None, 128, 128, 16)	2,320	conv2d_3[0][0]
max_pooling2d_2 (MaxPooling2D)	(None, 64, 64, 16)	0	conv2d_4[0][0]
conv2d_5 (Conv2D)	(None, 64, 64, 32)	4,640	max_pooling2d_2[0][0]
conv2d_6 (Conv2D)	(None, 64, 64, 32)	9,248	conv2d_5[0][0]
max_pooling2d_3 (MaxPooling2D)	(None, 32, 32, 32)	0	conv2d_6[0][0]
conv2d_7 (Conv2D)	(None, 32, 32, 64)	18,496	max_pooling2d_3[0][0]
conv2d_8 (Conv2D)	(None, 32, 32, 64)	36,928	conv2d_7[0][0]
conv2d_transpose (Conv2DTranspose)	(None, 64, 64, 32)	8,224	conv2d_8[0][0]
concatenate (Concatenate)	(None, 64, 64, 64)	0	conv2d_transpose[0][0], conv2d_6[0][0]
conv2d_9 (Conv2D)	(None, 64, 64, 32)	18,464	concatenate[0][0]
conv2d_10 (Conv2D)	(None, 64, 64, 32)	9,248	conv2d_9[0][0]
conv2d_transpose_1 (Conv2DTranspose)	(None, 128, 128, 16)	2,064	conv2d_10[0][0]
concatenate_1 (Concatenate)	(None, 128, 128, 32)	0	conv2d_transpose_1[0][0], conv2d_4[0][0]
conv2d_11 (Conv2D)	(None, 128, 128, 16)	4,624	concatenate_1[0][0]
conv2d_12 (Conv2D)	(None, 128, 128, 16)	2,320	conv2d_11[0][0]
conv2d_13 (Conv2D)	(None, 128, 128, 1)	17	conv2d_12[0][0]

# After the table:
cat("\n**Total params:** 116,753 (456.07 KB) \n")

## 
## **Total params:** 116,753 (456.07 KB)

cat("\n**Trainable params**: 116,753 (456.07 KB) \n")

## 
## **Trainable params**: 116,753 (456.07 KB)

cat("\n**Non-trainable params**: 0 (0.00 B) \n")

## 
## **Non-trainable params**: 0 (0.00 B)

library(keras3)

conv_block <- function(x, filters) {
  x |>
    layer_conv_2d(filters, 3, padding = "same", activation = "relu") |>
    layer_conv_2d(filters, 3, padding = "same", activation = "relu")
}

unet_inputs <- keras_input(shape = c(128, 128, 1))
c1 <- conv_block(unet_inputs, 16)
p1 <- c1 |> layer_max_pooling_2d(pool_size = 2)
c2 <- conv_block(p1, 32)
p2 <- c2 |> layer_max_pooling_2d(pool_size = 2)
bottleneck <- conv_block(p2, 64)

u2 <- bottleneck |>
  layer_conv_2d_transpose(filters = 32, kernel_size = 2, strides = 2)
u2 <- layer_concatenate(list(u2, c2))
c3 <- conv_block(u2, 32)
u1 <- c3 |>
  layer_conv_2d_transpose(filters = 16, kernel_size = 2, strides = 2)
u1 <- layer_concatenate(list(u1, c1))
c4 <- conv_block(u1, 16)
unet_outputs <- c4 |> layer_conv_2d(filters = 1, kernel_size = 1,
                                    activation = "sigmoid")

unet_model <- keras_model(unet_inputs, unet_outputs)
soft_dice_loss <- function(y_true, y_pred) {
  epsilon <- 1e-6
  intersection <- op_sum(y_true * y_pred, axis = c(1, 2, 3))
  denominator <- op_sum(y_true, axis = c(1, 2, 3)) +
    op_sum(y_pred, axis = c(1, 2, 3))
  op_mean(1 - (2 * intersection + epsilon) / (denominator + epsilon))
}
unet_model |> compile(optimizer = optimizer_adam(), loss = soft_dice_loss)

Why not just use Cross-Entropy for segmentation? In medical imaging, the background often dominates the image, e.g., a 5mm tumor in a 512×512 slice $99\%$ background. A standard cross-entropy (CE) loss will be satisfied if the model predicts background everywhere, achieving $99\%$ accuracy but $0\%$ sensitivity. Dice loss, and its variants like Tversky loss, are region-based overlap metrics. They directly optimize the intersection over union, making them robust to severe class imbalance. Combining CE and Dice is a common best-of-both-worlds approach.

U-Net performance depends strongly on preprocessing, patch sampling, loss, augmentation, postprocessing, and annotation conventions. Architecture names alone do not define a reproducible model.

10.7 Data augmentation as a model of plausible variability

An augmentation $T$ should preserve the label while representing plausible variation

\[(I,Y)\mapsto(TI,Y).\]

Potential transformations include small rotations, translations, elastic deformation, intensity scaling, blur, noise, and simulated resolution changes. Their validity is modality and anatomy specific.

Medical imaging augmentations can destroy labels. In natural images (ImageNet), a horizontal flip of a cat is still a cat. In medical imaging:

Laterality: Flipping a left kidney makes it look like a right kidney. If laterality is a surgical input, you have corrupted the label.
Acquisition physics: CT intensities are quantitative (Hounsfield Units). Random brightness shifts can turn soft tissue into bone or air.
Pathology: Aggressive elastic deformation can tear a subtle tumor boundary, making an annotation mask invalid. Augmentation is a model of plausible variability. If your augmentation model is wrong, your neural network will learn a hallucinated reality.

Augmentation is applied only to training data. Validation and test images undergo the deterministic deployment pipeline.

Interactive Exploration: Augmentation Laboratory

The app below applies common augmentations to a real CT slice. Adjust the parameters and observe the effect. Would a radiologist still trust the diagnosis on this transformed image?

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Medical Image Augmentation Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("rotation", "Rotation (degrees):",
                  min = -45, max = 45, value = 0, step = 5),
      sliderInput("translation", "Translation (pixels, both axes):",
                  min = -20, max = 20, value = 0, step = 2),
      sliderInput("scale", "Scale factor:",
                  min = 0.8, max = 1.2, value = 1.0, step = 0.05),
      sliderInput("noise", "Gaussian noise (SD):",
                  min = 0, max = 50, value = 0, step = 5),
      sliderInput("brightness", "Intensity shift (HU):",
                  min = -100, max = 100, value = 0, step = 10),
      checkboxInput("flip_h", "Horizontal Flip (DANGEROUS)", value = FALSE),
      hr(),
      helpText("Observe: Flipping changes anatomy. Large rotations introduce 
               zero-padded regions. Large intensity shifts push tissue into 
               bone/air HU ranges. Translation simulates patient motion.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Augmented Image", plotOutput("augPlot", height = "500px")),
        tabPanel("Intensity Histogram", plotOutput("histPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {

  # Ensure the real slice exists (from Section 5.8 or earlier)
  req(have_image, exists("slice"))
  
  aug_img <- reactive({
    img <- slice
    d <- dim(img)
    
    # ---- 1. Horizontal flip ----
    if (input$flip_h) {
      img <- img[, ncol(img):1]
    }
    
    # ---- 2. Rotation (affine, centre, zero-pad) ----
    if (input$rotation != 0) {
      rad <- input$rotation * pi / 180
      cx <- d[1] / 2; cy <- d[2] / 2
      coords <- expand.grid(x = 1:d[1], y = 1:d[2])
      
      # Inverse mapping: source = R⁻¹ (output – centre) + centre
      x_new <-  (coords$x - cx) * cos(rad) + (coords$y - cy) * sin(rad) + cx
      y_new <- -(coords$x - cx) * sin(rad) + (coords$y - cy) * cos(rad) + cy
      
      x_int <- round(x_new)
      y_int <- round(y_new)
      
      valid <- x_int >= 1 & x_int <= d[1] & y_int >= 1 & y_int <= d[2]
      
      out <- matrix(0, d[1], d[2])
      out[valid] <- img[cbind(x_int[valid], y_int[valid])]
      img <- out
    }
    
    # ---- 3. Scale (affine, centre, zero-pad) ----
    if (input$scale != 1.0) {
      s <- input$scale
      cx <- d[1] / 2; cy <- d[2] / 2
      coords <- expand.grid(x = 1:d[1], y = 1:d[2])
      
      # Inverse mapping: source = (output – centre) / s + centre
      x_new <- (coords$x - cx) / s + cx
      y_new <- (coords$y - cy) / s + cy
      
      x_int <- round(x_new)
      y_int <- round(y_new)
      
      valid <- x_int >= 1 & x_int <= d[1] & y_int >= 1 & y_int <= d[2]
      
      out <- matrix(0, d[1], d[2])
      out[valid] <- img[cbind(x_int[valid], y_int[valid])]
      img <- out
    }
    
    # ---- 4. Translation (both axes, zero-pad) ----
    if (input$translation != 0) {
      t <- input$translation
      coords <- expand.grid(x = 1:d[1], y = 1:d[2])
      src_x <- coords$x - t
      src_y <- coords$y - t
      
      valid <- src_x >= 1 & src_x <= d[1] & src_y >= 1 & src_y <= d[2]
      
      out <- matrix(0, d[1], d[2])
      out[valid] <- img[cbind(src_x[valid], src_y[valid])]
      img <- out
    }
    
    # ---- 5. Brightness shift ----
    img <- img + input$brightness
    
    # ---- 6. Gaussian noise ----
    if (input$noise > 0) {
      img <- img + matrix(rnorm(length(img), mean = 0, sd = input$noise),
                          nrow(img), ncol(img))
    }
    
    img
  })
  
  output$augPlot <- renderPlot({
    img <- aug_img()
    df <- data.frame(
      x = rep(1:nrow(img), ncol(img)),
      y = rep(1:ncol(img), each = nrow(img)),
      value = as.vector(img)
    )
    
    ggplot(df, aes(x = x, y = y, fill = value)) +
      geom_raster() +
      scale_fill_gradient(low = "black", high = "white", name = "HU") +
      coord_equal() +
      labs(title = "Augmented CT Slice",
           subtitle = sprintf("Rot=%d° | Trans=%d px | Scale=%.2f | Noise=%d | Shift=%d | Flip=%s",
                              input$rotation, input$translation, input$scale, 
                              input$noise, input$brightness, input$flip_h),
           x = "", y = "") +
      theme_minimal(base_size = 12) +
      theme(axis.text = element_blank(), panel.grid = element_blank())
  })
  
  output$histPlot <- renderPlot({
    img <- aug_img()
    df <- data.frame(HU = as.vector(img))
    
    ggplot(df, aes(x = HU)) +
      geom_histogram(bins = 60, fill = "grey70", color = "white") +
      geom_vline(xintercept = -1000, color = "blue", lty = 2) + # Air
      geom_vline(xintercept = 0, color = "green", lty = 2) +    # Water
      geom_vline(xintercept = 1000, color = "red", lty = 2) +   # Bone
      annotate("text", x = -1000, y = Inf, vjust = 1.5, label = "Air", color = "blue") +
      annotate("text", x = 0, y = Inf, vjust = 1.5, label = "Water", color = "green") +
      annotate("text", x = 1000, y = Inf, vjust = 1.5, label = "Bone", color = "red") +
      labs(title = "Intensity Histogram",
           subtitle = "Dashed lines = physiological HU boundaries",
           x = "Hounsfield Units (HU)", y = "Count") +
      theme_minimal(base_size = 12)
  })
}

shinyApp(ui, server)

10.8 Transfer learning, self-supervision, and foundation models

Transfer learning initializes an encoder using a source task. It is most useful when source representations transfer to the target modality and task. Natural-image pretraining can help 2D medical imaging, but differences in texture, channels, resolution, and semantics limit direct analogy.

Self-supervised learning constructs a pretext objective from unlabeled images. In contrastive learning, representations $z_i$ and $z_i^+$ of related views are pulled together while other cases act as negatives. A common objective is

\[L_i=-\log \frac{\exp\{\operatorname{sim}(z_i,z_i^+)/\tau\}} {\sum_{j}\exp\{\operatorname{sim}(z_i,z_j)/\tau\}},\]

where $\tau$ is temperature. Positive-pair construction must preserve the clinical signal. An augmentation that removes a small lesion defeats the objective.

The Self-Supervised Pretraining Workflow

library(DiagrammeR)

grViz("
digraph self_supervised_workflow {
  # Graph setup
  graph [layout = dot, rankdir = TD, compound = true, nodesep = 0.4, ranksep = 0.6]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # Subgraph Phase 1
  subgraph cluster_phase1 {
    label = 'Phase 1: Self-Supervised Pretraining (No Labels)'
    fontname = Helvetica
    fontsize = 12
    style = dashed
    
    A [label = 'Unlabeled CT Scans', fillcolor = '#e1f5fe']
    B [label = 'Create Augmented Pairs']
    C [label = 'Contrastive Encoder']
    D [label = 'Learn Representations', fillcolor = '#fff3e0']
  }

  # Subgraph Phase 2
  subgraph cluster_phase2 {
    label = 'Phase 2: Supervised Fine-tuning (Few Labels)'
    fontname = Helvetica
    fontsize = 12
    style = dashed
    
    E [label = 'Initialize Encoder Weights']
    F [label = 'Add Classification Head']
    G [label = 'Train on Labeled Data', fillcolor = '#e8f5e9']
  }

  # Edges
  A -> B -> C -> D
  D -> E -> F -> G
}
")

Large medical foundation models can provide encoders, segment-anything interfaces, or report-image embeddings. Their use still requires release-specific documentation, licensing review, local calibration, subgroup analysis, and external validation. Pretraining data overlap with test data must be investigated.

10.9 Attention and vision transformers

The scaled dot-product attention operator is

\[\operatorname{Attention}(Q,K,V)= \operatorname{softmax}\left(\frac{QK^\top}{\sqrt{d_k}}\right)V.\]

Vision transformers divide an image into tokens and model long-range interactions. Hybrid CNN-transformer architectures can combine local inductive bias with global context.

Attention weights are not explanations. It is tempting to visualize attention weights as a “saliency map” showing where the network looked to make its decision. This is misleading. Attention weights are a computational routing mechanism, not a causal explanation. A network can attend strongly to a region and still base its final prediction on a shortcut feature elsewhere. Use explainability methods (e.g., Grad-CAM, SHAP) with extreme caution, and always validate them against known anatomy.

10.10 Weak, noisy, and multiple-instance labels

Image-level labels often supervise only part of an image. In multiple-instance learning (MIL), a patient or slide is a bag of patches $\{x_{ij}\}$ with one bag label $Y_i$. An attention or pooling function aggregates instance representations:

\[z_i=\sum_j a_{ij}h(x_{ij}), \qquad \sum_j a_{ij}=1.\]

Anatomy of Multiple-Instance Learning

library(DiagrammeR)

grViz("
digraph mil_anatomy {
  # Graph setup
  graph [layout = dot, rankdir = TD, compound = true, nodesep = 0.4, ranksep = 0.6]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # Nodes
  A [label = 'Whole Slide / Volume', fillcolor = '#e1f5fe']
  B [label = 'Split into Patches / Instances']
  C [label = 'Patch 1']
  D [label = 'Patch 2']
  E [label = 'Patch N']
  F [label = 'Feature Extractor h', fillcolor = '#fff3e0']
  G [label = 'Attention Pooling', fillcolor = '#f3e5f5']
  H [label = 'Bag Label Prediction\\ne.g., Malignant', fillcolor = '#e8f5e9']

  # Edges
  A -> B
  B -> C
  B -> D
  B -> E
  C -> F
  D -> F
  E -> F
  F -> G
  G -> H
}
")

This is useful for pathology slides and whole-volume classification, but localization inferred from bag supervision should be validated separately. The attention weights, $a_{ij}$, can suggest which patches drove the decision, but they are not pixel-level segmentations.

Noisy-label strategies include adjudication subsets, probabilistic labels, robust loss functions, co-teaching, and explicit annotator models. None replaces careful reference-standard design.

10.11 Multimodal fusion

Let $z_I$ be an image representation, $z_C$ clinical features, and $z_G$ genomic features. Fusion strategies include:

early fusion: concatenate normalized inputs;
intermediate fusion: combine learned modality embeddings;
late fusion: combine modality-specific predictions;
gated fusion: learn reliability weights conditional on availability or quality.

A simple intermediate model is

\[\widehat y=f_{\theta}([z_I,z_C,z_G]).\]

Fusion Architectures

library(DiagrammeR)

grViz("
digraph fusion_architectures {
  # Graph setup
  graph [layout = dot, rankdir = LR, compound = true, nodesep = 0.4, ranksep = 0.6]

  # Global node styles
  node [shape = rectangle, fontname = Helvetica, fontsize = 10, style = filled, fillcolor = White]
  edge [fontname = Helvetica, fontsize = 9]

  # Subgraph Early Fusion
  subgraph cluster_early {
    label = 'Early Fusion'
    fontname = Helvetica
    fontsize = 12
    style = dashed
    
    I1 [label = 'Image']
    C1 [label = 'Clinical']
    E1 [label = 'Features']
    M1 [label = 'Classifier']
    
    I1 -> E1
    C1 -> E1
    E1 -> M1
  }

  # Subgraph Intermediate Fusion
  subgraph cluster_intermediate {
    label = 'Intermediate Fusion'
    fontname = Helvetica
    fontsize = 12
    style = dashed
    
    I2 [label = 'Image']
    C2 [label = 'Clinical']
    E2 [label = 'CNN']
    E3 [label = 'MLP']
    M2 [label = 'Concat/Attention']
    M3 [label = 'Classifier']
    
    I2 -> E2
    C2 -> E3
    E2 -> M2
    E3 -> M2
    M2 -> M3
  }

  # Subgraph Late Fusion
  subgraph cluster_late {
    label = 'Late Fusion'
    fontname = Helvetica
    fontsize = 12
    style = dashed
    
    I3 [label = 'Image']
    C3 [label = 'Clinical']
    E4 [label = 'CNN']
    E5 [label = 'MLP']
    P1 [label = 'Prob 1']
    P2 [label = 'Prob 2']
    M4 [label = 'Voting/Avg']
    
    I3 -> E4 -> P1
    C3 -> E5 -> P2
    P1 -> M4
    P2 -> M4
  }
}
")

Missing modalities require explicit design. Complete-case training can select an unrepresentative subgroup. Alternatives include modality dropout, missingness-aware encoders, and separate fallback models, but all deployment states need evaluation.

Interactive Exploration: The Incremental Value Test

For the kidney case, a radiomics-clinical model can be compared with image-only and clinical-only models. The incremental value of CT features should be quantified relative to a strong clinical baseline rather than against no model. The next app uses the predictions from Chapter 7 to visually perform this comparison.

library(shiny)
library(ggplot2)
library(pROC)

# Ensure model_scores exist
if (!exists("model_scores")) {
  model_scores <- list(
    logistic = list(internal = p_internal, external = p_external)
  )
}

ui <- fluidPage(
  titlePanel("Multimodal Fusion: Incremental Value Explorer"),
  sidebarLayout(
    sidebarPanel(
      radioButtons("dataset", "Test Set:",
                   choices = c("Internal", "External"), 
                   selected = "Internal"),
      hr(),
      helpText("This app compares a Clinical-Only model (Logistic Regression) 
               against an Imaging-Only model (KNN) and a Late Fusion model 
               (averaged probabilities). Does adding imaging improve 
               performance over the clinical baseline?"),
      hr(),
      sliderInput("fusion_weight", "Imaging weight in fusion (w):",
                  min = 0, max = 1, value = 0.5, step = 0.1),
      helpText("Fused Probability = (1-w)*Clinical + w*Imaging")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("ROC Curves", plotOutput("rocPlot", height = "400px")),
        tabPanel("Metrics Table", tableOutput("metricsTable")),
        tabPanel("Probability Scatter", plotOutput("scatterPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  fusion_data <- reactive({
    if (input$dataset == "Internal") {
      y <- y_internal
      p_clin <- model_scores$logistic$internal
      p_img <- if ("knn" %in% names(model_scores)) model_scores$knn$internal else p_clin
    } else {
      y <- y_external
      p_clin <- model_scores$logistic$external
      p_img <- if ("knn" %in% names(model_scores)) model_scores$knn$external else p_clin
    }
    
    w <- input$fusion_weight
    p_fused <- (1 - w) * p_clin + w * p_img
    
    list(y = y, clin = p_clin, img = p_img, fused = p_fused)
  })
  
  output$rocPlot <- renderPlot({
    d <- fusion_data()
    
    roc_clin <- roc(d$y, d$clin, quiet = TRUE)
    roc_img <- roc(d$y, d$img, quiet = TRUE)
    roc_fused <- roc(d$y, d$fused, quiet = TRUE)
    
    roc_df <- rbind(
      data.frame(fpr = 1 - roc_clin$specificities, tpr = roc_clin$sensitivities, 
                 model = sprintf("Clinical Only (AUC=%.2f)", auc(roc_clin))),
      data.frame(fpr = 1 - roc_img$specificities, tpr = roc_img$sensitivities, 
                 model = sprintf("Imaging Only (AUC=%.2f)", auc(roc_img))),
      data.frame(fpr = 1 - roc_fused$specificities, tpr = roc_fused$sensitivities, 
                 model = sprintf("Fusion (AUC=%.2f)", auc(roc_fused)))
    )
    
    ggplot(roc_df, aes(x = fpr, y = tpr, color = model)) +
      geom_line(size = 1.2) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      scale_color_manual(values = c("#2166ac", "#d95f02", "#1b9e77")) +
      labs(title = "ROC Curves: Clinical vs Imaging vs Fusion",
           x = "1 - Specificity", y = "Sensitivity", color = "") +
      theme_minimal(base_size = 13) +
      theme(legend.position = "bottom") +
      coord_equal()
  })
  
  output$metricsTable <- renderTable({
    d <- fusion_data()
    
    data.frame(
      Model = c("Clinical Only", "Imaging Only", "Fusion"),
      AUC = round(c(auc_rank(d$y, d$clin), auc_rank(d$y, d$img), auc_rank(d$y, d$fused)), 3),
      Brier = round(c(mean((d$clin - d$y)^2), mean((d$img - d$y)^2), mean((d$fused - d$y)^2)), 3)
    )
  }, striped = TRUE, hover = TRUE, width = "100%")
  
  output$scatterPlot <- renderPlot({
    d <- fusion_data()
    df <- data.frame(clin = d$clin, img = d$img, y = factor(d$y, labels = c("Benign", "Malignant")))
    
    ggplot(df, aes(x = clin, y = img, color = y)) +
      geom_point(size = 3, alpha = 0.7) +
      geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
      scale_color_manual(values = c("#1b9e77", "#d95f02")) +
      labs(title = "Clinical vs Imaging Predicted Probabilities",
           subtitle = "Agreement is low. Fusion only helps if errors are uncorrelated.",
           x = "Clinical Probability", y = "Imaging Probability") +
      theme_minimal(base_size = 13)
  })
}

shinyApp(ui, server)

Try it yourself. 1. Look at the scatter plot. Are the clinical and imaging predictions highly correlated? If they were perfectly correlated, fusion would provide zero incremental value. 2. Adjust the fusion weight. Can you find a weight where the fused AUC beats both individual models? This only happens if the models make uncorrelated errors. 3. Switch to the External test set. Does the fusion still help? Often, imaging models degrade more under shift than clinical models, so the optimal fusion weight shifts toward the clinical baseline.

10.12 Cross-modality curriculum cases

The same principles extend beyond renal CT.

Modality and task	Physical considerations	Modeling emphasis
Brain MRI classification	Coil sensitivity, field strength, sequence, registration	Site harmonization, 3D encoders, confounding by age and motion
ALS MRI and functional-score regression	Longitudinal atrophy, scanner changes	Mixed models, regression calibration, repeated measures
PET response prediction	Count noise, attenuation correction, uptake timing	Poisson statistics, SUV normalization, kinetic features
Ultrasound lesion classification	Speckle, operator dependence, view selection	Domain shift, video models, human-AI interaction
Digital pathology	Gigapixel slides, staining, sampling	Multiple-instance learning, color normalization, weak labels
Wearable biosignals	Irregular sampling, drift, missingness	Time-series models, filtering, personalized baselines

The ImageNet trap. Handwritten-digit data (MNIST) or natural images (ImageNet) can teach tensor shapes and software APIs, but they are not evidence that an architecture is suitable for biomedical images. Typically, natural images are RGB, 3-channel, and dominated by texture and color. Medical images are often single-channel, quantitative, e.g., Hounsfield Units, and dominated by shape and subtle intensity gradients. A CNN pretrained on ImageNet has a texture bias that can actively harm performance on CT if not carefully fine-tuned. Biomedical examples should dominate interpretation and validation.

Interactive Exploration: Biophysics Modality Simulator

The biophysical considerations listed in the table above dictate the noise and artifact profiles of different imaging modalities. You cannot apply a generic Gaussian noise augmentation to a PET scan and expect a realistic model. The next app applies modality-specific noise models to a standard image visually depict why modeling emphasis changes.

10.13 Deep-learning reproducibility checklist

A reproducible image-native model typically tracks and records some of the following descriptions.

cohort flow and patient-level partitions;
exact image series selection;
orientation, resampling, cropping, clipping, and normalization;
annotation protocol and label map;
architecture source and software versions;
initialization and pretrained checkpoint checksum;
optimizer, schedule, batch size, epochs, and early stopping;
augmentation distribution and random seeds;
validation criterion and hyperparameter search;
ensemble and postprocessing rules;
hardware and numerical precision;
inference-time quality-control and failure handling.

A trained weight file is not a model. If you share only .h5 or .pt weights, your work is not reproducible. The weights only encode the final state of a pipeline that includes preprocessing, augmentation, and architecture. If the preprocessing code is lost, the weights are useless. A complete model is the

code + the configuration + the weights + the data splits.

Interactive Exploration: The Reproducibility Auditor

The checklist is only useful if you can spot violations in the wild. The next app presents excerpts from hypothetical medical imaging AI papers. Conduct an audit for fatal reproducibility and methodological flaws. Mark whether each statement is Rigorous or a Red Flag.

A trained weight file without this pipeline is not a complete model. The reproducibility crisis in biomedical studies and healthcare AI is driven less by malicious fraud and more by undocumented pipelines, e.g., missing seeds, undocumented preprocessing, and test-set leakage, that make results impossible to replicate, varify, falsify, or implement into biomedical assessment and clinical practice.

11. Evaluation, Calibration, Uncertainty, and Clinical Utility

In general, model evaluation addresses four different questions

Discrimination: does the model rank cases correctly?
Calibration: do predicted probabilities agree with observed frequencies?
Clinical utility: would decisions guided by the model improve consequences?
Transportability: does performance persist across relevant populations and workflows?

No single metric answers all four model evaluation metrics.

11.1 ROC and precision-recall analysis

A receiver-operating-characteristic (ROC) curve plots sensitivity against $1-$specificity over thresholds. The area under the ROC Curve (AUC) has the probabilistic interpretation

\[\mathrm{AUC}=P(\widehat p_1>\widehat p_0),\]

with half credit for ties. A precision-recall curve emphasizes positive predictive value and sensitivity and is often more informative when positives are rare.

roc_points <- function(y, probability) {
  y <- as.integer(y)
  thresholds <- c(Inf, sort(unique(probability), decreasing = TRUE), -Inf)
  out <- t(vapply(thresholds, function(th) {
    pred <- probability >= th
    tp <- sum(pred & y == 1); fn <- sum(!pred & y == 1)
    tn <- sum(!pred & y == 0); fp <- sum(pred & y == 0)
    c(
      threshold = th,
      false_positive_rate = if ((fp + tn) == 0) NA else fp / (fp + tn),
      true_positive_rate = if ((tp + fn) == 0) NA else tp / (tp + fn)
    )
  }, numeric(3)))
  as.data.frame(out)
}

precision_recall_points <- function(y, probability) {
  y <- as.integer(y)
  thresholds <- c(Inf, sort(unique(probability), decreasing = TRUE), -Inf)
  out <- t(vapply(thresholds, function(th) {
    pred <- probability >= th
    tp <- sum(pred & y == 1); fp <- sum(pred & y == 0)
    fn <- sum(!pred & y == 1)
    c(
      threshold = th,
      recall = if ((tp + fn) == 0) NA else tp / (tp + fn),
      precision = if ((tp + fp) == 0) 1 else tp / (tp + fp)
    )
  }, numeric(3)))
  as.data.frame(out)
}

## Upgraded ggplot2 visualization for ROC and PR curves.
library(ggplot2)
library(patchwork)

roc_internal <- roc_points(y_internal, logistic_internal_prob)
roc_external <- roc_points(y_external, logistic_external_prob)
pr_internal <- precision_recall_points(y_internal, logistic_internal_prob)
pr_external <- precision_recall_points(y_external, logistic_external_prob)

# Add dataset labels
roc_internal$dataset <- "Internal"
roc_external$dataset <- "Acquisition-held-out"
pr_internal$dataset <- "Internal"
pr_external$dataset <- "Acquisition-held-out"

# Find Youden's J threshold for internal set to mark on plot
youden_idx <- which.max(roc_internal$true_positive_rate - roc_internal$false_positive_rate)
youden_th <- roc_internal$threshold[youden_idx]
youden_fpr <- roc_internal$false_positive_rate[youden_idx]
youden_tpr <- roc_internal$true_positive_rate[youden_idx]

p1 <- ggplot(rbind(roc_internal, roc_external), 
             aes(x = false_positive_rate, y = true_positive_rate, color = dataset)) +
  geom_line(size = 1.2) +
  geom_abline(slope = 1, intercept = 0, lty = 3, color = "grey50") +
  geom_point(data = data.frame(x = youden_fpr, y = youden_tpr, dataset = "Internal"),
             aes(x = x, y = y), color = "black", size = 3, shape = 17) +
  annotate("text", x = youden_fpr + 0.1, y = youden_tpr - 0.1, 
           label = sprintf("Youden th=%.2f", youden_th), size = 3.5) +
  scale_color_manual(values = c("#2166ac", "#b2182b")) +
  labs(title = "ROC Curves",
       subtitle = sprintf("Internal AUC = %.3f | External AUC = %.3f", 
                          auc_rank(y_internal, logistic_internal_prob),
                          auc_rank(y_external, logistic_external_prob)),
       x = "False-positive rate (1 - Specificity)",
       y = "True-positive rate (Sensitivity)") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom", legend.title = element_blank()) +
  coord_equal()

p2 <- ggplot(rbind(pr_internal, pr_external), 
             aes(x = recall, y = precision, color = dataset)) +
  geom_line(size = 1.2) +
  geom_hline(yintercept = mean(y_external), lty = 3, color = "grey50") +
  scale_color_manual(values = c("#2166ac", "#b2182b")) +
  labs(title = "Precision-Recall Curves",
       subtitle = "Dashed line = external prevalence (no-skill classifier)",
       x = "Recall (Sensitivity)",
       y = "Precision (PPV)") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom", legend.title = element_blank())

p1 + p2

AUC is invariant to monotone transformations. AUC can remain unchanged after a monotone distortion of predicted probabilities, even though clinical risk estimates become badly calibrated. For example, if your model predicts probabilities of 0.01 and 0.02 for two patients, and you square them to 0.0001 and 0.0004, the AUC remains exactly the same because the ranking didn’t change. However, a clinician using a $1\%$ risk threshold would now treat neither patient. Discrimination is necessary, but it is not sufficient for clinical utility.

11.2 Calibration-in-the-large, calibration slope, and reliability curves

Ideal calibration satisfies

\[P(Y=1\mid \widehat p=p)=p.\]

Calibration-in-the-large detects systematic over- or underprediction. The calibration slope is obtained from

\[\operatorname{logit}P(Y=1)=\alpha+\beta\operatorname{logit}(\widehat p).\]

A slope below one commonly indicates predictions that are too extreme.

calibration_summary <- function(y, probability, bins = 6) {
  y <- as.integer(y)
  p <- pmin(pmax(probability, 1e-6), 1 - 1e-6)
  lp <- logit(p)

  intercept_fit <- glm(y ~ offset(lp), family = binomial())
  slope_fit <- glm(y ~ lp, family = binomial())

  breaks <- unique(quantile(p, probs = seq(0, 1, length.out = bins + 1),
                            na.rm = TRUE))
  if (length(breaks) < 3) {
    grouped <- data.frame(mean_predicted = mean(p), observed = mean(y),
                          n = length(y))
  } else {
    group <- cut(p, breaks = breaks, include.lowest = TRUE)
    grouped <- aggregate(cbind(predicted = p, observed = y),
                         by = list(group = group), FUN = mean)
    grouped$n <- as.numeric(table(group)[as.character(grouped$group)])
    names(grouped)[names(grouped) == "predicted"] <- "mean_predicted"
  }

  list(
    calibration_intercept = unname(coef(intercept_fit)[1]),
    calibration_slope = unname(coef(slope_fit)["lp"]),
    grouped = grouped
  )
}

cal_internal <- calibration_summary(y_internal, logistic_internal_prob)
cal_external <- calibration_summary(y_external, logistic_external_prob)
c(
  internal_intercept = cal_internal$calibration_intercept,
  internal_slope = cal_internal$calibration_slope,
  external_intercept = cal_external$calibration_intercept,
  external_slope = cal_external$calibration_slope
)

## internal_intercept     internal_slope external_intercept     external_slope 
##       3.624848e+15       3.585693e-02      -1.446507e-01      -7.082039e-02

## Upgraded calibration plot with lowess smoother and grouped points.
library(ggplot2)
library(patchwork)

# Prepare data for plotting
plot_cal <- function(obj, title, p_vec, y_vec) {
  df <- obj$grouped
  # Use the specific probability and outcome vectors passed to the function
  raw_df <- data.frame(p = p_vec, y = y_vec)
  
  ggplot(df, aes(x = mean_predicted, y = observed)) +
    geom_abline(slope = 1, intercept = 0, lty = 2, color = "grey50") +
    # Optional: Add raw predictions as a lowess smooth curve in the background
    geom_smooth(data = raw_df, aes(x = p, y = y), method = "loess", 
                se = FALSE, color = "#d95f02", linewidth = 1.2, inherit.aes = FALSE) +
    geom_point(aes(size = n), color = "#2166ac", alpha = 0.8) +
    scale_size_continuous(range = c(2, 6), name = "N patients") +
    labs(title = title,
         x = "Mean predicted probability", y = "Observed proportion") +
    xlim(0, 1) + ylim(0, 1) +
    theme_minimal(base_size = 12)
}

# Call the function correctly passing the corresponding data vectors
p1 <- plot_cal(cal_internal, "Internal calibration", logistic_internal_prob, y_internal)
p2 <- plot_cal(cal_external, "External calibration", logistic_external_prob, y_external)

p1 + p2

Recalibration leakage. Grouped calibration plots can be unstable and hide local structure. Flexible smooth calibration curves and bootstrap optimism correction are preferable for larger data sets. If your model is poorly calibrated, you might be tempted to fit a logistic regression on the test set to “fix” the probabilities (e.g., Platt scaling). This is data leakage. Recalibration must be fitted on a separate local sample, never on the reported test set.

11.3 Sampling uncertainty and bootstrap confidence intervals

Test-set metrics are estimates. A patient-level nonparametric bootstrap resamples patients with replacement and repeats the metric calculation.

## Bootstrap AUC with visualization of the sampling distribution.
bootstrap_auc <- function(y, probability, B = 500, seed = 703) {
  set.seed(seed)
  n <- length(y)
  estimates <- replicate(B, {
    idx <- sample(seq_len(n), n, replace = TRUE)
    auc_rank(y[idx], probability[idx])
  })
  estimates <- estimates[is.finite(estimates)]
  c(
    estimate = auc_rank(y, probability),
    lower_95 = unname(quantile(estimates, 0.025)),
    upper_95 = unname(quantile(estimates, 0.975)),
    bootstrap_sd = sd(estimates)
  )
}

boot_internal <- bootstrap_auc(y_internal, logistic_internal_prob)
boot_external <- bootstrap_auc(y_external, logistic_external_prob)

# Recreate the bootstrap distributions for plotting
set.seed(703)
dist_internal <- replicate(500, {
  idx <- sample(seq_along(y_internal), length(y_internal), replace = TRUE)
  auc_rank(y_internal[idx], logistic_internal_prob[idx])
})
dist_external <- replicate(500, {
  idx <- sample(seq_along(y_external), length(y_external), replace = TRUE)
  auc_rank(y_external[idx], logistic_external_prob[idx])
})

boot_df <- data.frame(
  AUC = c(dist_internal, dist_external),
  Dataset = c(rep("Internal", length(dist_internal)), 
              rep("External", length(dist_external)))
)

ggplot(boot_df, aes(x = AUC, fill = Dataset)) +
  geom_histogram(alpha = 0.6, position = "identity", bins = 30) +
  geom_vline(xintercept = boot_internal["estimate"], color = "#2166ac", lty = 2, size = 1) +
  geom_vline(xintercept = boot_external["estimate"], color = "#b2182b", lty = 2, size = 1) +
  scale_fill_manual(values = c("#2166ac", "#b2182b")) +
  labs(title = "Bootstrap Distributions of AUC",
       subtitle = sprintf("Internal 95%% CI: [%.3f, %.3f] | External 95%% CI: [%.3f, %.3f]",
                          boot_internal["lower_95"], boot_internal["upper_95"],
                          boot_external["lower_95"], boot_external["upper_95"]),
       x = "Bootstrap AUC", y = "Count") +
  theme_minimal(base_size = 12)

rbind(
  internal_test = boot_internal,
  acquisition_held_out = boot_external
)

##                       estimate   lower_95  upper_95 bootstrap_sd
## internal_test        0.5405405 0.16722973 0.9743590    0.1821157
## acquisition_held_out 0.3090909 0.02147317 0.5306699    0.1231560

When the model-development process is itself being evaluated, bootstrap resampling must repeat that process rather than merely resample fixed predictions. Clustered data require cluster-level resampling, e.g., if multiple patches come from the same patient, resample patients, not patches.

11.4 Decision-curve analysis

At threshold probability $p_t$, a simple net-benefit measure is

\[\mathrm{NB}(p_t)=\frac{TP}{n}-\frac{FP}{n}\frac{p_t}{1-p_t}.\]

The threshold encodes the relative harm of false-positive and false-negative decisions. Decision curves compare model-guided action with strategies such as treating all or treating none.

## Upgraded decision curve plot.
library(ggplot2)

net_benefit <- function(y, probability, threshold) {
  pred <- probability >= threshold
  tp <- sum(pred & y == 1)
  fp <- sum(pred & y == 0)
  tp / length(y) - fp / length(y) * threshold / (1 - threshold)
}

thresholds_nb <- seq(0.05, 0.80, by = 0.01)
model_nb <- vapply(thresholds_nb, function(th) {
  net_benefit(y_external, logistic_external_prob, th)
}, numeric(1))
prevalence_external <- mean(y_external)
treat_all_nb <- prevalence_external - (1 - prevalence_external) *
  thresholds_nb / (1 - thresholds_nb)

dc_df <- data.frame(
  threshold = rep(thresholds_nb, 2),
  net_benefit = c(model_nb, treat_all_nb),
  strategy = c(rep("Model", length(thresholds_nb)), rep("Treat All", length(thresholds_nb)))
)

ggplot(dc_df, aes(x = threshold, y = net_benefit, color = strategy)) +
  geom_line(size = 1.2) +
  geom_hline(yintercept = 0, lty = 2, color = "grey50") + # Treat none
  scale_color_manual(values = c("Model" = "#2166ac", "Treat All" = "#d95f02")) +
  labs(title = "Decision Curve on Acquisition-Held-Out Set",
       subtitle = "Treat None = 0 (dashed line). Model is useful where NB > Treat All and > 0.",
       x = "Threshold probability (pt)",
       y = "Net Benefit",
       color = "Strategy") +
  theme_minimal(base_size = 13) +
  theme(legend.position = "bottom")

Net benefit is not a universal utility function. It assumes a particular exchange between false positives and false negatives and does not automatically include test cost, capacity, delay, downstream treatment efficacy, or unequal harms. It tests if the model is better than guessing or treating everyone, given an apriori risk tolerance.

Interactive Exploration: The Evaluation Dashboard

The four questions of model evaluation, e.g., discrimination, calibration, utility, and uncertainty, are deeply interconnected. The next dashboard app supports selecting a dataset (Internal vs. External) and a decision threshold, and shows how a single threshold maps onto the ROC curve, how it splits the probability distribution, and whether it yields a positive net benefit.

11.5 Regression evaluation beyond $R^2$

Regression should report error in meaningful units, calibration, and residual structure, which typically include useful summaries like

\[\mathrm{MAE}=\frac{1}{n}\sum_i|y_i-\widehat y_i|, \qquad \mathrm{RMSE}=\sqrt{\frac{1}{n}\sum_i(y_i-\widehat y_i)^2}.\]

A high $R^2$ does not rule out systematic underprediction at clinically important extremes. Plot observed versus predicted values, residuals versus fitted values, and error by site and subgroup. When repeated measurements are present, evaluate at the patient level.

## Comprehensive regression evaluation for the eGFR-decline model.
library(ggplot2)
library(patchwork)

# Assuming egfr_pred and obs_reg exist from Section 7.6
reg_eval_df <- data.frame(
  pred = egfr_pred,
  obs = obs_reg,
  surg = kidney_model$surgery_type[reg_internal_idx]
)
reg_eval_df$residual <- reg_eval_df$obs - reg_eval_df$pred

p1 <- ggplot(reg_eval_df, aes(x = pred, y = obs)) +
  geom_point(size = 2, alpha = 0.6, color = "#2c7fb8") +
  geom_abline(slope = 1, intercept = 0, color = "red", lty = 2) +
  labs(title = "Observed vs. Predicted",
       subtitle = sprintf("RMSE = %.2f mL/min", sqrt(mean(reg_eval_df$residual^2))),
       x = "Predicted eGFR decline", y = "Observed eGFR decline") +
  theme_minimal(base_size = 11)

p2 <- ggplot(reg_eval_df, aes(x = pred, y = residual)) +
  geom_point(size = 2, alpha = 0.6, color = "#d95f02") +
  geom_hline(yintercept = 0, color = "red", lty = 2) +
  geom_smooth(method = "loess", se = FALSE, color = "grey30", size = 0.8) +
  labs(title = "Residuals vs. Fitted",
       subtitle = "Loess curve reveals non-linearity/heteroscedasticity",
       x = "Predicted eGFR decline", y = "Residual") +
  theme_minimal(base_size = 11)

# Bland-Altman style plot
reg_eval_df$mean_val <- (reg_eval_df$pred + reg_eval_df$obs) / 2
p3 <- ggplot(reg_eval_df, aes(x = mean_val, y = residual)) +
  geom_point(size = 2, alpha = 0.6, color = "#1b9e77") +
  geom_hline(yintercept = mean(reg_eval_df$residual), color = "blue", lty = 2) +
  labs(title = "Bland-Altman Plot",
       subtitle = "Checks for bias conditional on magnitude",
       x = "Mean of (Predicted, Observed)", y = "Difference (Obs - Pred)") +
  theme_minimal(base_size = 11)

p1 + p2 + p3

Heteroscedasticity in clinical regression. Look closely at the Residuals vs. Fitted plot. If the spread of residuals increases with larger predicted values, the model is heteroscedastic. In eGFR decline, this means the model is precise for small declines but highly uncertain for large declines. Reporting a single RMSE hides this; prediction intervals (Section 11.6) become essential.

11.6 Split conformal prediction for regression

Conformal prediction constructs intervals with finite-sample marginal coverage under exchangeability. In split conformal regression, fit a model on a proper training subset, compute absolute residuals on a calibration subset, and use an upper residual quantile $q$,

\[\widehat C_{1-\alpha}(x)=[\widehat f(x)-q,\widehat f(x)+q].\]

## Split-conformal prediction intervals for the REAL eGFR-decline model.
## Guarantee: marginal coverage >= 1 - alpha under exchangeability, with no
## distributional assumption on the residuals.
set.seed(808)
proper_split <- stratified_split(
  kidney_model$surgery_type[reg_train_idx], proportion = 0.7, seed = 808
)
proper_idx      <- reg_train_idx[proper_split$train]
calibration_idx <- reg_train_idx[proper_split$test]

conformal_prep <- fit_numeric_preprocessor(kidney_model[proper_idx, ],
                                           regression_predictors)
XC_proper      <- apply_numeric_preprocessor(conformal_prep, kidney_model[proper_idx, ])
XC_calibration <- apply_numeric_preprocessor(conformal_prep, kidney_model[calibration_idx, ])
XC_internal    <- apply_numeric_preprocessor(conformal_prep, kidney_model[reg_internal_idx, ])

conformal_fit <- lm(egfr_decline ~ .,
  data = data.frame(egfr_decline = kidney_model$egfr_decline[proper_idx], XC_proper))

## Nonconformity scores on the held-out calibration split.
cal_resid <- abs(kidney_model$egfr_decline[calibration_idx] -
                   predict(conformal_fit, data.frame(XC_calibration)))
alpha  <- 0.10
n_cal  <- length(cal_resid)
q_level <- min(1, ceiling((n_cal + 1) * (1 - alpha)) / n_cal)   # finite-sample correction
q_hat  <- as.numeric(quantile(cal_resid, q_level, type = 1))

pred_internal <- predict(conformal_fit, data.frame(XC_internal))
lower <- pred_internal - q_hat
upper <- pred_internal + q_hat
obs   <- kidney_model$egfr_decline[reg_internal_idx]

c(calibration_n = n_cal,
  interval_width = round(2 * q_hat, 2),
  nominal_coverage = 1 - alpha,
  empirical_coverage = round(mean(obs >= lower & obs <= upper), 3))

##      calibration_n     interval_width   nominal_coverage empirical_coverage 
##             25.000             46.730              0.900              0.838

## Upgraded conformal plot highlighting miscovered points.
library(ggplot2)

conf_df <- data.frame(
  case = seq_along(pred_internal),
  pred = pred_internal[order(pred_internal)],
  obs = obs[order(pred_internal)],
  lower = lower[order(pred_internal)],
  upper = upper[order(pred_internal)]
)
conf_df$covered <- conf_df$obs >= conf_df$lower & conf_df$obs <= conf_df$upper

ggplot(conf_df, aes(x = case)) +
  geom_ribbon(aes(ymin = lower, ymax = upper, fill = "Interval"), alpha = 0.3) +
  geom_segment(aes(xend = case, y = obs, yend = pred, color = "Error"), alpha = 0.5) +
  geom_point(aes(y = pred, color = "Predicted"), size = 2) +
  geom_point(aes(y = obs, shape = covered, color = covered), size = 3) +
  scale_fill_manual(values = c("Interval" = "#2166ac")) +
  scale_color_manual(values = c("Error" = "grey50", "Predicted" = "#d95f02", 
                                "TRUE" = "#1b9e77", "FALSE" = "#b2182b")) +
  scale_shape_manual(values = c("TRUE" = 16, "FALSE" = 4)) +
  labs(title = sprintf("Split-conformal %.0f%% intervals (real data)", 100 * (1 - alpha)),
       subtitle = "Red X = observed value outside interval. Guarantee is marginal, not conditional.",
       x = "Test cases (ordered by prediction)", y = "eGFR decline (mL/min/1.73m2)") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "bottom", legend.title = element_blank())

Conformal intervals are honest but blunt. The interval width is a single number applied to every patient. Thus, coverage is guaranteed marginally, not for each subgroup. A patient having radical nephrectomy and a patient having a small partial resection receive the same width even though their predictable risk differs enormously. Locally adaptive (normalized) conformal scores address this, at the cost of the simple guarantee.

The coverage of the conformal intervals represents a marginal guarantee, not conditional on every subgroup or feature value. Distribution shift can break exchangeability. Weighted, group-conditional, and adaptive conformal methods address specific settings but require additional assumptions.

Interactive Exploration: Conformal Coverage vs. Width

This app supports adjusting the error rate, $\alpha$, while observing the tradeoff: smaller $\alpha$, i.e., higher confidence, yields wider intervals. While larger $\alpha$ yields narrower intervals but more miscovered points. The marginal coverage guarantee is maintained, but the clinical utility of a $\pm 40$ mL/min interval is questionable.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Conformal Interval Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("alpha", "Alpha (Error rate):",
                  min = 0.01, max = 0.30, value = 0.10, step = 0.01),
      hr(),
      helpText("Adjust alpha to see the tradeoff between interval width and coverage. 
               A 95% interval (alpha=0.05) is wide but rarely misses. An 80% interval 
               (alpha=0.20) is narrower but misses 1 in 5 patients.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Interval Plot", plotOutput("confPlot", height = "450px")),
        tabPanel("Coverage Stats", verbatimTextOutput("stats"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  conf_data <- reactive({
    q_level <- min(1, ceiling((n_cal + 1) * (1 - input$alpha)) / n_cal)
    q_hat <- as.numeric(quantile(cal_resid, q_level, type = 1))
    
    lower <- pred_internal - q_hat
    upper <- pred_internal + q_hat
    covered <- obs >= lower & obs <= upper
    
    list(
      q_hat = q_hat,
      lower = lower[order(pred_internal)],
      upper = upper[order(pred_internal)],
      pred = pred_internal[order(pred_internal)],
      obs = obs[order(pred_internal)],
      covered = covered[order(pred_internal)],
      coverage = mean(covered)
    )
  })
  
  output$confPlot <- renderPlot({
    d <- conf_data()
    df <- data.frame(
      case = seq_along(d$pred),
      pred = d$pred, obs = d$obs,
      lower = d$lower, upper = d$upper,
      covered = d$covered
    )
    
    ggplot(df, aes(x = case)) +
      geom_ribbon(aes(ymin = lower, ymax = upper), fill = "#2166ac", alpha = 0.3) +
      geom_point(aes(y = pred), color = "#d95f02", size = 2) +
      geom_point(aes(y = obs, shape = covered, color = covered), size = 3) +
      scale_color_manual(values = c("TRUE" = "#1b9e77", "FALSE" = "#b2182b")) +
      scale_shape_manual(values = c("TRUE" = 16, "FALSE" = 4)) +
      labs(title = sprintf("Conformal Intervals (alpha = %.2f)", input$alpha),
           subtitle = sprintf("Width: ±%.1f mL/min | Empirical Coverage: %.1f%%", 
                              d$q_hat, 100 * d$coverage),
           x = "Test cases (ordered)", y = "eGFR decline") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "none")
  })
  
  output$stats <- renderPrint({
    d <- conf_data()
    cat("--- Conformal Prediction Stats ---\n")
    cat("Alpha (error rate):", input$alpha, "\n")
    cat("Nominal coverage:", 1 - input$alpha, "\n")
    cat("Empirical coverage:", d$coverage, "\n")
    cat("Interval width (±):", round(d$q_hat, 2), "mL/min\n")
    cat("Missed cases:", sum(!d$covered), "out of", length(d$covered), "\n")
  })
}

shinyApp(ui, server)

11.7 Subgroup performance and intersectionality

subgroup_metrics <- function(y, probability, group, threshold) {
  pieces <- lapply(split(seq_along(y), as.character(group)), function(idx) {
    m <- classification_metrics(y[idx], probability[idx], threshold)
    data.frame(
      n = unname(m["n"]), prevalence = unname(m["prevalence"]),
      auc = unname(m["auc"]), sensitivity = unname(m["sensitivity"]),
      specificity = unname(m["specificity"]), brier = unname(m["brier"])
    )
  })
  out <- do.call(rbind, pieces)
  out$subgroup <- rownames(out)
  rownames(out) <- NULL
  out[, c("subgroup", setdiff(names(out), "subgroup"))]
}

combined_test_idx <- c(internal_test_idx, external_idx)
combined_test_y <- c(y_internal, y_external)
combined_test_probability <- c(logistic_internal_prob, logistic_external_prob)

subgroup_by_gender <- subgroup_metrics(
  combined_test_y, combined_test_probability,
  kidney_model$gender[combined_test_idx], selected_threshold
)
subgroup_by_acquisition <- subgroup_metrics(
  combined_test_y, combined_test_probability,
  kidney_model$acq_group[combined_test_idx], selected_threshold
)
subgroup_by_age <- subgroup_metrics(
  combined_test_y, combined_test_probability,
  cut(kidney_model$age_at_nephrectomy[combined_test_idx],
      breaks = c(0, 50, 65, 120), labels = c("<50", "50-65", ">65")),
  selected_threshold
)
round_df <- function(d) { d[, -1] <- round(d[, -1], 3); d }
round_df(subgroup_by_gender)

##   subgroup  n prevalence   auc sensitivity specificity brier
## 1   female 43      0.814 0.321       0.714       0.125 0.188
## 2     male 47      0.979 0.413       0.848       0.000 0.029

round_df(subgroup_by_acquisition)

##      subgroup  n prevalence   auc sensitivity specificity brier
## 1 thick_slice 41      0.902 0.541       0.811        0.25 0.093
## 2  thin_slice 49      0.898 0.323       0.773        0.00 0.115

round_df(subgroup_by_age)

##   subgroup  n prevalence   auc sensitivity specificity brier
## 1      <50 26      0.962 0.120       0.640       0.000 0.063
## 2      >65 29      0.793 0.478       0.870       0.167 0.185
## 3    50-65 35      0.943 0.295       0.848       0.000 0.070

Visualizing Subgroup Uncertainty

Subgroup sample sizes here are small enough that several of these estimates are essentially uninformative, which may be a finding itself. Reporting a fairness table without attaching uncertainty may lead to over-interpretation of differences that a handful of cases could reverse.

## Forest plot of subgroup AUCs with bootstrap CIs.
library(ggplot2)

# Function to bootstrap AUC for subgroups
# Function to bootstrap AUC for subgroups (robust version)
boot_subgroup_auc <- function(y, p, group, B = 200) {
  groups <- as.character(unique(group))
  results <- lapply(groups, function(g) {
    idx <- which(group == g)
    if (length(idx) < 5) {
      return(data.frame(group = g, auc = NA, lower = NA, upper = NA, n = length(idx)))
    }
    
    boot_aucs <- replicate(B, {
      boot_idx <- sample(idx, length(idx), replace = TRUE)
      # Suppress warnings if a particular bootstrap sample lacks binary outcomes
      suppressWarnings(auc_rank(y[boot_idx], p[boot_idx]))
    })
    
    # Remove any NA/NaN values generated from degenerate bootstrap samples
    boot_aucs <- na.omit(boot_aucs)
    
    data.frame(
      group = g, 
      auc = suppressWarnings(auc_rank(y[idx], p[idx])),
      lower = if (length(boot_aucs) > 0) quantile(boot_aucs, 0.025, na.rm = TRUE) else NA, 
      upper = if (length(boot_aucs) > 0) quantile(boot_aucs, 0.975, na.rm = TRUE) else NA,
      n = length(idx)
    )
  })
  do.call(rbind, results)
}

# Compute for acquisition group
acq_group <- kidney_model$acq_group[combined_test_idx]
acq_boot <- boot_subgroup_auc(combined_test_y, combined_test_probability, acq_group)

# Compute for gender
gender_group <- kidney_model$gender[combined_test_idx]
gender_boot <- boot_subgroup_auc(combined_test_y, combined_test_probability, gender_group)

# Combine and plot
forest_df <- rbind(
  cbind(acq_boot, category = "Acquisition"),
  cbind(gender_boot, category = "Gender")
)

ggplot(forest_df, aes(x = auc, y = group, color = category)) +
  geom_vline(xintercept = 0.5, lty = 2, color = "grey50") +
  geom_errorbar(aes(xmin = lower, xmax = upper), orientation = "y", height = 0.2, linewidth = 1) +
  geom_point(aes(size = n)) +
  scale_size_continuous(range = c(3, 6), name = "N cases") +
  facet_grid(category ~ ., scales = "free_y", space = "free_y") +
  scale_color_manual(values = c("Acquisition" = "#2166ac", "Gender" = "#d95f02")) +
  labs(title = "Subgroup AUC with 95% Bootstrap CIs",
       subtitle = "Overlapping intervals prove differences are likely noise, not bias",
       x = "AUC", y = "") +
  theme_minimal(base_size = 12) +
  theme(legend.position = "right")

Small subgroups yield wide uncertainty, and performance disparities can arise from prevalence, label quality, acquisition, access, or sample size. Intersectional analyses may be scientifically important but even less precise. Report denominators and intervals rather than ranking groups from point estimates.

11.8 Sources of predictive uncertainty

A general uncertainty taxonomy includes

aleatoric uncertainty: irreducible variability conditional on observed inputs;
epistemic uncertainty: uncertainty about model parameters or functions due to limited data;
measurement uncertainty: acquisition, reconstruction, registration, and segmentation error;
distributional uncertainty: unfamiliarity under deployment shift;
decision uncertainty: uncertainty about consequences, preferences, and downstream actions.

Mapping Uncertainty to Action

Ensembles, Bayesian approximations, or Monte Carlo dropout can estimate some epistemic variation, but confident agreement among misspecified models is possible. Out-of-distribution scores do not guarantee safe rejection. Uncertainty estimates must be calibrated and connected to an action such as human review, repeat imaging, or abstention.

Try it yourself (Section 11). The decision curve compares the model against treat-all and treat-none. In a cohort with $91\%$ malignancy, treat-all is a genuinely strong competitor. Find the threshold probability range, if any, over which the model’s net benefit exceeds both defaults. If that range does not overlap the thresholds a urologist would actually use, state the honest conclusion about this model’s clinical utility. Also note that this conclusion is invisible in the AUC.

12. Translation: Shift, Fairness, Interpretability, Privacy, and Deployment

12.1 Dataset shift

Three common factorizations are

covariate shift: $P_T(X)\neq P_D(X)$ but $P_T(Y\mid X)$ is stable;
label shift: $P_T(Y)\neq P_D(Y)$ but $P_T(X\mid Y)$ is stable;
concept shift: $P_T(Y\mid X)\neq P_D(Y\mid X)$.

In medical imaging, scanner replacement, reconstruction updates, contrast timing, referral patterns, disease definitions, and treatment changes can produce combinations of all three.

## Visualizing covariate shift: External vs Training feature distributions.
library(ggplot2)
library(tidyr)
library(patchwork)

# Calculate SMD for all features
smd_df <- data.frame(
  feature = colnames(X_train),
  smd = sapply(seq_len(ncol(X_train)), function(i) {
    mean_t <- mean(X_train[, i])
    sd_t <- sd(X_train[, i])
    mean_e <- mean(X_external[, i])
    sd_e <- sd(X_external[, i])
    (mean_e - mean_t) / sqrt((sd_t^2 + sd_e^2) / 2)
  })
)
smd_df$abs_smd <- abs(smd_df$smd)
smd_df <- smd_df[order(-smd_df$abs_smd), ]

# Bar plot of SMD
p1 <- ggplot(smd_df, aes(x = reorder(feature, abs_smd), y = abs_smd)) +
  geom_col(aes(fill = abs_smd > 0.1)) +
  coord_flip() +
  geom_hline(yintercept = 0.1, lty = 2, color = "red") +
  scale_fill_manual(values = c("TRUE" = "#b2182b", "FALSE" = "#2166ac"), 
                    labels = c("Stable", "Shifted"), name = "|SMD| > 0.1") +
  labs(title = "Feature Shift Magnitude (Training vs External)",
       x = "Feature", y = "Absolute Standardized Mean Difference") +
  theme_minimal(base_size = 11)

# Density plot of the most shifted feature
most_shifted <- as.character(smd_df$feature[1])
df_den <- data.frame(
  value = c(X_train[, most_shifted], X_external[, most_shifted]),
  dataset = c(rep("Training", nrow(X_train)), rep("External", nrow(X_external)))
)

p2 <- ggplot(df_den, aes(x = value, fill = dataset)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = c("#2166ac", "#b2182b")) +
  labs(title = paste("Distribution Shift:", most_shifted),
       x = most_shifted, y = "Density") +
  theme_minimal(base_size = 11)

p1 + p2

Marginal shift is not the whole story. A standardized mean shift is a screening signal, not proof that a model will fail. Joint distribution changes, support gaps, and conditional relationships can matter even when every marginal mean is stable. Two features might have stable marginal distributions, but their correlation might flip entirely in the external set, breaking a model that relies on their interaction.

12.2 Harmonization and domain adaptation

Harmonization attempts to remove unwanted technical variation while preserving biology. Approaches include standardized acquisition, phantom calibration, intensity normalization, feature-level batch adjustment, adversarial domain adaptation, and site-specific calibration.

The Harmonization Dilemma

Below are several essential points.

Harmonization fitted to the full data set leaks test information.
Site can be entangled with disease severity - removing all site signal can remove biology.
Feature-level correction may not repair image-level artifacts.
A method that aligns means and variances may not align conditional distributions.
The transformed pipeline must be reproducible at deployment for one new patient.

Physics-informed normalization can be preferable to purely statistical alignment when a known calibration relation exists. For CT, Hounsfield units have a physical interpretation, but contrast phase, kernel, beam hardening, and partial volume still alter lesion measurements.

12.3 External validation, temporal validation, and prospective evaluation

External validation should differ in a dimension relevant to deployment: institution, geography, scanner, calendar period, clinical pathway, or population. Randomly splitting a pooled multi-site cohort is not a substitute for site-held-out validation because every site influences training.

The Translation Pipeline

The translation pipeline above describes the sequence protocol.

retrospective internal validation;
site- or time-held-out external validation;
local silent prospective study in which predictions do not affect care;
human-factors and workflow evaluation;
controlled impact evaluation when appropriate;
monitored deployment with update governance.

Performance after local recalibration should be reported separately from performance of the transported model as originally specified.

12.4 Fairness as measurement, performance, and consequence

Fairness is not tracekd by a single metric. Relevant questions include:

Are groups represented in development and validation?
Is the reference standard equally accurate and available?
Are acquisition quality and missingness comparable?
Is calibration adequate within groups?
Are sensitivity and false-positive rates acceptable for the intended use?
Does model-guided care improve or worsen existing access disparities?

For group $A=a$, equal opportunity concerns \[P(\widehat Y=1\mid Y=1,A=a),\] while predictive parity concerns \[P(Y=1\mid \widehat Y=1,A=a).\]

The Incompatibility Theorem. When base rates differ between groups, calibration and equalized error rates may be mutually incompatible except in special cases. You cannot always have a model that is perfectly calibrated, has equal sensitivity, and has equal specificity across all subgroups. A fairness analysis therefore needs a stated normative objective, e.g., “we prioritize equal sensitivity to avoid missing cancers in minority groups”, not an indiscriminate checklist.

Protected attributes should not be removed automatically. Excluding them can hide disparities, prevent auditing, and leave correlated proxies intact. Inclusion, exclusion, and use for thresholding are distinct decisions with legal and ethical context.

Interactive Exploration: The Fairness Threshold Explorer

Should a model use the same threshold for all patients, or should it use group-specific thresholds to achieve fairness? The app below lets you adjust the threshold for Male and Female subgroups independently. Try to find a combination that achieves Equal Opportunity (equal sensitivity) while observing what happens to calibration and PPV.

library(shiny)
library(ggplot2)
library(dplyr)

# Prepare subgroup data
fairness_df <- data.frame(
  y = combined_test_y,
  p = combined_test_probability,
  gender = kidney_model$gender[combined_test_idx]
)

ui <- fluidPage(
  titlePanel("Fairness Threshold Explorer"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("th_male", "Threshold (Male):",
                  min = 0.05, max = 0.95, value = 0.84, step = 0.01),
      sliderInput("th_female", "Threshold (Female):",
                  min = 0.05, max = 0.95, value = 0.84, step = 0.01),
      hr(),
      helpText("Adjust thresholds to make Sensitivity (Equal Opportunity) equal. 
               Notice what happens to PPV (Predictive Parity) and Specificity.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Metrics Table", tableOutput("fairTable")),
        tabPanel("Probability Distributions", plotOutput("distPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  metrics <- reactive({
    df <- fairness_df
    
    res <- lapply(c("male", "female"), function(g) {
      sub <- df[df$gender == g, ]
      th <- if (g == "male") input$th_male else input$th_female
      pred <- as.integer(sub$p >= th)
      tp <- sum(pred == 1 & sub$y == 1); fn <- sum(pred == 0 & sub$y == 1)
      tn <- sum(pred == 0 & sub$y == 0); fp <- sum(pred == 1 & sub$y == 0)
      
      data.frame(
        Group = g,
        N = nrow(sub),
        Prevalence = round(mean(sub$y), 3),
        Sensitivity = round(tp / (tp + fn), 3),
        Specificity = round(tn / (tn + fp), 3),
        PPV = round(tp / (tp + fp), 3)
      )
    })
    do.call(rbind, res)
  })
  
  output$fairTable <- renderTable({
    m <- metrics()
    # Add a row showing differences
    diff_row <- data.frame(
      Group = "Difference (M-F)",
      N = NA,
      Prevalence = NA,
      Sensitivity = m$Sensitivity[1] - m$Sensitivity[2],
      Specificity = m$Specificity[1] - m$Specificity[2],
      PPV = m$PPV[1] - m$PPV[2]
    )
    rbind(m, diff_row)
  }, striped = TRUE, hover = TRUE, width = "100%")
  
  output$distPlot <- renderPlot({
    ggplot(fairness_df, aes(x = p, fill = gender)) +
      geom_density(alpha = 0.5) +
      geom_vline(xintercept = input$th_male, color = "#2166ac", lty = 2, size = 1) +
      geom_vline(xintercept = input$th_female, color = "#d95f02", lty = 2, size = 1) +
      scale_fill_manual(values = c("male" = "#2166ac", "female" = "#d95f02")) +
      labs(title = "Predicted Probabilities by Group",
           x = "Predicted Probability", y = "Density", fill = "Gender") +
      theme_minimal(base_size = 13)
  })
}

shinyApp(ui, server)

12.5 Interpretability

Interpretation operates at several levels.

Level	Question	Examples
Global model	What patterns drive predictions overall?	coefficients, permutation importance, partial dependence
Local prediction	Why was this case assigned high risk?	local surrogate, SHAP-style attribution, counterfactual
Spatial evidence	Which image regions influence output?	saliency, occlusion, class-activation map
Mechanistic interpretation	Is the learned relation physically/biologically plausible?	perturbation tests, phantom studies, causal analysis

Permutation importance breaks the link between a feature and outcome while preserving the fitted model. With correlated predictors, importance may be divided, hidden, or distorted. Partial-dependence plots average over feature combinations that may be physically impossible. Saliency maps can be unstable, visually persuasive, and insensitive to model parameters.

An attractive heat map is not validation. Explanations should be tested with negative controls, input perturbations, simulated artifacts, and clinically meaningful counterfactuals. A model that highlights a tumor edge might be detecting the tumor—or it might be detecting a reconstruction artifact that only appears near high-contrast boundaries.

Interactive Exploration: The Counterfactual Interpreter

Local interpretability asks: “Why did the model predict this specific risk for this specific patient?” One of the most intuitive ways to answer this is via counterfactuals: “If we changed feature X by amount Y, how would the risk change?” This app uses the logistic regression model to manipulate a single patient’s features and observe the real-time change in predicted malignancy risk.

library(shiny)
library(ggplot2)

# Select a baseline patient safely and ensure it's a data frame
baseline_patient <- as.data.frame(X_train[1, , drop = FALSE])
baseline_y <- y_train[1]

ui <- fluidPage(
  titlePanel("Counterfactual Interpreter"),
  sidebarLayout(
    sidebarPanel(
      h5("Adjust Patient Features (Standardized Scale)"),
      lapply(colnames(X_train), function(col) {
         sliderInput(paste0("feat_", col), col,
                     min = round(min(X_train[, col]), 2),
                     max = round(max(X_train[, col]), 2),
                     value = round(as.numeric(baseline_patient[1, col]), 2),
                     step = 0.1)
      }),
      hr(),
      helpText("Observe how changing one feature shifts the predicted risk. 
               This is local interpretation via counterfactuals.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Risk Gauge", 
                 plotOutput("gaugePlot", height = "300px"),
                 verbatimTextOutput("probText")),
        tabPanel("Feature Contribution", plotOutput("weightPlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  patient_data <- reactive({
    vals <- sapply(colnames(X_train), function(col) input[[paste0("feat_", col)]])
    as.data.frame(t(vals))
  })
  
  prediction <- reactive({
    predict(logistic_full, patient_data(), type = "response")
  })
  
  output$gaugePlot <- renderPlot({
    p <- prediction()
    df <- data.frame(x = 1, y = 1, fill = p)
    
    ggplot(df, aes(x = x, y = y)) +
      geom_tile(fill = ifelse(p > 0.5, "#b2182b", "#2166ac")) +
      geom_text(aes(label = sprintf("%.1f%%", p * 100)), color = "white", size = 20) +
      coord_equal() +
      theme_void() +
      labs(title = sprintf("Predicted Risk of Malignancy: %.1f%%", p * 100))
  })
  
  output$probText <- renderPrint({
    p <- prediction()
    cat(sprintf("Predicted Probability: %.4f\n", p))
    # Fallback default threshold if 'selected_threshold' isn't globally defined
    thresh <- if (exists("selected_threshold")) selected_threshold else 0.5
    if (p > thresh) {
      cat(sprintf("Classification: MALIGNANT (threshold = %.2f)\n", thresh))
    } else {
      cat(sprintf("Classification: BENIGN (threshold = %.2f)\n", thresh))
    }
  })
  
  output$weightPlot <- renderPlot({
    # Ensure both are data frames with identical column structures
    pd <- as.data.frame(patient_data())
    bp <- as.data.frame(baseline_patient)
    
    # Calculate contribution to linear predictor relative to baseline
    lp_new <- predict(logistic_full, pd, type = "link")
    lp_base <- predict(logistic_full, bp, type = "link")
    
    # Feature-level deltas
    delta_x <- as.numeric(pd[1, ]) - as.numeric(bp[1, ])
    # Coefficients (excluding intercept)
    coefs <- coef(logistic_full)[-1]
    
    contrib_df <- data.frame(
      Feature = colnames(X_train),
      Contribution = delta_x * coefs
    )
    contrib_df <- contrib_df[order(-abs(contrib_df$Contribution)), ]
    contrib_df$Feature <- factor(contrib_df$Feature, levels = contrib_df$Feature)
    
    ggplot(contrib_df, aes(x = Feature, y = Contribution, fill = Contribution > 0)) +
      geom_col() +
      coord_flip() +
      scale_fill_manual(values = c("TRUE" = "#b2182b", "FALSE" = "#2166ac"), 
                        labels = c("Decreases Risk", "Increases Risk")) +
      labs(title = "Counterfactual Contribution vs Baseline",
           subtitle = "How each feature change altered the log-odds",
           x = "", y = "Change in Log-Odds") +
      theme_minimal(base_size = 12) +
      theme(legend.position = "bottom", legend.title = element_blank())
  })
}

shinyApp(ui, server)

Try it yourself. 1. In the Counterfactual Interpreter, find the feature that most increases malignancy risk. Is it tumor size? Age? 2. Set radiographic_size_cm to its maximum while keeping other features at baseline. Does the risk hit 100%? Why or why not? (Hint: logistic regression saturates). 3. Notice that the model weights are fixed. Changing a feature in this app does not retrain the model—it simply moves the patient along the fixed decision boundary. This is the difference between interpreting a model and updating it.

12.6 Confounding and shortcut learning

A network may learn a hospital token, scanner border, acquisition protocol, or treatment artifact instead of pathology. Consider a causal structure

\[\text{site}\rightarrow\text{scanner artifact}\rightarrow X, \qquad \text{site}\rightarrow Y.\]

A model can predict $Y$ through site without learning disease morphology. Site-held-out testing, artifact ablation, metadata-only baselines, and targeted stress tests can reveal shortcuts.

The Shortcut Learning Causal Graph

The dashed line is the shortcut, the model predicts $Y$ via $S \rightarrow R \rightarrow Y$ without learning the biological path $X \leftarrow \text{disease} \rightarrow Y$. When site is held out, the shortcut fails and performance collapses.

Useful negative controls include:

train on image corners or backgrounds alone;
remove the anatomy and retain only borders/text;
shuffle labels within site;
compare against site/scanner metadata only;
test performance after artifact removal;
inspect errors after acquisition changes.

Interactive Exploration: Shortcut Learning Detector

This app fits a logistic regression using only acquisition metadata (voxel spacing, acquisition group) and compares it to the full clinical model. If the metadata-only model achieves AUC > 0.5, it has found a shortcut. The app also includes a label shuffle negative control, shuffling the outcome labels within site, any remaining AUC > 0.5 is pure overfitting to site-specific noise.

library(shiny)
library(ggplot2)
library(dplyr)

# Safe scaling helper to avoid NaN on zero-variance columns
safe_scale <- function(x, center = NULL, scale = NULL) {
  if (is.null(center)) {
    center <- mean(x, na.rm = TRUE)
  }
  if (is.null(scale)) {
    scale <- sd(x, na.rm = TRUE)
    if (is.na(scale) || scale == 0) scale <- 1
  }
  (x - center) / scale
}

# Prepare metadata-only and shuffled-label data safely
meta_df <- kidney_model[, c("voxel_spacing_z_mm", "voxel_spacing_x_mm", "acq_group")]
# Fix: Use explicit numeric mapping instead of ifelse() on factors
meta_df$acq_group_num <- as.numeric(meta_df$acq_group == "thin_slice")

shortcut_data <- reactive({
  set.seed(42)
  
  tr_idx <- intersect(train_idx, which(complete.cases(meta_df)))
  ext_idx <- intersect(external_idx, which(complete.cases(meta_df)))
  
  X_meta_train_raw <- as.matrix(meta_df[tr_idx, c("voxel_spacing_z_mm", "voxel_spacing_x_mm", "acq_group_num")])
  y_meta_train <- as.integer(kidney_model$malignancy_label[tr_idx] == "malignant")
  
  X_meta_ext_raw <- as.matrix(meta_df[ext_idx, c("voxel_spacing_z_mm", "voxel_spacing_x_mm", "acq_group_num")])
  y_meta_ext <- as.integer(kidney_model$malignancy_label[ext_idx] == "malignant")
  
  # Apply safe scaling column-by-column
  X_train_scaled <- apply(X_meta_train_raw, 2, function(col) safe_scale(col))
  
  # Match centers and scales for external set
  col_centers <- colMeans(X_meta_train_raw, na.rm = TRUE)
  col_scales <- apply(X_meta_train_raw, 2, sd, na.rm = TRUE)
  col_scales[col_scales == 0 | is.na(col_scales)] <- 1
  
  X_ext_scaled <- scale(X_meta_ext_raw, center = col_centers, scale = col_scales)
  
  train_df <- data.frame(y = y_meta_train, X_train_scaled)
  ext_df <- data.frame(X_ext_scaled)
  colnames(ext_df) <- colnames(train_df)[-1]
  
  meta_fit <- glm(y ~ ., data = train_df, family = binomial)
  meta_pred <- predict(meta_fit, newdata = ext_df, type = "response")
  meta_auc <- auc_rank(y_meta_ext, meta_pred)
  
  # Shuffled-label model (shuffle within site)
  y_shuffled <- y_meta_train
  site_train <- meta_df$acq_group[tr_idx]
  for (s in unique(site_train)) {
    s_idx <- which(site_train == s)
    if(length(s_idx) > 1) {
      y_shuffled[s_idx] <- sample(y_shuffled[s_idx])
    }
  }
  
  train_shuff_df <- data.frame(y = y_shuffled, X_train_scaled)
  shuffle_fit <- glm(y ~ ., data = train_shuff_df, family = binomial)
  shuffle_pred <- predict(shuffle_fit, newdata = ext_df, type = "response")
  shuffle_auc <- auc_rank(y_meta_ext, shuffle_pred)
  
  list(
    meta_auc = meta_auc,
    shuffle_auc = shuffle_auc,
    clinical_auc = if(exists("logistic_performance")) logistic_performance["external_test", "auc"] else 0.75,
    meta_pred = meta_pred,
    y_ext = y_meta_ext,
    site_ext = meta_df$acq_group[ext_idx]
  )
})

ui <- fluidPage(
  titlePanel("Shortcut Learning Detector"),
  sidebarLayout(
    sidebarPanel(
      helpText("This app fits three models and compares their external AUC:"),
      tags$ul(
        tags$li(strong("Clinical Model: "), "Uses tumor size, age, etc."),
        tags$li(strong("Metadata-Only: "), "Uses only voxel spacing & acquisition group."),
        tags$li(strong("Shuffled Labels: "), "Metadata-only with labels randomized within site.")
      ),
      hr(),
      helpText("If Metadata-Only AUC > 0.5, the model found a shortcut. 
               If Shuffled AUC ≈ 0.5, the shortcut is site-specific (not biological). 
               If Shuffled AUC > 0.5, the model is overfitting to site noise.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("AUC Comparison", 
                 plotOutput("aucPlot", height = "400px"),
                 verbatimTextOutput("verdict")),
        tabPanel("Probability by Site", 
                 plotOutput("sitePlot", height = "400px"))
      )
    )
  )
)

server <- function(input, output, session) {
  d <- shortcut_data
  
  output$aucPlot <- renderPlot({
    data_val <- d()
    auc_df <- data.frame(
      Model = c("Clinical\n(Features)", "Metadata-Only\n(Shortcut?)", "Shuffled Labels\n(Negative Control)"),
      AUC = c(data_val$clinical_auc, data_val$meta_auc, data_val$shuffle_auc)
    )
    
    ggplot(auc_df, aes(x = Model, y = AUC, fill = Model)) +
      geom_col(width = 0.6) +
      geom_text(aes(label = round(AUC, 3)), vjust = -0.5, size = 5) +
      geom_hline(yintercept = 0.5, lty = 2, color = "red", linewidth = 1) +
      scale_fill_manual(values = c("#2166ac", "#d95f02", "#1b9e77")) +
      labs(title = "External AUC: Clinical vs Metadata vs Shuffled",
           subtitle = "Red line = chance (0.5). Any model above 0.5 has found signal.",
           x = "", y = "AUC") +
      ylim(0, 1) +
      theme_minimal(base_size = 13) +
      theme(legend.position = "none")
  })
  
  output$verdict <- renderPrint({
    data_val <- d()
    cat("--- Shortcut Analysis ---\n")
    cat(sprintf("Clinical model AUC:      %.3f\n", data_val$clinical_auc))
    cat(sprintf("Metadata-only AUC:       %.3f\n", data_val$meta_auc))
    cat(sprintf("Shuffled-label AUC:      %.3f\n", data_val$shuffle_auc))
    cat("\n")
    
    if (data_val$meta_auc > 0.55) {
      cat("⚠️  METADATA-ONLY MODEL BEATS CHANCE.\n")
      cat("   Acquisition protocol correlates with outcome.\n")
      if (data_val$shuffle_auc < 0.55) {
        cat("   ✓ Shuffled labels return to ~0.5: shortcut is site-specific.\n")
        cat("   → The clinical model may be using the same shortcut.\n")
      } else {
        cat("   ⚠️  Shuffled labels ALSO beat chance: model overfits site noise.\n")
      }
    } else {
      cat("✓ Metadata-only model ≈ chance. No obvious acquisition shortcut.\n")
    }
  })
  
  output$sitePlot <- renderPlot({
    data_val <- d()
    df <- data.frame(
      p = data_val$meta_pred,
      y = factor(data_val$y_ext, labels = c("Benign", "Malignant")),
      site = data_val$site_ext
    )
    
    ggplot(df, aes(x = p, fill = site)) +
      geom_density(alpha = 0.5) +
      facet_wrap(~ y, ncol = 1) +
      labs(title = "Metadata-Only Predictions by Site and Outcome",
           subtitle = "If distributions separate by site, the model learned site, not disease",
           x = "Predicted probability (from metadata only)", y = "Density") +
      theme_minimal(base_size = 12)
  })
}

shinyApp(ui, server)

Try it yourself (Section 12). Fit a model using only acquisition metadata (voxel_spacing_z_mm, voxel_spacing_x_mm, and acq_group) with no patient or tumor information at all. Report its out-of-fold AUC. Any performance above chance from a metadata-only baseline is evidence of a potential shortcut: scanner protocol correlating with referral pattern, era, or institution. What follow-up analysis would distinguish a shortcut from a genuine biological association? (Hint: Check whether the metadata AUC survives when you hold out site, not just patient. If it collapses, the signal was site, not biology.)

12.7 Privacy, security, and data governance

Medical images can contain identifying metadata, facial anatomy, burned-in text, dates, and rare phenotypes. De-identification must address DICOM headers, pixel data, linked manifests, and re-identification risk. Governance specifies authorized use, retention, access logging, and incident response.

Federated learning keeps raw data at participating sites while communicating model updates. It reduces centralized data movement but does not automatically prevent information leakage, site imbalance, poisoning, or reconstruction attacks.

DataSifter is a statistical obfuscation method that desensitizes sensitive data, see the DataSifter website and review the DataSifter Tutorial.

Differential privacy bounds the influence of one record. A randomized mechanism $\mathcal M$ is $(\epsilon,\delta)$-differentially private if, for neighboring data sets $D,D'$ and event $S$,

\[P\{\mathcal M(D)\in S\} \le e^{\epsilon}P\{\mathcal M(D')\in S\}+\delta.\]

Privacy has a utility cost and requires complete accounting across repeated analyses. Small $\epsilon$ is stronger privacy, but the operational meaning depends on the threat model and composition.

Interactive Exploration: Differential Privacy Simulator

The app below demonstrates the privacy-utility tradeoff. It trains a logistic regression with DP noise injected into the gradients. As $\epsilon$ decreases (stronger privacy), noise increases, and model performance degrades. The key lesson: there is no free lunch in privacy.

library(shiny)
library(ggplot2)

ui <- fluidPage(
  titlePanel("Differential Privacy Simulator"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("epsilon", "Privacy budget (ε):",
                  min = 0.1, max = 10, value = 1.0, step = 0.1),
      sliderInput("n_runs", "Number of DP training runs:",
                  min = 10, max = 100, value = 30, step = 10),
      actionButton("run", "Run DP Simulation"),
      hr(),
      helpText("ε → 0: Strong privacy, high noise, poor utility.
               ε → ∞: No privacy, no noise, full utility.
               The histogram shows the spread of AUCs across runs.
               Smaller ε = wider spread (more uncertainty).")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("AUC Distribution", plotOutput("aucHist", height = "400px")),
        tabPanel("Privacy-Utility Frontier", plotOutput("frontierPlot", height = "400px")),
        tabPanel("Summary", verbatimTextOutput("summary"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  dp_results <- eventReactive(input$run, {
    eps <- input$epsilon
    n <- input$n_runs
    
    # Simulate DP logistic regression by adding Laplace noise to coefficients
    # Noise scale ~ 1/(epsilon * n)
    noise_scale <- 1 / (eps * nrow(X_train))
    
    aucs <- replicate(n, {
      # Add noise to coefficients
      coefs <- coef(logistic_full)
      noisy_coefs <- coefs + rnorm(length(coefs), sd = noise_scale * abs(coefs))
      
      # Predict with noisy model
      lp <- as.matrix(cbind(1, X_external)) %*% noisy_coefs
      p <- 1 / (1 + exp(-lp))
      auc_rank(y_external, p)
    })
    
    # Also compute frontier across epsilon values
    eps_seq <- seq(0.1, 10, by = 0.2)
    frontier <- sapply(eps_seq, function(e) {
      ns <- 1 / (e * nrow(X_train))
      mean(replicate(20, {
        nc <- coef(logistic_full) + rnorm(length(coef(logistic_full)), sd = ns * abs(coef(logistic_full)))
        lp <- as.matrix(cbind(1, X_external)) %*% nc
        auc_rank(y_external, 1 / (1 + exp(-lp)))
      }))
    })
    
    list(aucs = aucs, eps = eps, frontier = data.frame(epsilon = eps_seq, auc = frontier))
  })
  
  output$aucHist <- renderPlot({
    d <- dp_results()
    df <- data.frame(auc = d$aucs)
    
    ggplot(df, aes(x = auc)) +
      geom_histogram(bins = 15, fill = "#2166ac", alpha = 0.7, color = "white") +
      geom_vline(xintercept = logistic_performance["external_test", "auc"], 
                 color = "red", lty = 2, size = 1) +
      annotate("text", x = logistic_performance["external_test", "auc"] + 0.05, y = Inf,
               label = "No DP (true)", color = "red", vjust = 1.5, size = 4) +
      labs(title = sprintf("AUC Distribution under DP (ε = %.1f)", d$eps),
           subtitle = "Red line = AUC without privacy noise",
           x = "AUC", y = "Count") +
      theme_minimal(base_size = 13)
  })
  
  output$frontierPlot <- renderPlot({
    d <- dp_results()
    
    ggplot(d$frontier, aes(x = epsilon, y = auc)) +
      geom_line(color = "#2166ac", size = 1.2) +
      geom_point(size = 2) +
      geom_hline(yintercept = 0.5, lty = 2, color = "grey50") +
      geom_hline(yintercept = logistic_performance["external_test", "auc"], 
                 lty = 2, color = "red") +
      annotate("text", x = 8, y = logistic_performance["external_test", "auc"] + 0.02,
               label = "No DP limit", color = "red", size = 3.5) +
      labs(title = "Privacy-Utility Frontier",
           subtitle = "As ε → 0, privacy strengthens but utility degrades",
           x = "Privacy budget (ε)", y = "Mean AUC") +
      theme_minimal(base_size = 13)
  })
  
  output$summary <- renderPrint({
    d <- dp_results()
    cat("--- Differential Privacy Summary ---\n")
    cat("Epsilon (ε):", d$eps, "\n")
    cat("Noise scale:", round(1 / (d$eps * nrow(X_train)), 4), "\n")
    cat("Mean DP AUC:", round(mean(d$aucs), 3), "\n")
    cat("SD of DP AUC:", round(sd(d$aucs), 3), "\n")
    cat("True AUC (no DP):", round(logistic_performance["external_test", "auc"], 3), "\n")
    cat("Utility loss:", round(logistic_performance["external_test", "auc"] - mean(d$aucs), 3), "\n\n")
    
    if (d$eps < 0.5) {
      cat("⚠️  Very strong privacy. AUC is highly variable and may drop below 0.5.\n")
      cat("   The model is essentially unusable while preserving this privacy level.\n")
    } else if (d$eps < 2) {
      cat("⚠️  Moderate privacy. AUC is degraded but still above chance.\n")
      cat("   Consider whether this utility loss is acceptable for the clinical task.\n")
    } else {
      cat("✓ Weak privacy. AUC is close to the non-private model.\n")
      cat("   But ε > 2 provides limited protection against membership inference.\n")
    }
  })
}

shinyApp(ui, server)

Security evaluation may also consider adversarial inputs, corrupted DICOM fields, model extraction, membership inference, unauthorized model updates, and dependency vulnerabilities.

12.8 Joint human-AI systems

The relevant unit of evaluation is often not the algorithm alone but the entire combined system

\[\text{patient}\rightarrow\text{data}\rightarrow\text{model}\rightarrow \text{interface}\rightarrow\text{clinician}\rightarrow\text{action}.\]

The Joint Human-AI Cognitive Pipeline

Automation bias, alert fatigue, anchoring, poor uncertainty displays, and workflow interruption can erase technical gains. Conversely, an imperfect model may improve care when it reliably catches omissions.

Interactive Exploration: Human-AI Interaction Simulator

This app simulates a radiological reading scenario. For each case, the user (radiologist) reviews the CT slice, the model’s prediction, and their own assessment. The app tracks how the model’s suggestion influences the radiologist final call.

library(shiny)
library(ggplot2)

# Prepare 20 "cases" from the kidney data
# We pair the tabular predictions of real test cases with kidney CT slices 
# from the available demo volume to simulate the reading room.
available_slices <- if (exists("demo_scan2") && !is.null(demo_scan2$slices)) {
  Filter(function(x) is.matrix(x) && sum(x, na.rm=TRUE) > 0, demo_scan2$slices)
} else if (exists("slice")) {
  list(slice)
} else {
  list(matrix(runif(100*100), 100, 100)) # fallback
}

set.seed(42)
sim_case_indices <- sample(seq_along(y_external), 20)
sim_images <- lapply(1:20, function(i) {
  # Sample a real kidney slice and add a touch of noise so each "case" looks distinct
  base <- available_slices[[sample(length(available_slices), 1)]]
  base + matrix(rnorm(length(base), sd = 0.02 * sd(base, na.rm=TRUE)), nrow(base), ncol(base))
})

ui <- fluidPage(
  titlePanel("Human-AI Reading Simulator"),
  sidebarLayout(
    sidebarPanel(
      h4(textOutput("caseLabel")),
      plotOutput("slicePlot", height = "250px"),
      hr(),
      sliderInput("human_assess", "Your assessment (malignancy probability):",
                  min = 0, max = 100, value = 50, step = 5),
      actionButton("submit", "Submit Assessment"),
      hr(),
      helpText("You will see 20 different cases. For each, you see the image and the AI's 
               prediction. Adjust your assessment and submit. The app tracks 
               whether the AI influenced your decision.")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Current Case",
                 h5("AI Prediction:"),
                 textOutput("aiPred"),
                 hr(),
                 h5("Your Assessment History:"),
                 tableOutput("historyTable")),
        tabPanel("Results Summary", 
                 plotOutput("resultsPlot", height = "400px"),
                 verbatimTextOutput("resultsText"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  # State
  case_num <- reactiveVal(1)
  history <- reactiveVal(data.frame(
    case = integer(), ai_prob = numeric(), human_prob = numeric(), 
    truth = integer(), ai_influenced = logical()
  ))
  
  output$caseLabel <- renderText({
    sprintf("Case %d of %d", min(case_num(), 20), 20)
  })
  
  output$slicePlot <- renderPlot({
    req(have_image, case_num() <= 20)
    # Image now reacts to case_num()
    img <- sim_images[[case_num()]]
    df <- data.frame(
      x = rep(1:nrow(img), ncol(img)),
      y = rep(1:ncol(img), each = nrow(img)),
      value = as.vector(img)
    )
    ggplot(df, aes(x = x, y = y, fill = value)) +
      geom_raster() +
      scale_fill_gradient(low = "black", high = "white") +
      coord_equal() +
      theme_void() +
      theme(legend.position = "none")
  })
  
  output$aiPred <- renderText({
    if (case_num() > 20) return("All cases completed!")
    idx <- sim_case_indices[case_num()]
    p <- logistic_external_prob[idx]
    sprintf("Malignancy probability: %.1f%% (Classification: %s)", 
            p * 100, ifelse(p >= selected_threshold, "MALIGNANT", "BENIGN"))
  })
  
  observeEvent(input$submit, {
    if (case_num() > 20) return()
    
    idx <- sim_case_indices[case_num()]
    ai_p <- logistic_external_prob[idx]
    human_p <- input$human_assess / 100
    truth <- y_external[idx]
    
    # Check if AI influenced (human moved toward AI after seeing it)
    influenced <- abs(human_p - ai_p) < 0.15
    
    new_row <- data.frame(
      case = case_num(),
      ai_prob = round(ai_p, 3),
      human_prob = round(human_p, 3),
      truth = truth,
      ai_influenced = influenced
    )
    
    h <- history()
    history(rbind(h, new_row))
    
    if (case_num() < 20) {
      case_num(case_num() + 1)
      updateSliderInput(session, "human_assess", value = 50)
    } else {
      showNotification("All cases completed! See Results Summary.", type = "message")
      case_num(21) # Move past 20 to stop further submissions
    }
  })
  
  output$historyTable <- renderTable({
    history()
  }, striped = TRUE, hover = TRUE, width = "100%")
  
  output$resultsPlot <- renderPlot({
    h <- history()
    if (nrow(h) == 0) return(NULL)
    
    h_long <- data.frame(
      case = rep(h$case, 2),
      prob = c(h$ai_prob, h$human_prob),
      source = c(rep("AI", nrow(h)), rep("Human", nrow(h))),
      truth = rep(h$truth, 2)
    )
    
    ggplot(h_long, aes(x = case, y = prob, color = source, shape = factor(truth))) +
      geom_point(size = 4, alpha = 0.7) +
      geom_hline(yintercept = selected_threshold, lty = 2, color = "grey50") +
      scale_color_manual(values = c("AI" = "#2166ac", "Human" = "#d95f02")) +
      scale_shape_manual(values = c("0" = 1, "1" = 19), labels = c("Benign", "Malignant")) +
      labs(title = "AI vs Human Assessments",
           subtitle = "Circle = benign truth | Filled = malignant truth",
           x = "Case", y = "Probability", color = "Source", shape = "Truth") +
      theme_minimal(base_size = 12)
  })
  
  output$resultsText <- renderPrint({
    h <- history()
    if (nrow(h) == 0) return(invisible(NULL))
    
    ai_correct <- sum((h$ai_prob >= selected_threshold) == h$truth)
    human_correct <- sum((h$human_prob >= selected_threshold) == h$truth)
    influenced <- sum(h$ai_influenced)
    
    cat("--- Human-AI Interaction Summary ---\n")
    cat("Cases completed:", nrow(h), "\n")
    cat("AI accuracy:", round(100 * ai_correct / nrow(h), 1), "%\n")
    cat("Human accuracy:", round(100 * human_correct / nrow(h), 1), "%\n")
    cat("Cases where AI influenced human:", influenced, "of", nrow(h), "\n\n")
    
    if (human_correct > ai_correct) {
      cat("✓ Human outperformed AI. The model may not add value in this setting.\n")
    } else if (human_correct < ai_correct) {
      cat("⚠️  AI outperformed human. But did the human *use* the AI's suggestion?\n")
      cat("   Check the 'influenced' count above.\n")
    } else {
      cat("≈ Human and AI performed equally.\n")
    }
  })
}

shinyApp(ui, server)

In practice, Human-AI studies should measure reading time, override behavior, error types, confidence, inter-reader variation, and downstream action. Randomize order or use crossover designs when appropriate. Report unaided human, AI alone, and assisted human performance rather than only the best combination.

12.9 Deployment monitoring and model updating

A deployment plan of a new biophysical, AI or computational model into practice requires specification of some of the following

input schema and acceptable acquisition range;
automated quality-control checks;
abstention and escalation criteria;
latency and availability requirements;
logging of model/version/input/output/action;
drift and subgroup monitoring;
delayed outcome linkage;
alert thresholds and responsible owners;
rollback procedure;
recalibration/retraining triggers;
validation required after an update.

Monitoring only the output distribution is inadequate. A stable prediction rate can hide compensating changes in prevalence and model error. If the population becomes sicker (prevalence rises) but the model simultaneously degrades (predicts lower probabilities for all cases), the output distribution may look identical while error skyrockets. Monitor input drift, output drift, and outcome drift separately.

When labels arrive late, proxy monitoring should be explicitly distinguished from performance monitoring.

A continuously changing model creates a moving medical intervention. Versioning, change control, and post-update validation are scientific requirements.

12.10 Reporting and risk-of-bias frameworks

Several complementary frameworks organize transparent reporting and evaluation.

Framework	Scope	Key Focus
CLAIM	Medical imaging AI	Image acquisition, segmentation, annotation
TRIPOD+AI	Prediction models	Development, validation, calibration
PROBAST+AI	Risk of bias	Participants, predictors, outcome, analysis
DECIDE-AI	Early clinical evaluation	Human-AI interaction, workflow
SPIRIT-AI	Trial protocols	AI intervention specification
CONSORT-AI	Trial reports	Randomization, blinding, AI failures

Rigorous scientific articles, or technical manuscripts, should still explain the basic scientific rationale, not merely state checklist compliance. Report cohort flow, missingness, exclusions, sample sizes at every stage, model specification, all data-dependent decisions, uncertainty, failure cases, and access to code/model/data when permitted.

12.11 A compact model card for biomedical imaging

A model card can include:

model name, version, date, and owner;
intended use and prohibited uses;
target population and decision point;
inputs, acquisition constraints, and preprocessing;
output meaning, units, threshold, and uncertainty;
development and validation cohorts;
performance with intervals, calibration, and subgroups;
known failure modes and unsupported inputs;
privacy, security, and governance controls;
monitoring, update, and retirement plan.

The card is a concise interface to deeper documentation, not a replacement for it.

Interactive Exploration: Model Card Builder

Here is an app filling out a model card for the KiTS malignancy classifier. Fill in each section and generate a formatted summary. The exercise reveals how many decisions in a machine-learning pipeline are undocumented in a typical paper.

library(shiny)

ui <- fluidPage(
  titlePanel("Model Card Builder: KiTS Malignancy Classifier"),
  sidebarLayout(
    sidebarPanel(
      h4("Fill in each section:"),
      textInput("card_name", "1. Model name:", "KiTS Malignancy Classifier v1.0"),
      textInput("card_owner", "Owner:", ""),
      textInput("card_use", "2. Intended use:", ""),
      textInput("card_prohibit", "Prohibited uses:", ""),
      textInput("card_pop", "3. Target population:", ""),
      textInput("card_input", "4. Inputs & preprocessing:", ""),
      textInput("card_output", "5. Output & threshold:", ""),
      textInput("card_cohort", "6. Development cohort:", ""),
      textInput("card_perf", "7. Performance summary:", ""),
      textInput("card_failures", "8. Known failure modes:", ""),
      textInput("card_privacy", "9. Privacy & governance:", ""),
      textInput("card_monitor", "10. Monitoring plan:", ""),
      actionButton("generate", "Generate Model Card")
    ),
    mainPanel(
      tabsetPanel(
        tabPanel("Generated Card", verbatimTextOutput("cardOutput")),
        tabPanel("Template", verbatimTextOutput("template"))
      )
    )
  )
)

server <- function(input, output, session) {
  
  card <- eventReactive(input$generate, {
    paste0(
      "========================================\n",
      "       MODEL CARD: ", input$card_name, "\n",
      "========================================\n\n",
      "1. MODEL INFORMATION\n",
      "   Name: ", input$card_name, "\n",
      "   Owner: ", input$card_owner, "\n",
      "   Version: 1.0\n",
      "   Date: ", format(Sys.Date(), "%Y-%m-%d"), "\n\n",
      "2. INTENDED USE\n",
      "   Use case: ", input$card_use, "\n",
      "   Prohibited: ", input$card_prohibit, "\n\n",
      "3. TARGET POPULATION\n",
      "   ", input$card_pop, "\n\n",
      "4. INPUTS & PREPROCESSING\n",
      "   ", input$card_input, "\n\n",
      "5. OUTPUT\n",
      "   ", input$card_output, "\n\n",
      "6. DEVELOPMENT & VALIDATION\n",
      "   ", input$card_cohort, "\n\n",
      "7. PERFORMANCE\n",
      "   ", input$card_perf, "\n\n",
      "8. KNOWN FAILURE MODES\n",
      "   ", input$card_failures, "\n\n",
      "9. PRIVACY & GOVERNANCE\n",
      "   ", input$card_privacy, "\n\n",
      "10. MONITORING & UPDATE PLAN\n",
      "   ", input$card_monitor, "\n\n",
      "========================================\n",
      "This card is a summary. Full documentation\n",
      "including code, data splits, and validation\n",
      "logs must be maintained separately.\n",
      "========================================\n"
    )
  })
  
  output$cardOutput <- renderText({ card() })
  
  output$template <- renderText({
    paste0(
      "MODEL CARD TEMPLATE\n",
      "====================\n\n",
      "1. Model name, version, date, owner\n",
      "2. Intended use and prohibited uses\n",
      "3. Target population and decision point\n",
      "4. Inputs, acquisition constraints, preprocessing\n",
      "5. Output meaning, units, threshold, uncertainty\n",
      "6. Development and validation cohorts\n",
      "7. Performance: AUC (95% CI), calibration, subgroups\n",
      "8. Known failure modes and unsupported inputs\n",
      "9. Privacy, security, governance controls\n",
      "10. Monitoring, update, retirement plan\n\n",
      "Key questions to ask:\n",
      "- What scanner/protocol was the model trained on?\n",
      "- What happens if the input is out-of-distribution?\n",
      "- How often is the model retrained?\n",
      "- Who is notified when performance degrades?\n",
      "- What is the rollback procedure?\n"
    )
  })
}

shinyApp(ui, server)

Try it yourself. Fill out the model card for the KiTS classifier. Pay special attention to: 1. Known failure modes: What inputs should the model reject? (Hint: non-contrast CT, different scanner vendor, post-nephrectomy scans). 2. Performance summary: Should you report the internal or external AUC? What about the calibration slope? 3. Monitoring plan: How will you detect drift if labels arrive 6 months late? 4. Prohibited uses: Can this model be used for screening? Why or why not?

13. Reproducible Computational Practice and Capstone Project

13.1 A project structure that separates data, code, and results

chapter08_project/
|-- README.md
|-- renv.lock
|-- config/
|   `-- analysis.yml
|-- data/
|   |-- raw/              # immutable; access controlled
|   |-- interim/          # converted and QC-annotated
|   `-- derived/          # feature tables and partitions
|-- manifests/
|   |-- cohort.csv
|   |-- images.csv
|   `-- checksums.txt
|-- R/
|   |-- io.R
|   |-- qc.R
|   |-- features.R
|   |-- modeling.R
|   `-- evaluation.R
|-- models/
|-- reports/
|-- tests/
`-- BPAD2_Chapter08_DataModeling_AI_ML.Rmd

Raw data should be immutable. Derived files should be reconstructible from code, configuration, and a manifest. Access-controlled data must not be copied into public repositories.

13.2 Configuration, random seeds, and provenance

analysis_config <- list(
  project            = "BPAD2 Chapter 8 -- real KiTS19 kidney CT study",
  data_source        = "KiTS19 public release (kits.json + reference segmentations)",
  data_url           = KITS_METADATA_URL,
  n_cases_clinical   = nrow(kidney),
  n_cases_imaging    = if (have_imaging) nrow(imaging_features) else 0L,
  intensity_source   = img_src$source,
  seed               = 2026,
  prediction_time    = "preoperative",
  primary_outcome    = "malignant pathology",
  positive_class     = "malignant",
  external_stratum   = "thin-slice acquisitions (z spacing <= 1 mm)",
  resampling_folds   = 5,
  selected_threshold = selected_threshold,
  feature_definition = "teaching implementation; not IBSI-certified"
)
str(analysis_config)

## List of 14
##  $ project           : chr "BPAD2 Chapter 8 -- real KiTS19 kidney CT study"
##  $ data_source       : chr "KiTS19 public release (kits.json + reference segmentations)"
##  $ data_url          : chr "https://raw.githubusercontent.com/neheller/kits19/master/data/kits.json"
##  $ n_cases_clinical  : int 210
##  $ n_cases_imaging   : int 30
##  $ intensity_source  : chr "openly distributed reference MRI volume"
##  $ seed              : num 2026
##  $ prediction_time   : chr "preoperative"
##  $ primary_outcome   : chr "malignant pathology"
##  $ positive_class    : chr "malignant"
##  $ external_stratum  : chr "thin-slice acquisitions (z spacing <= 1 mm)"
##  $ resampling_folds  : num 5
##  $ selected_threshold: num 0.84
##  $ feature_definition: chr "teaching implementation; not IBSI-certified"

A random seed controls pseudorandom operations but does not guarantee identical results across software versions, hardware, parallel execution, or nondeterministic GPU kernels. Record package versions, operating system, hardware, and numerical precision.

R.version.string

## [1] "R version 4.3.3 (2024-02-29 ucrt)"

sessionInfo()

## R version 4.3.3 (2024-02-29 ucrt)
## Platform: x86_64-w64-mingw32/x64 (64-bit)
## Running under: Windows 11 x64 (build 26200)
## 
## Matrix products: default
## 
## 
## locale:
## [1] LC_COLLATE=English_United States.utf8 
## [2] LC_CTYPE=English_United States.utf8   
## [3] LC_MONETARY=English_United States.utf8
## [4] LC_NUMERIC=C                          
## [5] LC_TIME=English_United States.utf8    
## 
## time zone: America/New_York
## tzcode source: internal
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## other attached packages:
##  [1] knitr_1.51        dendextend_1.17.1 cluster_2.1.6     survival_3.7-0   
##  [5] pROC_1.18.5       bootstrap_2019.6  caret_6.0-94      lattice_0.22-6   
##  [9] glmnet_4.1-8      Matrix_1.6-5      shiny_1.8.1.1     patchwork_1.3.0  
## [13] DiagrammeR_1.0.11 car_3.1-2         carData_3.0-5     ggcorrplot_0.3.0 
## [17] plotly_4.12.0     lubridate_1.9.3   forcats_1.0.0     stringr_1.5.1    
## [21] dplyr_1.1.4       purrr_1.0.2       readr_2.1.5       tidyr_1.3.1      
## [25] tibble_3.2.1      ggplot2_4.0.1     tidyverse_2.0.0  
## 
## loaded via a namespace (and not attached):
##  [1] gridExtra_2.3        rlang_1.1.5          magrittr_2.0.3      
##  [4] otel_0.2.0           e1071_1.7-14         compiler_4.3.3      
##  [7] mgcv_1.9-1           systemfonts_1.1.0    callr_3.7.6         
## [10] vctrs_0.6.5          reshape2_1.4.4       pkgconfig_2.0.3     
## [13] shape_1.4.6.1        fastmap_1.2.0        labeling_0.4.3      
## [16] promises_1.3.2       rmarkdown_2.31       prodlim_2024.06.25  
## [19] tzdb_0.4.0           ps_1.9.0             ragg_1.3.2          
## [22] xfun_0.52            randomForest_4.7-1.1 cachem_1.1.0        
## [25] jsonlite_1.8.9       recipes_1.1.0        later_1.4.1         
## [28] parallel_4.3.3       R6_2.6.1             bslib_0.9.0         
## [31] stringi_1.8.4        RColorBrewer_1.1-3   parallelly_1.37.1   
## [34] rpart_4.1.23         jquerylib_0.1.4      Rcpp_1.0.14         
## [37] bookdown_0.40        iterators_1.0.14     future.apply_1.11.2 
## [40] httpuv_1.6.15        splines_4.3.3        nnet_7.3-19         
## [43] timechange_0.3.0     tidyselect_1.2.1     viridis_0.6.5       
## [46] rstudioapi_0.18.0    abind_1.4-5          yaml_2.3.10         
## [49] timeDate_4032.109    websocket_1.4.1      codetools_0.2-20    
## [52] processx_3.8.6       listenv_0.9.1        plyr_1.8.9          
## [55] withr_3.0.2          S7_0.2.1             evaluate_1.0.3      
## [58] future_1.33.2        proxy_0.4-27         pillar_1.10.1       
## [61] RNifti_1.6.1         foreach_1.5.2        stats4_4.3.3        
## [64] generics_0.1.3       chromote_0.4.0       hms_1.1.3           
## [67] scales_1.4.0         globals_0.16.3       xtable_1.8-4        
## [70] class_7.3-22         glue_1.8.0           lazyeval_0.2.2      
## [73] tools_4.3.3          webshot2_0.1.1       data.table_1.16.4   
## [76] webshot_0.5.5        ModelMetrics_1.2.2.2 gower_1.0.1         
## [79] visNetwork_2.1.2     grid_4.3.3           ipred_0.9-14        
## [82] nlme_3.1-165         cli_3.6.3            textshaping_0.4.0   
## [85] viridisLite_0.4.2    lava_1.8.0           gtable_0.3.6        
## [88] sass_0.4.9           digest_0.6.37        htmlwidgets_1.6.4   
## [91] farver_2.1.2         memoise_2.0.1        htmltools_0.5.8.1   
## [94] lifecycle_1.0.5      hardhat_1.4.0        httr_1.4.7          
## [97] mime_0.12            MASS_7.3-60.0.1

13.3 Assertions and unit tests

## Structural invariants of the pipeline.
stopifnot(
  nrow(X_train) == length(y_train),
  ncol(X_train) == length(classification_predictors),
  all(is.finite(X_train)),
  all(logistic_internal_prob >= 0 & logistic_internal_prob <= 1),
  all(logistic_external_prob >= 0 & logistic_external_prob <= 1),
  !anyDuplicated(kidney$case_id),
  all(!is.na(kidney$partition))
)

## Overlap metrics must satisfy their mathematical definitions.
stopifnot(
  abs(dice_coefficient(TRUE, TRUE) - 1) < 1e-12,
  abs(jaccard_index(TRUE, TRUE) - 1) < 1e-12,
  dice_coefficient(c(TRUE, FALSE), c(FALSE, TRUE)) == 0
)

## The data really are the released KiTS19 records, not a substitute.
stopifnot(
  nrow(kidney) == 210L,
  sum(kidney$malignant) == 192L,
  sum(kidney$event_observed) == 21L
)

## Geometry: a synthetic cube of known size must return its exact volume,
## which validates the spacing arithmetic used on every real mask.
local({
  cube <- array(0L, dim = c(10, 10, 10)); cube[3:7, 3:7, 3:7] <- 2L
  spacing <- c(0.5, 0.5, 2.0)
  expected_cm3 <- 5^3 * prod(spacing) / 1000
  observed_cm3 <- sum(cube == 2L) * prod(spacing) / 1000
  stopifnot(abs(expected_cm3 - observed_cm3) < 1e-12)
})

cat("all chapter unit tests passed\n")

## all chapter unit tests passed

Tests should include known phantoms and benchmark feature values, image-mask alignment, empty masks, single-voxel masks, anisotropic spacing, unexpected labels, missing files, duplicate identifiers, and deterministic preprocessing.

13.4 Learning curves

Learning curves help distinguish high variance from high bias. Repeatedly fit the complete pipeline on increasing numbers of training patients and evaluate on a fixed validation set. The validation set is used diagnostically and cannot then serve as a final test set.

set.seed(914)
training_fractions <- c(0.30, 0.45, 0.60, 0.75, 1.00)
repetitions <- 20
learning_predictors <- c(
  "age_at_nephrectomy", "body_mass_index", "radiographic_size_cm",
  "log_radiographic_size", "gender_male", "ckd_yes"
)
learning_results <- do.call(rbind, lapply(training_fractions, function(frac) {
  replicate_rows <- lapply(seq_len(repetitions), function(rep_id) {
    selected <- unlist(lapply(split(seq_along(y_train), y_train), function(idx) {
      n_take <- max(2, floor(frac * length(idx)))
      sample(idx, min(length(idx), n_take))
    }), use.names = FALSE)
    prep <- fit_numeric_preprocessor(
      kidney_model[train_idx[selected], ], learning_predictors
    )
    x_sub <- apply_numeric_preprocessor(prep,
                                        kidney_model[train_idx[selected], ])
    x_val <- apply_numeric_preprocessor(prep,
                                        kidney_model[internal_test_idx, ])
    fit <- try(suppressWarnings(glm(y ~ ., family = binomial(),
                 data = data.frame(y = y_train[selected], x_sub))), silent = TRUE)
    if (inherits(fit, "try-error")) {
      probability <- rep(mean(y_train[selected]), length(y_internal))
    } else {
      probability <- predict(fit, data.frame(x_val), type = "response")
      probability[!is.finite(probability)] <- mean(y_train[selected])
    }
    data.frame(fraction = frac, repetition = rep_id,
               n_train = length(selected), auc = auc_rank(y_internal, probability),
               brier = mean((probability - y_internal)^2))
  })
  do.call(rbind, replicate_rows)
}))

learning_summary <- aggregate(cbind(auc, brier) ~ fraction + n_train,
                              data = learning_results, FUN = mean)
plot(learning_summary$n_train, learning_summary$auc, type = "b", ylim = c(0, 1),
     xlab = "Training patients", ylab = "Mean internal-validation AUC",
     main = "Illustrative learning curve")

If performance continues to improve steeply, more representative data may help. A flat curve can reflect irreducible noise, insufficient features, label error, or a model mismatch. It does not prove that more data are useless.

13.5 Sensitivity analyses

A credible study examines whether conclusions survive reasonable alternatives:

different segmentation sources or boundary perturbations;
native versus resampled resolution;
fixed bin width versus fixed bin count;
alternative missing-data assumptions;
exclusion of low-quality scans;
site-held-out and time-held-out partitions;
clinically plausible threshold range;
models with and without technical variables;
complete-case versus imputed analysis;
competing-risk versus cause-specific formulation;
alternative reference-standard definitions.

Sensitivity analyses should be prespecified when they could change the primary claim. Post hoc analyses are still useful when labeled as exploratory.

13.6 Minimum reproducible analysis record

For each reported number, preserve:

immutable data identifiers and checksums;
cohort inclusion/exclusion logic;
partition assignments;
source code commit;
environment lock file;
configuration and random seeds;
fitted preprocessing and model objects;
prediction file with case identifiers and model version;
metric code and confidence-interval method;
generated report and execution log.

A table of predictions is often the most valuable audit artifact because all headline metrics can be recomputed from it.

13.7 Capstone: a multimodal renal-mass AI study

Scientific prompt

Using the real KiTS19 release loaded in this chapter, develop and critically evaluate a model that uses preoperative clinical data and CT-derived features to estimate malignant pathology. Then extend the analysis with one secondary aim: segmentation, postoperative renal-function prediction, or censored prognosis.

Work with the full cohort: set bpad.n_mask_cases high enough to process the segmentation volumes you need (all 210 is roughly 170 MB of downloads and about twenty minutes of streaming). Your report must state how many cases contributed to each analysis and why any case was excluded.

The honest-result clause. This cohort is small, heavily imbalanced, and event-poor. A submission that reports a modest AUC with correct uncertainty, a calibration assessment, and a clear statement of what the model cannot support will score higher than one reporting excellent discrimination obtained by leakage, threshold shopping, or silent case exclusion. State negative results plainly, they are also results.

Required deliverables

Clinical specification. Population, decision time, inputs, target, horizon, and proposed action.
Cohort diagram and data dictionary. Include units, missingness, and time availability.
Physics-aware preprocessing. Explain spacing, interpolation, intensity, segmentation, and QC.
Locked evaluation design. Patient-level development, tuning, internal test, and a held-out stratum justified by a real property of the cohort (for example acquisition protocol), not a random split.
Baselines. At least one clinical-only and one simple statistical model.
Candidate model. Radiomics, deep learning, or multimodal fusion with justified complexity.
Evaluation. Discrimination, calibration, uncertainty, clinical utility, subgroup performance, and failure cases.
Sensitivity analysis. At least two upstream or design perturbations.
Reproducibility package. Code, configuration, environment, manifest, and prediction table.
Translation memo. Intended use, contraindications, monitoring, and next prospective study.

Assessment rubric

Dimension	Weight	Evidence of excellence
Scientific and clinical formulation	15%	Clear estimand and prediction time; clinically coherent action
Biomedical physics	15%	Acquisition, sampling, units, noise, and segmentation integrated
Study design	15%	Leakage-free partitions; appropriate reference and censoring
Modeling rigor	15%	Strong baselines; justified complexity; nested tuning
Evaluation	20%	Calibration, intervals, utility, external/subgroup analyses
Reproducibility	10%	Executable pipeline, provenance, tests, immutable predictions
Communication and limitations	10%	Calibrated claims, failures, deployment constraints

Creative extension options

build a segmentation-uncertainty ensemble and propagate it into malignancy risk;
compare a mechanistic tumor-growth feature with a black-box temporal encoder;
simulate a scanner protocol change and design a drift detector;
construct a human-AI reader-study protocol;
evaluate modality dropout when clinical or imaging inputs are missing;
develop a model card and silent-trial monitoring dashboard.

14. Chapter Summary

Biomedical AI is an end-to-end measurement science. The learned predictor is only the last component of a chain that begins with biology, acquisition, reconstruction, sampling, and annotation. Rigorous work therefore combines biomedical physics, statistical learning, clinical study design, and software engineering.

The central principles are:

define the intended use, prediction time, target, and action before fitting;
split at the highest independent unit and preserve a locked external test;
fit every data-adaptive operation on training data only;
express image features in physical units and record computational provenance;
propagate uncertainty from acquisition and segmentation, not only model fitting;
use survival and longitudinal methods when time and censoring matter;
compare flexible models with strong transparent baselines;
evaluate discrimination, calibration, uncertainty, utility, and transportability;
audit shortcuts, subgroup performance, privacy, and human factors;
treat deployment, monitoring, updating, and retirement as part of the scientific protocol.

A model is clinically credible not because it is complex, but because its complete evidence chain is coherent, reproducible, transportable, and useful.

What the real data taught that a simulation could not

This chapter was built on the released KiTS19 records rather than a generated cohort, and several of its most important lessons exist only because the data are real:

Volume is an integral, and the arithmetic can be checked. Summing the measured cross-sectional area profile reproduces the streamed voxel count exactly, and the imaging-derived diameter agrees closely with the radiologist’s recorded size. Those two checks validate the geometry of the whole pipeline before any model is fitted.
A physical scaling law survives contact with real anatomy. Fitting $\log V$ against $\log D$ recovers an exponent near the value $3$ predicted for geometrically similar solids, while the shortfall quantifies real departures from sphericity.
Dice is not a volumetric guarantee. A one-voxel perturbation of a genuine expert contour leaves Dice near $0.94$ but moves the measured area by roughly $12\%$.
Texture is a property of the pipeline as much as the tissue. The same real slice yields systematically different GLCM values as the grey-level discretization changes.
Class imbalance and event scarcity dominate everything downstream. With 192 malignant against 18 benign cases and 21 deaths, confidence intervals are wide, calibration slopes fall well below one, and “treat all” is a serious competitor in decision-curve analysis.
Real records carry semantics that naive parsing destroys. Laboratory values truncated at ">=90", an ischemia time of "not_applicable" determined by the operation performed, and a length of stay of "died_before_discharge" are all information, not noise.
Technical heterogeneity is available for free. Slice thickness spans $0.5$ to $5.0$ mm in this cohort, giving a documented, non-fabricated axis along which to test transportability.

None of these would have appeared in a simulated cohort, because a simulation contains only the structure its author put there.

15. Key Equations

Concept	Equation
Measurement chain	$I=\mathcal R\{\mathcal A(S;A)+N\}$
Prediction	$\widehat y=f_\theta\{g_\phi(I),X_C\}$
Empirical risk	$\widehat R(\theta)=n^{-1}\sum_iL(y_i,f_\theta(x_i))$
Least squares	$\widehat\beta=(X^\top X)^{-1}X^\top y$ when invertible
Logistic model	$\operatorname{logit}(p)=\beta_0+X^\top\beta$
Ridge/lasso	$\widehat R(\beta)+\lambda\\|\beta\\|_q$
Bayes theorem	$P(D\mid +)=P(+\mid D)P(D)/P(+)$
Voxel volume	$v_{\mathrm{vox}}=\Delta_x\Delta_y\Delta_z$
Sphericity	$\Phi=\pi^{1/3}(6V)^{2/3}/A$
PCA/SVD	$X_c=U\Sigma V^\top$
Copula	$F(x)=C\{F_1(x_1),\ldots,F_p(x_p)\}$
Cox model	$h(t\mid X)=h_0(t)e^{X^\top\beta}$
Logistic growth	$dV/dt=rV(1-V/K)$
k-means	$\min\sum_k\sum_{i\in C_k}\\|x_i-\mu_k\\|^2$
Graph Laplacian	$L=D-W$
Convolution	$Y[i,j]=\sum_{u,v}K[u,v]X[i-u,j-v]$
Soft Dice	$(2\sum p_ig_i+\epsilon)/(\sum p_i+\sum g_i+\epsilon)$
Attention	$\operatorname{softmax}(QK^\top/\sqrt{d_k})V$
Brier score	$n^{-1}\sum_i(\widehat p_i-y_i)^2$
Net benefit	$TP/n-(FP/n)p_t/(1-p_t)$
Conformal interval	$[\widehat f(x)-q,\widehat f(x)+q]$

16. Glossary

Aleatoric uncertainty. Outcome variability remaining even if the data-generating distribution were known.

Annotation. Human- or algorithm-generated label, contour, landmark, or measurement used as training information or reference.

Calibration. Agreement between predicted probabilities and observed event frequencies.

Censoring. Partial observation of an event time, commonly because follow-up ends before the event.

Clinical utility. Expected consequences of using predictions to guide an action.

Concept shift. Change in $P(Y\mid X)$ between development and deployment.

Conformal prediction. Distribution-free framework for prediction sets or intervals under exchangeability.

Copula. Multivariate dependence function joining marginal CDFs into a joint CDF.

Covariate shift. Change in the predictor distribution $P(X)$.

Data leakage. Use of information during fitting or evaluation that would be unavailable for a new case at the intended prediction time.

Discrimination. Ability to rank or separate cases with different outcomes.

Domain adaptation. Methods intended to transfer a model across related distributions.

Epistemic uncertainty. Uncertainty about parameters or functions due to limited knowledge or data.

External validation. Evaluation on data meaningfully independent of model development.

Feature. Quantitative input variable, whether measured, engineered, or learned.

Foundation model. Large pretrained model intended to transfer across downstream tasks.

Harmonization. Reduction of unwanted technical variation while attempting to preserve relevant biological variation.

Label shift. Change in outcome prevalence $P(Y)$ under stable $P(X\mid Y)$.

Landmarking. Dynamic prediction from a prespecified time using only history available up to that time.

Model calibration slope. Coefficient of predicted log odds in a calibration model, values below one often indicate overfitting.

Multimodal fusion. Integration of imaging with clinical, molecular, signal, or text information.

Nested cross-validation. Outer resampling for evaluation and inner resampling for tuning.

Radiomics. Standardized high-throughput extraction of quantitative image features.

Reference standard. Procedure used to define the target label or measurement.

Segmentation. Assignment of spatial elements to anatomical or pathological classes.

Self-supervised learning. Representation learning from labels constructed from the data themselves.

Shortcut learning. Reliance on an easy but noncausal correlate, such as site or artifact.

Transportability. Ability to maintain useful performance in a specified target setting.

17. Practice Problems

Hands-on problems with the real kidney cohort

These problems are answered by running code against the data already loaded in this chapter. Each has a checkable numerical answer, so you can verify yourself rather than wait for a key.

H1. Count how many of the 210 patients have a recorded tumor_isup_grade. Fit the Cox model from Section 8.3 with and without that variable. Report the hazard ratio for radiographic_size_cm in both fits and the number of patients actually used in each. How much of the change is attributable to the altered analysis sample rather than to grade itself?

H2. Compute the median and interquartile range of pathologic_size_cm - radiographic_size_cm. Test whether the difference is centred on zero. If preoperative CT systematically under- or over-estimates specimen size, what does that imply for a model trained on radiographic size but validated against pathologic size?

H3. For the processed segmentation volumes, regress log(tumor_volume_cm3) on log(radiographic_size_cm). Report the exponent with a confidence interval and state whether it is consistent with 3. Then repeat using max_bbox_extent_mm as the diameter. Which linear measure better satisfies the geometric scaling law, and why might a radiologist’s caliper differ from a bounding box?

H4. Take one real mask. Dilate it once, twice, and three times, recording Dice and measured volume each time. Plot percentage volume error against Dice. At what Dice value does the volume error exceed 10%? Compare with the Dice thresholds commonly described as “excellent agreement”.

H5. Recompute the GLCM features on a real slice using 8, 16, 32, and 64 grey levels, then rank the four features by how much they change. If two centres used different discretization settings, which features would be least comparable between them?

H6. Split the cohort by acq_group and compute the standardized mean difference for every predictor in classification_predictors. Which predictor shifts most? Now train on thick-slice scans and test on thin-slice scans, and again in the reverse direction. Is the performance drop symmetric? What would asymmetry tell you?

H7. Using the out-of-fold predictions, compute AUC together with a bootstrap 95% confidence interval. Then compute the same interval after removing five randomly chosen benign cases. How much does the interval widen, and what does that say about the reliability of any model comparison in this cohort?

H8. Construct a “cheating” model that includes pathologic_size_cm and tumor_isup_grade as predictors of malignancy. Report its out-of-fold AUC. Explain, with reference to the timeline in Section 4.2, exactly why this number is meaningless for preoperative decision support.

H9. Among patients whose preop_egfr is recorded as ">=90", compute the mean observed egfr_decline and compare it with patients having a numeric baseline. Does the truncated group differ? Propose an analysis that respects the truncation and say what it would cost you.

H10. Fit the malignancy model using only voxel_spacing_z_mm and voxel_spacing_x_mm. Report the out-of-fold AUC of this metadata-only baseline. Interpret any performance above 0.5 in terms of shortcut learning, and design one analysis that would distinguish a technical shortcut from a genuine clinical association.

Basic mathematical and physical bio-modeling problems

A tumor mask contains 18,500 voxels with spacing $(0.8,0.8,3.0)$ mm. Compute physical volume in mm$^3$ and cm$^3$. Explain why reporting only voxel count is inadequate.
Derive the gradient of binary cross-entropy for logistic regression and show that it is $X^\top(p-y)$ up to normalization.
Suppose CT intensity has independent measurement variance $\sigma_I^2$ and a risk score is $g(I)=\exp(aI)$. Use first-order propagation to approximate $\operatorname{Var}\{g(I)\}$.
For a logistic tumor-growth model, derive the time at which $V(t)=K/2$.
Explain how convolution in the image domain relates to multiplication in the Fourier domain. Give one reason small CNN kernels are not normally implemented by a full-image FFT at every layer.
Show why standardizing all patients before cross-validation leaks validation information, even though outcomes are not used.

Study design and preprocessing

A data set contains 120 patients, 360 scans, 18,000 slices, and 900,000 patches. What is the unit for partitioning and why?
Write an intended-use sentence for a model predicting 90-day response from pretreatment PET/CT. Identify any predictors that would constitute temporal leakage.
Distinguish MCAR, MAR, and MNAR using an example involving omitted MRI sequences.
Construct a leakage audit for radiomic feature selection, ComBat harmonization, and threshold tuning.
Explain why KiTS19 and a later KiTS cohort cannot be pooled without release-specific documentation and a new validation design.
Design a phantom experiment to determine whether a texture feature is stable to slice thickness and reconstruction kernel.

Classical and time-dependent modeling

Fit logistic, penalized logistic, and kNN models to the teaching cohort. Use nested resampling to select hyperparameters. Compare calibration as well as AUC.
Create a clinical-only model and an image-only model. Quantify whether multimodal fusion adds value on the site-held-out set.
The disease prevalence changes from 40% in development to 10% in deployment while sensitivity and specificity remain fixed. Derive the new PPV and NPV.
Explain why vital_status alone is insufficient for prognosis when follow-up differs between patients.
Compare a Cox model with a model that predicts five-year status by logistic regression. State the information lost by the latter.
Simulate longitudinal volumes under exponential growth with measurement error. Estimate doubling time and examine bias as the number of scans decreases.

Segmentation and deep learning

Construct two predicted masks with identical Dice scores but different maximum boundary errors. Explain which might be clinically safer.
Vary the gray-level bin count in glcm_features_3d. Plot feature stability and explain why the result belongs in the feature provenance record.
Modify the CT phantom so that tumor and kidney have identical intensity distributions. Test k-means segmentation and explain the failure.
Calculate the receptive field of three consecutive $3\times3$ convolutions with stride one and no dilation.
Propose anatomically valid and invalid augmentations for renal CT, brain MRI, and chest radiography.
Design a self-supervised positive-pair strategy for 3D CT that is unlikely to erase a small lesion.

Evaluation and translation

Bootstrap sensitivity and specificity at the selected threshold. Why can their confidence intervals differ markedly even with the same total test size?
Recalibrate the logistic model using a separate local calibration subset. Compare calibration intercept, slope, Brier score, and AUC before and after recalibration.
Perform a shortcut test using site and scanner metadata only. What conclusions follow if this baseline predicts malignancy well?
Draft a silent prospective study and monitoring plan for deployment of the renal-mass model. Include quality-control failure, abstention, drift, delayed labels, subgroup review, and rollback.

18. Selected Solution Sketches

Hands-on problems

H1. Grade is missing for 38 patients, so the adjusted model silently drops them and the risk set shrinks. Refit on the same complete-case subset without grade to separate the sample effect from the covariate effect and report both comparisons.

H2. The difference is small on average but with wide dispersion, and it is not symmetric across the size range. Training on one measurement and validating against the other imports that disagreement as irreducible error, which caps achievable performance regardless of model class.

H3. The fitted exponent lies near but below 3, and the confidence interval typically includes or approaches 3 at modest sample sizes. A bounding-box extent is an upper bound on any single caliper measurement and is sensitive to orientation, whereas a radiologist measures a chosen axis on a chosen slice.

H4. Volume error grows roughly linearly with the number of dilations while Dice decays slowly, so volume error passes 10% while Dice still looks reassuring. The practical conclusion is that Dice cannot certify a volumetric biomarker.

H5. Contrast and entropy move most with the level count. Homogeneity and energy are comparatively more stable but still not invariant. Cross-centre comparability requires the discretization to be fixed by protocol and reported.

H6. Spacing-related predictors shift most. Asymmetric degradation usually indicates that one direction of transfer requires extrapolation beyond the training feature range, whereas the other is interpolation.

H7. The interval is already wide because the benign class is tiny. Removing a few benign cases widens it further and can reverse model rankings. This is the quantitative argument against declaring a winner from point estimates.

H8. Discrimination rises sharply because pathology is measured on the resected specimen – after the decision the model claims to support. The information does not exist at prediction time, so the estimate is not merely optimistic but undefined for the intended use.

H9. The truncated group starts at or above the reportable ceiling, so their computed decline is bounded below by construction. A tobit or interval-censored formulation respects the bound. The cost is a stronger distributional assumption and a more complex model.

H10. Any AUC meaningfully above 0.5 from spacing alone indicates that protocol correlates with case mix, era, or referral pattern. Distinguishing shortcut from association requires stratified analysis within protocol, or a cohort where protocol is assigned independently of indication.

Hints for basic mathematical and physical problems

Voxel volume is $0.8\times0.8\times3.0=1.92$ mm$^3$. Total volume is $18{,}500\times1.92=35{,}520$ mm$^3=35.52$ cm$^3$. Voxel count changes with sampling.
With $p=\sigma(X\beta)$ and loss $-y\log p-(1-y)\log(1-p)$, the chain rule gives derivative $p-y$ with respect to the linear predictor. Multiplying by $X^\top$ yields the coefficient gradient.
Since $g'(I)=a\exp(aI)$, the delta method gives $\operatorname{Var}\{g(I)\}\approx a^2\exp(2aI)\sigma_I^2$ at the expansion point.
Setting $V=K/2$ gives $1+((K-V_0)/V_0)e^{-rt}=2$, hence $t=r^{-1}\log\{(K-V_0)/V_0\}$.
The convolution theorem maps convolution to pointwise Fourier multiplication. Small spatial kernels exploit optimized local operations, avoid transform overhead, and interact efficiently with batching and channels.
The full-cohort mean and variance depend on held-out observations, so validation cases influence their own representation and the fitted decision rule.
Partition by patient. All scans, slices, and patches from one patient stay together because they are dependent and may be near duplicates.
The sentence must specify population, pretreatment decision time, PET/CT inputs, 90-day response, and action. Post-treatment scans, delivered dose summaries unavailable at baseline, and 90-day laboratory values would leak future information.
MCAR: sequence omitted by random transfer failure. MAR: omission depends on observed age or scanner. MNAR: sequence omitted because unobserved severity made the patient intolerant.
Fit feature selection and harmonization inside each analysis fold. Select thresholds from out-of-fold training predictions. Apply all frozen operations to assessment data.
Releases may differ in cases, annotations, rules, and held-out sets. Pooling can create overlap, invalidate official test restrictions, and erase a natural external-validation opportunity.
Scan a stable phantom across a factorial grid of thickness and kernel and repeat scans. Then use a fixed ROI and estimate repeatability, systematic effects, and interactions with confidence intervals.
The outer folds provide comparison predictions. All tuning and preprocessing occurs in inner folds. AUC alone is insufficient. Compare Brier score and calibration slope.
Fit all three models under identical partitions. Incremental value requires better external performance and calibration, not merely better training fit.
Use Bayes’ theorem: $PPV=Se\pi/[Se\pi+(1-Sp)(1-\pi)]$ and $NPV=Sp(1-\pi)/[(1-Se)\pi+Sp(1-\pi)]$ with $\pi=0.10$.
Alive at last contact may mean one month or ten years of event-free follow-up. A binary status neither represents exposure time nor handles censoring correctly.
Logistic five-year status excludes or misclassifies those censored before five years and discards event timing. Survival models use available follow-up under censoring assumptions.
With sparse noisy scans, the log-volume slope is unstable and can be biased by curvature or selection. Report uncertainty and investigate nonlinear/mixed models.
One mask may have a small distant false-positive island and another a smooth local boundary offset. Dice can match, but Hausdorff distance and clinical implications differ.
Discretization changes the co-occurrence distribution. Stability across justified settings supports robustness. Instability requires standardization or exclusion.
Intensity-only k-means cannot identify anatomy when class-conditional intensities overlap. Spatial context, shape priors, multimodal input, or supervised labels are needed.
The receptive field sizes are $3$, $5$, and $7$ pixels because each stride-one $3\times3$ layer adds two.
Validity depends on anatomy and task. Small in-plane rotations may be valid. Arbitrary left-right flips are invalid when laterality or asymmetric anatomy determines the label.
Use two crops centered on the same lesion with moderate intensity/blur perturbations that preserve lesion voxels. Verify the transformation with the mask during pretraining design.
Sensitivity uses only positive cases and specificity only negative cases. Their effective denominators can differ greatly under imbalance.
Logistic recalibration can change intercept and slope and improve Brier score without changing AUC, because a monotone transformation preserves ranking.
Strong metadata-only performance suggests prevalence/site confounding or workflow shortcuts. It motivates site-held-out testing, artifact audits, and comparison after controlling or redesigning sampling.
A complete plan specifies silent prediction capture, input QC, abstention, human review, drift thresholds, outcome linkage, subgroup intervals, incident ownership, and versioned rollback.

Rmd to HTML Knitting

To compile the Rmd notebook, run the code chunk how-to-run in interactive mode (do not update the setting eval=FALSE).

References

Angelopoulos, A. N., and Bates, S. (2023). Conformal prediction: A gentle introduction. Foundations and Trends in Machine Learning, 16(4), 494–591.

Bishop, C. M. (2006). Pattern Recognition and Machine Learning. Springer.

Collins, G. S., Moons, K. G. M., Dhiman, P., et al. (2024). TRIPOD+AI statement: Updated guidance for reporting clinical prediction models that use regression or machine learning methods. BMJ, 385, e078378. https://doi.org/10.1136/bmj-2023-078378

Goodfellow, I., Bengio, Y., and Courville, A. (2016). Deep Learning. MIT Press.

Guo, C., Pleiss, G., Sun, Y., and Weinberger, K. Q. (2017). On calibration of modern neural networks. In Proceedings of the 34th International Conference on Machine Learning.

Harrell, F. E. (2015). Regression Modeling Strategies (2nd ed.). Springer.

Hastie, T., Tibshirani, R., and Friedman, J. (2009). The Elements of Statistical Learning (2nd ed.). Springer.

Heller, N., Isensee, F., Maier-Hein, K. H., et al. (2021). The state of the art in kidney and kidney tumor segmentation in contrast-enhanced CT imaging: Results of the KiTS19 challenge. Medical Image Analysis, 67, 101821. https://doi.org/10.1016/j.media.2020.101821

Isensee, F., Jaeger, P. F., Kohl, S. A. A., Petersen, J., and Maier-Hein, K. H. (2021). nnU-Net: A self-configuring method for deep learning-based biomedical image segmentation. Nature Methods, 18, 203–211.

James, G., Witten, D., Hastie, T., Tibshirani, R., and Taylor, J. (2023). An Introduction to Statistical Learning: With Applications in Python. Springer.

Liu, X., Rivera, S. C., Moher, D., Calvert, M. J., and Denniston, A. K. (2020). Reporting guidelines for clinical trial reports for interventions involving artificial intelligence: The CONSORT-AI extension. Nature Medicine, 26, 1364–1374. https://doi.org/10.1038/s41591-020-1034-x

Lundberg, S. M., and Lee, S.-I. (2017). A unified approach to interpreting model predictions. In Advances in Neural Information Processing Systems 30.

Mongan, J., Moy, L., and Kahn, C. E. Jr. (2020). Checklist for Artificial Intelligence in Medical Imaging (CLAIM): A guide for authors and reviewers. Radiology: Artificial Intelligence, 2(2), e200029.

Moons, K. G. M., Damen, J. A. A. G., Kaul, T., et al. (2025). PROBAST+AI: An updated quality, risk-of-bias, and applicability assessment tool for prediction models using regression or artificial intelligence methods. BMJ, 388, e082505. https://doi.org/10.1136/bmj-2024-082505

Pearl, J. (2009). Causality: Models, Reasoning, and Inference (2nd ed.). Cambridge University Press.

Ribeiro, M. T., Singh, S., and Guestrin, C. (2016). “Why should I trust you?” Explaining the predictions of any classifier. In Proceedings of KDD 2016.

Rivera, S. C., Liu, X., Chan, A.-W., Denniston, A. K., and Calvert, M. J. (2020). Guidelines for clinical trial protocols for interventions involving artificial intelligence: The SPIRIT-AI extension. Nature Medicine, 26, 1351–1363. https://doi.org/10.1038/s41591-020-1037-7

Ronneberger, O., Fischer, P., and Brox, T. (2015). U-Net: Convolutional networks for biomedical image segmentation. In Medical Image Computing and Computer-Assisted Intervention (MICCAI), 234–241.

Steyerberg, E. W. (2019). Clinical Prediction Models (2nd ed.). Springer.

Tejani, A. S., Klontzas, M. E., Gatti, A. A., et al. (2024). Checklist for Artificial Intelligence in Medical Imaging (CLAIM): 2024 update. Radiology: Artificial Intelligence, 6, e240300. https://doi.org/10.1148/ryai.240300

Van Calster, B., McLernon, D. J., van Smeden, M., Wynants, L., and Steyerberg, E. W. (2019). Calibration: The Achilles heel of predictive analytics. BMC Medicine, 17, 230.

Vasey, B., Nagendran, M., Campbell, B., et al. (2022). Reporting guideline for the early-stage clinical evaluation of decision support systems driven by artificial intelligence: DECIDE-AI. Nature Medicine, 28, 924–933. https://doi.org/10.1038/s41591-022-01772-9

Vovk, V., Gammerman, A., and Shafer, G. (2005). Algorithmic Learning in a Random World. Springer.

Whybra, P., Parkinson, C., Foley, K., Staffurth, J., and Spezi, E. (2024). The Image Biomarker Standardization Initiative: Standardized convolutional filters for reproducible radiomics and enhanced clinical insights. Radiology, 310, e231319. https://doi.org/10.1148/radiol.231319

Zwanenburg, A., Vallières, M., Abdalah, M. A., et al. (2020). The Image Biomarker Standardization Initiative: Standardized quantitative radiomics for high-throughput image-based phenotyping. Radiology, 295, 328–338. https://doi.org/10.1148/radiol.2020191145

Chapter 1 foundation	Role in Chapter 8	Biomedical-imaging example
Vectors, matrices, tensors	Patients-by-features matrices and voxel arrays	\(X\in\mathbb{R}^{n\times p}\); CT volume \(I\in\mathbb{R}^{n_x\times n_y\times n_z}\)
Eigenvalues and SVD	PCA, low-rank representations, graph Laplacians	Compress correlated radiomic features
Probability and Bayes’ theorem	Likelihood, posterior risk, prevalence dependence	Convert sensitivity and specificity into post-test probability
Derivatives and optimization	Gradient descent and backpropagation	Train regression models and neural networks
Convolution and Fourier analysis	Learned spatial filters in CNNs	Detect edges, textures, organs, and tumors
ODEs and nonlinear models	Longitudinal imaging biomarkers	Estimate tumor growth rate and carrying capacity
Error propagation	Feature robustness and predictive uncertainty	Quantify the effect of a one-voxel boundary perturbation
Sampling and aliasing	Resolution, resampling, and domain shift	Explain why voxel spacing changes texture features
Noise models and SNR	Likelihoods, augmentation, robustness	Contrast CT, PET, and MRI measurement variability

Task/model	Loss	Typical penalty
Linear regression	\((y-\widehat y)^2\)	none, ridge, lasso
Logistic regression	binary cross-entropy	none, ridge, lasso
SVM	hinge loss	squared norm
Neural classifier	cross-entropy	weight decay, augmentation
Segmentation network	cross-entropy, Dice, or both	weight decay, augmentation

Concept	Equation
Measurement chain	\(I=\mathcal R\{\mathcal A(S;A)+N\}\)
Prediction	\(\widehat y=f_\theta\{g_\phi(I),X_C\}\)
Empirical risk	\(\widehat R(\theta)=n^{-1}\sum_iL(y_i,f_\theta(x_i))\)
Least squares	\(\widehat\beta=(X^\top X)^{-1}X^\top y\) when invertible
Logistic model	\(\operatorname{logit}(p)=\beta_0+X^\top\beta\)
Ridge/lasso	\(\widehat R(\beta)+\lambda\\|\beta\\|_q\)
Bayes theorem	\(P(D\mid +)=P(+\mid D)P(D)/P(+)\)
Voxel volume	\(v_{\mathrm{vox}}=\Delta_x\Delta_y\Delta_z\)
Sphericity	\(\Phi=\pi^{1/3}(6V)^{2/3}/A\)
PCA/SVD	\(X_c=U\Sigma V^\top\)
Copula	\(F(x)=C\{F_1(x_1),\ldots,F_p(x_p)\}\)
Cox model	\(h(t\mid X)=h_0(t)e^{X^\top\beta}\)
Logistic growth	\(dV/dt=rV(1-V/K)\)
k-means	\(\min\sum_k\sum_{i\in C_k}\\|x_i-\mu_k\\|^2\)
Graph Laplacian	\(L=D-W\)
Convolution	\(Y[i,j]=\sum_{u,v}K[u,v]X[i-u,j-v]\)
Soft Dice	\((2\sum p_ig_i+\epsilon)/(\sum p_i+\sum g_i+\epsilon)\)
Attention	\(\operatorname{softmax}(QK^\top/\sqrt{d_k})V\)
Brier score	\(n^{-1}\sum_i(\widehat p_i-y_i)^2\)
Net benefit	\(TP/n-(FP/n)p_t/(1-p_t)\)
Conformal interval	\([\widehat f(x)-q,\widehat f(x)+q]\)

Biomedical Physics with Applications to Disease (BPAD2)

Chapter 8: Data Modeling, Artificial Intelligence, and Biomedical Applications

Magdalena I. Ivanova, Ivo D. Dinov (BPAD Team + SOCR)

August 07, 2026

Chapter 8: Data Modeling, AI, and Machine Learning in Biomedical Image Analysis

Overview, Motivation, and Learning Objectives

Relevance to biomedical physics curriculum

Kidney case-study

Mathematical bridges from Chapter 1

Learning objectives

A two-track reading plan

Computational aspects

Running Interactive Demonstrations with RShiny Apps

Method A: Embedding via Quarto

Method B: Embedding in Standard R Markdown (.Rmd) via iframe

Install shinylive if needed

1. From Physical Measurement to a Learning Problem

1.1 A compositional model of the imaging-AI chain

1.2 Units of observation and hierarchical dependence

1.3 Prediction target, intended use, and action

1.4 Supervised, unsupervised, semi-supervised, and self-supervised learning

1.5 Mechanistic, statistical, predictive, and causal models

2. Mathematical Foundations of Statistical Learning

2.1 Design matrices and parameterized prediction rules

2.2 Empirical risk minimization

2.3 Least squares, likelihood, and matrix geometry

2.4 Logistic regression and cross-entropy

2.5 Regularization: ridge, lasso, and elastic net

2.6 Optimization and gradient descent

2.7 Bias, variance, and irreducible noise

2.8 Bayes’ theorem, prevalence, and clinical interpretation

2.9 Measurement error and uncertainty propagation

2.10 Imaging noise models, likelihoods, SNR, and CNR

2.11 Basis expansions, transformations, and nonlinear relationships

3. Study Design Before Model Fitting

3.1 Define the estimand, target population, and unit of analysis

3.2 Outcome and reference-standard design

3.3 Missing data and informative observation

3.4 Censoring, truncation, and competing events

3.5 Development, tuning, internal testing, and external testing

3.6 Leakage: a pipeline property, not only a variable property

3.7 Sample size, events, dimensionality, and learning curves

4. Running Case Study: Kidney Tumor CT, Clinical Data, and Outcomes

4.1 Kidney CT Overview

4.2 Case-level data dictionary

4.3 Loading the real KiTS19 cohort

4.4 Data-quality control (QC)

4.5 Exploratory data analysis (EDA)

4.6 Locking development and external test roles

5. From CT Volumes and Masks to Quantitative Features

5.1 Image tensors, coordinates, and segmentation labels

5.2 Reading a real NIfTI volume from first principles

5.3 First-order intensity features

5.4 Shape features in physical units

5.5 Texture features and discretization

5.6 Propagating segmentation uncertainty

5.7 Joining imaging and clinical tables safely

5.8 Real intensity volumes: first-order and texture radiomics

5.9 Sampling, resampling, interpolation, and aliasing

5.10 Feature provenance and standardization

6. Exploratory Structure, Preprocessing, and Representation

6.1 Feature engineering with physical meaning

6.2 Training-only imputation and standardization

6.3 Correlation, Redundancy, and Collinearity in Kidney Imaging Features

Results Interpretation

6.4 PCA as SVD of the Feature Matrix

Mathematical Foundation

Covariance vs. Correlation Matrix

Example

Results Interpretation

Try It Yourself: Scaling Experiment

Projecting New Data into PCA Space

Connection to Feature Selection and Modeling

6.5 High-dimensional radiomics and the \(p\gg n\) regime

Interactive Exploration: Feature Selection in High-Dimensional Radiomics

Learning Instructions

Questions

\(p \gg n\) Radiomics (More Variables than Cases)

6.6 Copulas: dependence separated from marginal distributions

Interactive Exploration: Invariance of Copulas

Running Interactive Demonstrations with `RShiny` Apps

Method A: Embedding via `Quarto`

Method B: Embedding in Standard `R` Markdown (.Rmd) via `iframe`