inst/doc/introduction.R

In orthoMTL: Multi-Task Learning with Orthogonal Constraints

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 7,
  fig.height = 5,
  fig.align = "center"
)
library(orthoMTL)

## ----simulate-----------------------------------------------------------------
set.seed(42)

sim <- simulate_mtl(
  n = 300,
  p = 15,
  n_signals = 5,
  thresholds = c(4, 8, 14, 20),
  effect_strength = 1.2
)
sim

## ----ground-truth-------------------------------------------------------------
# True coefficients for signal features
gt <- sim$ground_truth
signal_coefs <- gt$coefficients[gt$signal_features, ]
signal_coefs

## ----ground-truth-types-------------------------------------------------------
# Effect types
gt$effect_types

## ----prepare-data-------------------------------------------------------------
thresholds <- sim$thresholds
Y <- create_longitudinal_labels(sim$SurvTime, sim$Event, thresholds)
head(Y, 10)

## ----indicator----------------------------------------------------------------
W <- create_indicator_matrix(Y)
cat("Proportion observed per threshold:\n")
colMeans(W)

## ----constraint---------------------------------------------------------------
K <- create_constraint_matrix(length(thresholds))
K

## ----fit-initial--------------------------------------------------------------
fit <- orthoMTL(
  X = sim$X, Y = Y,
  lambda = 1e-3, step_size = 0.5,
  K = K, survival = TRUE, censored.mat = W,
  alpha = 0.5
)
summary(fit)

## ----heatmap-initial, fig.width=8, fig.height=6-------------------------------
plot_heatmap(fit)

## ----cv, results='hide'-------------------------------------------------------
n_tasks <- length(sim[["thresholds"]])
folds <- rep(1:5, length.out = nrow(sim[["X"]]))

cv_res <- cv_orthoMTL(
  X.train   = sim[["X"]],
  Y.train   = Y,
  W.train   = W,
  K         = K,
  lambdas   = c(1e-5, 1e-4, 1e-3),
  alphas    = c(0, 0.5, 1),
  stepsizes = c(1, 2, 5),
  diag_vals = c(0.5, n_tasks, 2 * n_tasks),
  survival  = TRUE,
  folds     = folds,
  n_cores   = 1,
  seed      = 42,
  verbose   = FALSE
)

## ----cv-results---------------------------------------------------------------
print(cv_res)

## ----fit-final----------------------------------------------------------------
best <- cv_res$best
K_final <- K
diag(K_final) <- best$diag_val

fit_final <- orthoMTL(
  X = sim$X, Y = Y,
  lambda    = best$lambda,
  alpha     = best$alpha,
  step_size = best$stepsize,
  K         = K_final,
  survival  = TRUE,
  censored.mat = W
)
summary(fit_final)

## ----heatmap-final, fig.width=8, fig.height=6---------------------------------
plot_heatmap(fit_final)

## ----correlation, fig.width=6, fig.height=5-----------------------------------
plot_correlation(fit_final)

## ----bootstrap, results='hide'------------------------------------------------
boot_res <- bootstrap_orthoMTL(
  X = sim$X, Y = Y,
  lambda    = best$lambda,
  alpha     = best$alpha,
  step_size = best$stepsize,
  K         = K_final,
  survival  = TRUE,
  censored.mat = W,
  n_repeats = 200,
  n_cores   = 1,
  verbose   = FALSE
)

## ----bootstrap-print----------------------------------------------------------
print(boot_res)

## ----bootstrap-select---------------------------------------------------------
signal_feats <- gt[["signal_features"]]
null_feats <- gt[["null_features"]]
effect_types <- gt[["effect_types"]]

selected <- c(
  signal_feats[effect_types == "switch"][1],
  signal_feats[effect_types == "constant"][1],
  signal_feats[effect_types == "early"][1],
  null_feats[1]
)

cat("Selected features:\n")
cat("  Switch signal:  ", selected[1], "(Cox should miss)\n")
cat("  Constant signal:", selected[2], "(Cox should find)\n")
cat("  Early signal:   ", selected[3], "(Cox may dilute)\n")
cat("  Null feature:   ", selected[4], "(neither should find)\n")

## ----bootstrap-plot, fig.width=8, fig.height=6--------------------------------
suppressWarnings(
  plot_bootstrap(boot_res, features = selected)
)

## ----cox-comparison, eval=requireNamespace("glmnet", quietly = TRUE) && requireNamespace("survival", quietly = TRUE)----
library(survival)
library(glmnet)

surv_obj <- Surv(time = sim[["SurvTime"]], event = sim[["Event"]])

