{"slug": "royston-parmar-model", "title": "Royston-Parmar Model", "summary": "A developer demonstrated the utility of Royston-Parmar (RP) models for causal inference in survival analysis, particularly in scenarios with non-proportional hazards where Cox proportional hazards models fail. The code, created with assistance from Google Gemini and reviewed by RB, simulates data with a hazard switch and calculates restricted mean survival time (RMST) to show the flexibility of RP models.", "body_md": "| # Title: Royston-Parmar Models for Causal Inference | |\n| # Description: RP models can be very useful for causal inference. The goal of this code is to | |\n| # demonstrate why they can be so useful. | |\n| # This example uses a non-proportional hazard, to demonstrate how they can be useful | |\n| # and how they are flexible. In this case, where a Cox PH model would fail. | |\n| # Additionally, the restricted mean survival time (RMST) is calculated to demonstrate this | |\n| # Note: This code was created with the help of Google Gemini, and reviewed by me (RB) | |\n| # Setup ---- | |\n| #... Packages ---- | |\n| library(tidyverse) # ol faithful | |\n| library(flexsurv) # flexsurvspline() | |\n| library(survival) # Surv(), survfit() | |\n| library(patchwork) # combining plots | |\n| # Simulate Data ---- | |\n| # Here we want to simulate data to demonstrate non-proportional hazards. | |\n| # Note: here we are not using any confounders. | |\n| set.seed(2028) # setting seed for reproducibility | |\n| n <- 800 # sample size (arbitrary) | |\n| group <- rbinom(n, 1, 0.5) # which group (only 2 for this example) | |\n| tau_switch <- 0.5 # Hazard switch at 6 months | |\n| h0_early <- 0.20 | |\n| h0_late <- 0.40 | |\n| b_early <- 1.2 # log(HR = 3.3) -> High early harm | |\n| b_late <- -1.8 # log(HR = 0.16) -> High late benefit | |\n| lp_early <- b_early * group | |\n| lp_late <- b_late * group | |\n| # Simulating the parts needed to estimate the event time. Once we | |\n| # have the event time, we can know if it was observed, or if it was censored. | |\n| u <- runif(n) | |\n| neglogu <- -log(u) | |\n| H_at_switch <- h0_early * exp(lp_early) * tau_switch | |\n| event_time <- ifelse( | |\n| neglogu <= H_at_switch, | |\n| neglogu / (h0_early * exp(lp_early)), | |\n| tau_switch + (neglogu - H_at_switch) / (h0_late * exp(lp_late)) | |\n| ) | |\n| # Based on the event time, we determine if a patient was censored or not. | |\n| # Note: there is another way to do this using the simsurv package, which | |\n| # makes simulating survival data much easier. | |\n| time_obs <- pmin(event_time, 5, rexp(n, 0.05)) | |\n| status <- as.numeric(event_time == time_obs) | |\n| dat <- data.frame(time = time_obs, status = status, group = factor(group, labels = c(\"Standard\", \"New Rx\"))) | |\n| # True RMST Difference ---- | |\n| # Note: there is a section at the end of this code titled \"Bonus: Calculate RMST\" | |\n| # that can be used to get this value. For now, we will use this. | |\n| # \"True\" RMST (based on our simulated data) | |\n| true_pop_diff <- 0.48717 | |\n| # Fitting Models ---- | |\n| # We will use 4 years as the cutoff for RMST | |\n| tau_eval <- 4.0 # cutoff for RMST | |\n| t_grid <- seq(0.001, tau_eval, length.out = 300) | |\n| #... Kaplan-Meier ---- | |\n| km_fit <- survfit(Surv(time, status) ~ group, data = dat) | |\n| #... Royston-Parmar Model (Flexible Spline) ---- | |\n| # Here we are using the flexsurvspline() function to fit an RP model. | |\n| # The k is the number of knots used. Here we used 3 but we can use different numbers | |\n| # depending on our data and model fit. Additionally, we do this on the hazard scale but can be | |\n| # on other scales as well (i.e. odds, or normal) | |\n| # Royston-Parmar Model (Flexible Spline) | |\n| rp_nonph <- flexsurvspline( | |\n| Surv(time, status) ~ group, | |\n| data = dat, | |\n| k = 3, | |\n| scale = \"hazard\", | |\n| anc = list(gamma1 = ~ group) | |\n| ) | |\n| # Getting Results from the Models ---- | |\n| #.. RP model results ---- | |\n| rp_rmst_res <- summary(rp_nonph, | |\n| newdata = data.frame(group = levels(dat$group)), | |\n| type = \"rmst\", | |\n| t = tau_eval, | |\n| ci = TRUE) | |\n| # Getting the point estimate and standard error | |\n| # For the control group | |\n| est_std_rp <- rp_rmst_res[[1]]$est[1] | |\n| se_std_rp <- (rp_rmst_res[[1]]$ucl[1] - rp_rmst_res[[1]]$lcl[1]) / (2 * 1.96) | |\n| # For the \"Rx\" group | |\n| est_rx_rp <- rp_rmst_res[[2]]$est[1] | |\n| se_rx_rp <- (rp_rmst_res[[2]]$ucl[1] - rp_rmst_res[[2]]$lcl[1]) / (2 * 1.96) | |\n| # Calculating the difference and 95% confidence interval | |\n| diff_rp <- as.numeric(est_rx_rp - est_std_rp) | |\n| se_rp_diff <- as.numeric(sqrt(se_std_rp^2 + se_rx_rp^2)) | |\n| lcl_rp <- diff_rp - 1.96 * se_rp_diff | |\n| ucl_rp <- diff_rp + 1.96 * se_rp_diff | |\n| #... Format Annotation for Later ---- | |\n| # Formatted annotation string for plot | |\n| rmst_annotation <- sprintf( | |\n| \"Mean Survival Benefit (Δ RMST at τ = %.1fy):\\n • RP Model: %+.2f yrs [95%% CI: %+.2f, %+.2f]\\n • True RMST: %+.2f yrs\", | |\n| tau_eval, diff_rp, lcl_rp, ucl_rp, true_pop_diff | |\n| ) | |\n| # Plots ---- | |\n| #... Setting up aesthetics ---- | |\n| # Creating a theme that can be used across both plots. | |\n| theme_pub <- function() { | |\n| theme_minimal(base_size = 18) + | |\n| theme( | |\n| plot.title = element_text(face = \"bold\", size = 18, hjust = 0), | |\n| plot.subtitle = element_text(color = \"grey30\", size = 16, margin = margin(b = 6)), | |\n| legend.position = \"top\", | |\n| text = element_text(size = 16), | |\n| legend.title = element_blank(), | |\n| panel.grid.minor = element_blank(), | |\n| axis.title = element_text(face = \"bold\", size = 14) | |\n| ) | |\n| } | |\n| # Setting the colors | |\n| cols <- c(\"Standard\" = \"#2b5c8f\", \"New Rx\" = \"#d95f02\") | |\n| #... Plot A: Hazards over Time ---- | |\n| # Getting the hazard over time, to plot. This shows how it is non-proportional. | |\n| df_true_haz <- data.frame( | |\n| time = rep(t_grid, 2), | |\n| group = rep(c(\"Standard\", \"New Rx\"), each = length(t_grid)) | |\n| ) %>% | |\n| mutate( | |\n| haz = case_when( | |\n| group == \"Standard\" & time <= tau_switch ~ h0_early, | |\n| group == \"Standard\" & time > tau_switch ~ h0_late, | |\n| group == \"New Rx\" & time <= tau_switch ~ h0_early * exp(b_early), | |\n| group == \"New Rx\" & time > tau_switch ~ h0_late * exp(b_late) | |\n| ) | |\n| ) | |\n| # Creating the plot. | |\n| p_hazards <- ggplot(df_true_haz, aes(x = time, y = haz, color = group)) + | |\n| geom_step(size = 1.1) + | |\n| geom_vline(xintercept = tau_switch, linetype = \"dashed\", color = \"grey40\") + | |\n| annotate(\"text\", x = tau_switch + 0.1, y = max(df_true_haz$haz) * 0.88, | |\n| label = \"True Hazard Switch\\n(Early Harm, Late Benefit)\", | |\n| hjust = 0, size = 5, fontface = \"bold.italic\", color = \"firebrick\") + | |\n| scale_color_manual(values = cols) + | |\n| scale_y_continuous(limits = c(0, max(df_true_haz$haz) * 1.05)) + | |\n| labs( | |\n| title = \"A. Hazards over Time\", | |\n| subtitle = \"Hazards over time (non-proportional hazards)\", | |\n| x = \"Time (Years)\", | |\n| y = \"Hazard Rate h(t)\" | |\n| ) + | |\n| theme_pub() | |\n| #... Plot B: Survival Curves ---- | |\n| # This has the Kaplan-Meier curves, and the RP models. Additionally it also has the | |\n| # estimated RMST, and the \"true\" RMST. | |\n| # Kaplan-Meier ---- | |\n| km_df <- data.frame( | |\n| time = summary(km_fit)$time, | |\n| surv = summary(km_fit)$surv, | |\n| group = gsub(\"group=\", \"\", summary(km_fit)$strata) | |\n| ) | |\n| #... RP model ---- | |\n| rp_surv_obj <- summary(rp_nonph, newdata = data.frame(group = levels(dat$group)), t = t_grid, type = \"survival\", ci = TRUE) | |\n| df_rp_surv <- bind_rows( | |\n| rp_surv_obj[[1]] %>% mutate(group = \"Standard\"), | |\n| rp_surv_obj[[2]] %>% mutate(group = \"New Rx\") | |\n| ) | |\n| #... Creating Plot ---- | |\n| p_survival <- ggplot() + | |\n| # Raw empirical KM steps | |\n| geom_step(data = km_df, aes(x = time, y = surv, color = group), alpha = 0.35, size = 0.8) + | |\n| # RP Model fit with 95% CI ribbons | |\n| geom_ribbon(data = df_rp_surv, aes(x = time, ymin = lcl, ymax = ucl, fill = group), alpha = 0.18) + | |\n| geom_line(data = df_rp_surv, aes(x = time, y = est, color = group), size = 1.1) + | |\n| # Text Box Annotation Card in Lower Left | |\n| annotate( | |\n| \"label\", | |\n| x = 0.15, y = 0.08, | |\n| label = rmst_annotation, | |\n| hjust = 0, vjust = 0, | |\n| fill = \"#f8f9fa\", color = \"#1a1a1a\", | |\n| fontface = \"bold\", size = 5, | |\n| label.padding = unit(0.5, \"lines\"), | |\n| label.size = 0.3 | |\n| ) + | |\n| scale_color_manual(values = cols) + | |\n| scale_fill_manual(values = cols) + | |\n| scale_y_continuous(limits = c(0, 1), labels = scales::percent) + | |\n| labs( | |\n| title = \"B. Survival Curves and Royston-Parmar Model\", | |\n| subtitle = \"Solid lines (RP spline model) track empirical KM steps\", | |\n| x = \"Time (Years)\", | |\n| y = \"Survival S(t)\" | |\n| ) + | |\n| theme_pub() | |\n| # Combine Plots! ---- | |\n| final_dashboard <- p_hazards | p_survival | |\n| print(final_dashboard) | |\n| # Bonus: Calculating the RMST! ---- | |\n| # For this example, the \"true\" RMST is difficult to see. To do this, we need to | |\n| # integrate to get the area under the curves, and the difference. The below code | |\n| # (with the help of Google Gemini, does that) | |\n| # Closed-form formula for integral of piecewise survival S(t) from 0 to tau | |\n| calc_true_rmst <- function(h_early, h_late, t_switch = 0.5, tau = 4.0) { | |\n| # Piece 1: Area under S(t) from t = 0 to t = t_switch | |\n| area_1 <- (1 - exp(-h_early * t_switch)) / h_early | |\n| # Survival probability at the switch point S(t_switch) | |\n| s_switch <- exp(-h_early * t_switch) | |\n| # Piece 2: Area under S(t) from t = t_switch to t = tau | |\n| area_2 <- s_switch * (1 - exp(-h_late * (tau - t_switch))) / h_late | |\n| return(area_1 + area_2) | |\n| } | |\n| # 1. Calculate true rates for both groups | |\n| h_std_early <- h0_early | |\n| h_std_late <- h0_late | |\n| h_rx_early <- h0_early * exp(b_early) | |\n| h_rx_late <- h0_late * exp(b_late) | |\n| # 2. Compute exact RMSTs at tau = 4.0 | |\n| true_rmst_std <- calc_true_rmst(h_std_early, h_std_late, tau_switch, tau_eval) | |\n| true_rmst_rx <- calc_true_rmst(h_rx_early, h_rx_late, tau_switch, tau_eval) | |\n| exact_diff_pop <- true_rmst_rx - true_rmst_std | |\n| # 3. Print Results to Console | |\n| cat(\"\\n=================================================================\\n\") | |\n| cat(sprintf(\" EXACT POPULATION TRUTH AT TAU = %.1f YEARS \\n\", tau_eval)) | |\n| cat(\"=================================================================\\n\") | |\n| cat(sprintf(\"Standard Group RMST: %.5f years (%.2f months)\\n\", true_rmst_std, true_rmst_std * 12)) | |\n| cat(sprintf(\"New Rx Group RMST: %.5f years (%.2f months)\\n\", true_rmst_rx, true_rmst_rx * 12)) | |\n| cat(\"-----------------------------------------------------------------\\n\") | |\n| cat(sprintf(\"True RMST Gain (Δ): %+.5f years (%+.2f months)\\n\", exact_diff_pop, exact_diff_pop * 12)) | |\n| cat(\"=================================================================\\n\\n\") |", "url": "https://wpnews.pro/news/royston-parmar-model", "canonical_source": "https://gist.github.com/battenr/df9ffbef8d32d6ca822fb8811e72eaf7", "published_at": "2026-07-27 16:15:31+00:00", "updated_at": "2026-08-02 23:59:07.488884+00:00", "lang": "en", "topics": ["machine-learning", "developer-tools"], "entities": ["Royston-Parmar", "Google Gemini", "RB", "flexsurv", "survival"], "alternates": {"html": "https://wpnews.pro/news/royston-parmar-model", "markdown": "https://wpnews.pro/news/royston-parmar-model.md", "text": "https://wpnews.pro/news/royston-parmar-model.txt", "jsonld": "https://wpnews.pro/news/royston-parmar-model.jsonld"}}