# Cross-validate alpha (mixing parameter)
alphas <- seq(0, 1, by = 0.1)
cv_scores <- numeric(length(alphas))

for (i in seq_along(alphas)) {
  set.seed(42)
  cvfit <- cv.glmnet(
    x = sim[["X"]],
    y = surv_obj,
    family = "cox",
    type.measure = "C",
    alpha = alphas[i]
  )
  cv_scores[i] <- cvfit[["cvm"]][cvfit[["index"]]["min", ]]
}

best_alpha <- alphas[which.max(cv_scores)]
cat("Best alpha:", best_alpha, "(CV C-index:", max(cv_scores), ")\n")

# Refit with best alpha
set.seed(42)
cox_fit <- cv.glmnet(
  x = sim[["X"]],
  y = surv_obj,
  family = "cox",
  type.measure = "C",
  alpha = best_alpha
)

cox_coefs <- as.numeric(coef(cox_fit, s = "lambda.min"))
names(cox_coefs) <- colnames(sim[["X"]])

## ----cox-table, eval=requireNamespace("glmnet", quietly = TRUE) && requireNamespace("survival", quietly = TRUE)----
# Build comparison table
ortho_mean_abs <- apply(abs(coef(fit_final)), 1, mean)

comparison <- data.frame(
  feature = gt$signal_features,
  effect_type = as.character(gt$effect_types),
  orthoMTL_mean_abs = round(ortho_mean_abs[gt$signal_features], 4),
  cox_coef = round(cox_coefs[gt$signal_features], 4),
  cox_detected = cox_coefs[gt$signal_features] != 0,
  stringsAsFactors = FALSE
)

cat("Signal feature detection comparison:\n\n")
print(comparison, row.names = FALSE)

## ----cox-vs-ortho, fig.width=8, fig.height=4, eval=requireNamespace("glmnet", quietly = TRUE) && requireNamespace("survival", quietly = TRUE)----
# Pick the switch feature — most interesting temporal pattern
switch_feat <- signal_feats[effect_types == "switch"][1]

# What Cox sees: one number
cat(switch_feat, "— Cox coefficient:", 
    round(cox_coefs[switch_feat], 3), "\n")

# What orthoMTL sees: a trajectory
cat(switch_feat, "— orthoMTL coefficients:\n")
print(round(coef(fit_final)[switch_feat, ], 3))

# What the truth is
cat(switch_feat, "— True coefficients (sign-aligned):\n")
print(round(-gt[["coefficients"]][switch_feat, ], 3))

## ----ground-truth-recovery----------------------------------------------------
true_coefs <- gt$coefficients[gt$signal_features, ]
est_coefs <- coef(fit_final)[gt$signal_features, ]

# Sign convention:
#   Simulation uses log-hazard scale (negative = protective, reduces hazard)
#   orthoMTL models P(progression-free) (positive = protective)
# Negate true coefficients to align
true_aligned <- -true_coefs

task_cors <- sapply(seq_len(ncol(true_aligned)), function(k) {
  cor(true_aligned[, k], est_coefs[, k])
})
names(task_cors) <- colnames(true_aligned)

cat("Correlation between true and estimated coefficients per threshold:\n")
print(round(task_cors, 3))

## ----recovery-heatmap, fig.width=8, fig.height=5------------------------------
make_long <- function(mat, source_label) {
  data.frame(
    feature = rep(rownames(mat), ncol(mat)),
    threshold = rep(colnames(mat), each = nrow(mat)),
    weight = as.vector(mat),
    source = source_label,
    stringsAsFactors = FALSE
  )
}

# Normalize each matrix to [-1, 1] by dividing by its own max absolute value
normalize <- function(mat) mat / max(abs(mat), na.rm = TRUE)

combined <- rbind(
  make_long(normalize(true_aligned), "True (sign-aligned)"),
  make_long(normalize(est_coefs),    "Estimated")
)

combined$feature <- factor(combined$feature, levels = rev(rownames(true_aligned)))
combined$threshold <- factor(combined$threshold, levels = colnames(true_aligned))
combined$source <- factor(combined$source, levels = c("True (sign-aligned)", "Estimated"))



# Now both panels use the full color range
ggplot2::ggplot(combined, ggplot2::aes(threshold, feature, fill = weight)) +
  ggplot2::geom_tile() +
  ggplot2::scale_fill_gradient2(low = "red", mid = "white", high = "blue", midpoint = 0,
                       limits = c(-1, 1)) +
  ggplot2::facet_wrap(~ source) +
  ggplot2::labs(x = "Threshold (months)", y = NULL, fill = "Normalized\nCoefficient") +
  ggplot2::theme_minimal()