---
title: "Slides"
execute:
  include: true
  echo: false
  warning: false
number-sections: true
toc: true
---

```{r}
library(tidyverse)
library(dplyr)
library(ggplot2)
library(survival)
library(emmeans)
library(foreign)
library(gtsummary)
library(gt)
library(ggsurvfit)
library(gridExtra)
library(survminer)
library(broom)
```


```{r}
dat <- read.csv("./unos.txt", sep = "\t")
names(dat) <- c("hla.match", "age.donor", "age.rec", "cold.isc", "death",
                "year", "sex", "tx.type", "follow.up")
dat <- dat |> 
  mutate(
    sex = factor(sex, levels = c(0,1), labels = c("Female","Male")),
    tx.type = factor(tx.type, levels = c(0,1), labels = c("Cadaveric","Living")),
    hla.match = factor(hla.match),
    # year = factor(year)
)
```

```{r}
my.theme <- theme_minimal() +
  theme(
    legend.position = "bottom",
    plot.title = element_text(size = 17, face = "bold"),
    axis.title = element_text(size = 15),
    axis.text = element_text(size = 12),
    legend.text = element_text(size = 12),
    plot.margin = margin(20, 30, 20, 30)
  )
```

```{r}
my.tab <- function(x) {
  x |>
  tab_options(
    row.striping.background_color = "#F6E8C3",
    table.border.top.color = "#A83262",
    table.border.bottom.color = "#A83262",
    column_labels.border.bottom.color = "#A83262",
    table.font.size = px(16),
    heading.title.font.size = px(18),
    table.background.color = "#FFF4CC"
  )
}
```

# Title 

# Table of Contents

# Introduction

# Method & Result

## Identify Predictors (M)

- Data source
- Study population
```{r, echo=TRUE}
nrow(dat)
range(dat$year)
```
- Covariates
- Outcome
```{r}
names(dat)
```

## Table (L)

```{r}
dat |>
  select(sex, age.rec, age.donor, hla.match, cold.isc, tx.type) |> 
  tbl_summary(
    by = tx.type,
    statistic = list(
      all_continuous() ~ "{median} ({p25}, {p75})"
    ),
    label = list(
      hla.match ~ "HLA matches, n(%)",
      age.donor ~ "Donor age, median (IQR)",
      age.rec ~ "Recipient age, median (IQR)",
      cold.isc ~ "Cold ischemic time (hours), median (IQR)",
      sex ~ "Sex, n(%)"
    ),
    missing = "ifany"
  ) |>
  add_overall() |>
  modify_footnote(all_stat_cols() ~ NA) |>
  as_gt() |>
  tab_style(
    style = list(
      cell_fill(color = "#A83262"),
      cell_text(color = "white", weight = "bold")
    ),
    locations = cells_column_labels()
  ) |>
  tab_style(
    style = list(
      cell_fill(color = "#F8EFCB"),
      cell_text(color = "#2F2F2F")
    ),
    locations = cells_body()
  ) |>
  opt_row_striping(row_striping = TRUE) |>
  tab_options(
    table.background.color = "#F8EFCB",
    row.striping.background_color = "#EFE6D0",
    table.border.top.color = "#A83262",
    table.border.bottom.color = "#A83262",
    column_labels.border.top.color = "#A83262",
    column_labels.border.bottom.color = "#A83262",
    table.font.size = px(18),
    column_labels.font.weight = "bold"
  )
```

# Table 1: By Transplant Type

## Transplant Type vs Sex

`sex` are similar across `tx.type`

```{r, fig.width=7, fig.height=5}
plot.tx.sex <- dat |>
  mutate(Overall = "Overall") |>
  pivot_longer(
    cols = c(tx.type, Overall),
    names_to = "Attribute",
    values_to = "Category"
  ) |>
  mutate(
    Attribute = recode(
      Attribute,
      "tx.type" = "Transplant Type"
    )
  ) |>
  count(Attribute, Category, sex) |>
  group_by(Attribute, Category) |>
  mutate(
    total = sum(n),
    percent = n / total
  ) |>
  ungroup() |>
  ggplot(aes(x = Category, y = percent, fill = sex)) +
  geom_col(position = "dodge") +
  facet_grid(
    ~ Attribute,
    scales = "free_x",
    space = "free_x"
  ) +
  labs(
    title = "Percentage of Sex by Transplant Type",
    x = "Group",
    y = "Percentage",
    fill = NULL
  ) +
  scale_x_discrete(
    labels = c("Cadaveric" = "Deceased")
  ) +
  my.theme
plot.tx.sex
```

## Transplant Type vs Recipient Age

```{r, fig.width=7, fig.height=5}
plot.tx.rec <- ggplot(data = dat) +
  geom_density(aes(x = age.rec, color = tx.type)) +
  geom_density(
    aes(x = age.rec, color = "Overall"),
    linewidth = 0.5,
    linetype = "dashed"
  ) +
  scale_color_manual(
    values = c(
      "Cadaveric" = "darkorange",
      "Living" = "darkgreen",
      "Overall" = "gray50"
    ),
    labels = c(
      "Cadaveric" = "Deceased"
    )
  ) +
  labs(
    title = "Density of Recipient Age by Transplant Type",
    x = "Recipient Age",
    y = "Density",
    color = NULL
  ) +
  my.theme
plot.tx.rec
```

```{r}
dat[dat$tx.type == "Cadaveric", ]$age.rec |> table()
dat[dat$tx.type == "Living", ]$age.rec |> table()
```


# Table 1: By Transplant Type

## Transplant Type vs HLA Match

Living donors have less `hla.match` then cadaveric donors.

```{r, fig.width=7, fig.height=5}
dat |>
  mutate(
    tx.type = recode(tx.type, "Cadaveric" = "Deceased")
  ) |>
  ggplot() +
  geom_bar(aes(x = hla.match, fill = tx.type)) +
  facet_wrap(tx.type ~ ., ncol = 1) +
  labs(
    title = "Distribution of HLA Match by Transplant Type",
    x = "HLA match",
    y = "Count",
    color = NULL
  ) +
  scale_fill_manual(
    values = c(
      "Deceased" = "darkorange",
      "Living" = "darkgreen"
    ),
    labels = c(
      "Deceased" = "Deceased",
      "Living" = "Living"
    )
  ) +
  my.theme +
  theme(
    legend.position = "none",
    strip.text = element_text(size = 12)
  )

```

## Transplant Type vs Donor Age

```{r, fig.width=7, fig.height=5}
plot.tx.donor <- ggplot(data = dat) +
  geom_density(aes(x = age.donor, color = tx.type)) +
  geom_density(
    aes(x = age.donor, color = "Overall"),
    linewidth = 0.5,
    linetype = "dashed"
  ) +
  scale_color_manual(
    values = c(
      "Cadaveric" = "darkorange",
      "Living" = "darkgreen",
      "Overall" = "gray50"
    ),
    labels = c(
      "Cadaveric" = "Deceased"
    )
  ) +
  labs(
    title = "Density of Donor Age by Transplant Type",
    x = "Recipient Age",
    y = "Density",
    color = NULL
  ) +
  my.theme

plot.tx.donor
```

# Overall Survival

```{r}
km.all <- survfit(Surv(follow.up, death) ~ 1, data = dat)
```

```{r, fig.width=7, fig.height=5}
km.all |>
  ggsurvfit(type = "survival") +
  add_confidence_interval() +
  scale_y_continuous(limits = c(0, 1)) +
  labs(
    title = "Kaplan-Meier Curve for Overall Survival",
    x = "Years of Follow-up",
    y = "Survival Probability",
  ) +
  my.theme
```

```{r}
header_bg   <- "#A83262"  # burgundy/magenta from right panel
header_text <- "white"
body_bg     <- "#FFF4CC"  # light cream
stripe_bg   <- "#F6E8C3"  # slightly darker cream
text_color  <- "#333333"
border_col  <- "#D8C8A5"
```

```{r}
km.all.summary <- summary(km.all, times = seq(0, 12, 2))
km.all.summary[c("time", "n.risk", "surv", "lower", "upper")] |> 
  as.data.frame() |>
  gt() |>
  tab_header(
    title = "Overall Kaplan-Meier Survival Summary"
  ) |>
  cols_label(
    time = "Follow-up Time",
    n.risk = "Number at Risk",
    surv = "Survival Probability",
    lower = "Upper 95% CI",
    upper = "Lower 95% CI",
  ) |>
  fmt_number(columns = surv, decimals = 3) |>
  fmt_number(columns = lower, decimals = 3) |>
  fmt_number(columns = upper, decimals = 3) |>
  fmt_number(columns = time, decimals = 0) |>
  tab_style(
    style = list(
      cell_fill(color = "#A83262"),
      cell_text(color = "white", weight = "bold")
    ),
    locations = cells_column_labels()
  ) |>
  tab_style(
    style = cell_fill(color = "#FFF4CC"),
    locations = cells_body()
  ) |>
  opt_row_striping(row_striping = TRUE) |>
  my.tab()
```

# Hazard by Transplant Type

## Death distribution


```{r}
dat[dat$death == 1, ] |>
  mutate(
    first.1 = follow.up <= 1,
    first.5 = follow.up <= 5,
  ) |>
  select(first.1, first.5) |>
  summarize(
    total = n(),
    first.1.total = sum(first.1),
    first.1.ratio = first.1.total / total * 100,
    first.5.total = sum(first.5),
    first.5.ratio = first.5.total / total * 100,
  )
```

```{r}
dat[dat$death == 1, ] |>
  ggplot(aes(x = follow.up)) +
  geom_histogram(bins = 50) +
  labs(
    title = "Distribution of Occurence of Death",
    x = "Years of Follow-up",
    y = "Count"
  ) +
  my.theme
```

```{r}
n.pop <- nrow(dat)
dat |>
  select(follow.up, death) |>
  mutate(censored = ifelse(death == 1, 0, 1)) |>
  group_by(follow.up) |>
  summarize(
    death = sum(death),
    censored = sum(censored),
    .groups = "drop"
  ) |>
  arrange(follow.up) |>
  mutate(
    death.accum = cumsum(death),
    death.accum.ratio = death.accum / sum(dat$death),
  ) |>
  ggplot() +
  geom_step(aes(y = death.accum.ratio, x = follow.up)) +
  labs(
    title = "Cumulative Proportion of Deaths Over Follow-up",
    x = "Years of Follow-up",
    y = "Cumulative Proportion of Deaths"
  ) +
  my.theme
```

# Hazard Rate by Transplant Type

```{r}
get.life.table <- function(dat, time.intervals) {
  n.pop <- nrow(dat)

  dat |>
    recode.dat(time.intervals) |>
    group_by(fu.interval) |>
    summarize(
      n.censored = sum(.data$death == 0),
      n.event = sum(.data$death),
    ) |>
    ungroup() |>
    calculate.hazard(n.pop)
}

get.life.table.by.groups <- function(dat, time.intervals, grps) {
  grps |>
    lapply(function(grp) {
      dat |>
        get.life.table.by.group(time.intervals, grp) |>
        mutate(
          grp.name = grp,
          grp.value = pick(1)[[1]]
        ) |>
        select(-1)
    }) |>
    bind_rows()
}

get.life.table.by.group <- function(dat, time.intervals, grp) {
  dat |>
    recode.dat(time.intervals) |>
    group_by(fu.interval, .data[[grp]]) |>
    summarize(
      n.censored = sum(.data$death == 0),
      n.event = sum(.data$death),
      .groups = "keep"
    ) |>
    ungroup(fu.interval) |>
    group_modify(function(df.sub, grp) {
      grp.name <- names(grp)
      grp.value <- grp[[1]]
      n.pop <- (dat[[grp.name]] == grp.value) |> sum()
      calculate.hazard(df.sub, n.pop)
    }) |>
    ungroup()
}

calculate.hazard <- function(life.table, n.pop) {
  n.removed <- life.table$n.event + life.table$n.censored
  n.removed.accum <- c(0, cumsum(n.removed)[-length(n.removed)])
  life.table |>
    mutate(
      n.at.risk = n.pop - n.removed.accum,
      # TODO: how to account for censored? How do we adjust for uneven interval?
      hazard.rate = n.event / n.at.risk
    )
}

recode.dat <- function(dat, time.intervals) {
  df <- dat[dat$follow.up <= sum(time.intervals), ]
  time.points <- cumsum(time.intervals)
  df$fu.interval <- sapply(df$follow.up, function(time) {
      time.points[time <= time.points][1]
  })

  df
}

plot.hazard.rate.by.groups <- function(dat, time.intervals, grps) {
  dat |>
    get.life.table.by.groups(time.intervals, grps) |>
    ggplot(aes(x = fu.interval, y = hazard.rate, color = grp.value)) +
    geom_point() +
    geom_line() +
    scale_color_discrete(
      labels = c(
        "Cadaveric" = "Deceased",
        "Living" = "Living"
      )
    ) +
    scale_x_continuous(
      breaks = function(x) seq(floor(x[1]), ceiling(x[2]), by = 1)
    ) + 
    labs(
      title = "Hazard Rate by Transplant Type",
      x = "Follow-up Year",
      y = "Estimated Hazard Rate",
      color = "Transplant Type"
    ) +
    my.theme
}
```

```{r, fig.width=7, fig.height=5}
time.intervals = c(rep(1/3, 3), rep(1, 4))
plot.hazard.rate.by.groups(dat, time.intervals, "tx.type")
```

```{r}
get.life.table.by.group(dat, time.intervals, "tx.type") |>
  select(fu.interval, tx.type, hazard.rate) |>
  pivot_wider(
    names_from = tx.type,
    values_from = hazard.rate
  ) |>
  mutate(
    fu.interval = case_when(
      abs(fu.interval - 1/3) < 0.001 ~ "1/3",
      abs(fu.interval - 2/3) < 0.001 ~ "2/3",
      fu.interval %% 1 == 0 ~ as.character(as.integer(fu.interval)),
      TRUE ~ as.character(fu.interval)
    ),
    Deceased = round(Cadaveric, 3),
    Living = round(Living, 3)
  ) |>
  select(fu.interval, Deceased, Living) |>
  gt() |>
  tab_header(
    title = "Estimated Hazard Rate by Transplant Type"
  ) |>
  cols_label(
    fu.interval = "Follow-up Interval"
  ) |>
  cols_align(
    align = "center",
    columns = everything()
  ) |>
  tab_style(
    style = list(
      cell_fill(color = "#5B5FE0"),
      cell_text(color = "white", weight = "bold")
    ),
    locations = cells_column_labels()
  ) |>
  tab_style(
    style = list(
      cell_fill(color = "#FFF2CC"),
      cell_text(color = "#2F2F2F")
    ),
    locations = cells_body()
  ) |>
  tab_style(
    style = cell_text(
      color = "#5B5FE0",
      weight = "bold",
      size = px(22)
    ),
    locations = cells_title(groups = "title")
  ) |>
  tab_options(
    table.background.color = "#FFF2CC",
    row.striping.background_color = "#F6E7B8",
    table.border.top.color = "#5B5FE0",
    table.border.bottom.color = "#5B5FE0",
    column_labels.border.bottom.color = "#5B5FE0",
    heading.background.color = "#FFF2CC",
    heading.title.font.size = px(22),
    table.font.size = px(18),
    column_labels.font.weight = "bold"
  ) |>
  opt_row_striping()
```


# Cox Model: Transplant Type

```{r}
cox.tx <- coxph(Surv(follow.up, death) ~ tx.type, data = dat)
summary(cox.tx)
```

```{r}
km.tx <- survfit(Surv(follow.up, death) ~ tx.type, data = dat)
```

```{r, fig.width=7, fig.height=5}
km.tx |>
  ggsurvfit(type = "survival") +
  add_confidence_interval() +
  scale_color_discrete(
    labels = c("Deceased", "Living")
  ) +
  scale_fill_discrete(
    labels = c("Deceased", "Living")
  ) +
  labs(
    title = "Survival by Transplant Type",
    x = "Years of Follow-up",
    y = "Survival Probability",
    color = "Transplant Type",
    fill = "Transplant Type"
  ) +
  my.theme
```

```{r}
summary(km.tx, times = c(0, 4, 8, 12))
```

# Cox Model: Age Recipient (Continuous)

```{r}
cox.age.rec <- coxph(Surv(follow.up, death) ~ age.rec, data = dat)
summary(cox.age.rec)
```

```{r}
km.age.rec <- survfit(Surv(follow.up, death) ~ age.rec, data = dat)
```

```{r, fig.width=7, fig.height=7}
km.age.rec |>
  ggsurvfit(type = "survival") +
  scale_color_discrete(
    labels = seq(1, 18)
  ) +
  labs(
    title = "Survival by Recipient Age",
    x = "Years of Follow-up",
    y = "Survival Probability",
    color = "Recipient Age",
  ) +
  my.theme
```

<details>
<summary>View life table</summary>

```{r}
summary(km.age.rec, times = c(0, 4, 8, 12))
```
</details>


# Cox Model: Age Recipient (Categorical)

```{r}
class.age <- function(age) {
  if (is.na(age)) return(NA)
  if (age < 2) { 
    return("0-1")
  } else if (age < 6) {
    return("2-5")
  } else if (age < 11) {
    return("6-10")
  } else if (age < 19) {
    return("11-18")
  }
}

dat.age.rec.group <- dat
dat.age.rec.group$age.rec.group = sapply(dat$age.rec, class.age) |>
  factor(levels = c(
    "0-1",
    "2-5",
    "6-10",
    "11-18"
  ))
cox.age.rec.group <- coxph(Surv(follow.up, death) ~ age.rec.group,
                           data = dat.age.rec.group)
```


```{r, echo=TRUE}
cox.age.rec.group
```

</details>


```{r, echo=TRUE}
eme.age.rec.group <- emmeans(cox.age.rec.group, pairwise ~ age.rec.group,
                             type = "response")
eme.age.rec.group
```


```{r}
km.age.rec.group <- survfit(Surv(follow.up, death) ~ age.rec.group, 
                            data = dat.age.rec.group)
```


```{r, fig.width=7, fig.height=7}
eme.age.rec.group$contrast |> 
  as.data.frame() |>
  select(contrast, ratio, SE, p.value) |>
  mutate(
    contrast = factor(contrast),
    log.ratio = log(ratio),
    SE.log = SE / ratio,
    low = exp(log.ratio - 1.96 * SE.log),
    up = exp(log.ratio + 1.96 * SE.log)
  ) |>
  ggplot(aes(y = reorder(contrast, ratio))) +
  geom_errorbarh(aes(xmin = low, xmax = up), height = 0.2) +
  geom_point(aes(x = ratio)) +
  geom_vline(xintercept =  1, linetype = "dashed") +
  scale_y_discrete(
    labels = function(x) {
      gsub("[()]", "", x = x)
    }
  ) +
  labs(
    x = "Hazard Ratio",
    y = "Recipient Age Group Comparison",
    title = "Pairwise Hazard Ratios by Recipient Age Groups"
  ) +
  my.theme
```

# Cox Model: Age Recipient (Categorical)

```{r, fig.width=7, fig.height=7}
km.age.rec.group |>
  ggsurvfit(type = "survival") +
  add_confidence_interval() +
  scale_color_discrete(
    labels = c("0-1", "2-5", "6-10", "11-18")
  ) +
  scale_fill_discrete(
    labels = c("0-1", "2-5", "6-10", "11-18")
  ) +
  labs(
    title = "Survival by Recipient Age Group",
    x = "Years of Follow-up",
    y = "Survival Probability",
    color = "Recipient Age Group",
    fill = "Recipient Age Group",
  ) +
  my.theme
```

# Identifying Predictors

```{r}
# From exercise 9
Waldtest <- function(coxph.object, idx) {
  b <- coxph.object$coef[idx]
  Sig <- coxph.object$var[idx, idx]
  Wald <- b %*% solve(Sig) %*% b
  p <- 1 - pchisq(as.numeric(Wald), df = length(idx))
  return(data.frame(Wald = Wald, df = length(idx), p = p))
}

test.new.var <- function(old.vars, new.var, i=1) {
  new.surv <- reformulate(
    termlabels = c(old.vars, new.var),
    response = "Surv(follow.up, death)"
  )
  cox.fit <- coxph(new.surv, data = dat, method = "breslow")
  print(cox.fit)
  Waldtest(cox.fit, i)
}
```

## Start with nothing

```{r, echo=TRUE}
old.vars <- c()
test.new.var(old.vars, "tx.type", 1)
test.new.var(old.vars, "age.rec", 1)
test.new.var(old.vars, "age.donor", 1)
test.new.var(old.vars, "year", 1)
test.new.var(old.vars, "hla.match", 1)
test.new.var(old.vars, "sex", 1)
test.new.var(old.vars, "cold.isc", 1)
```
## `tx.type` + ?

```{r, echo=TRUE}
old.vars <- c("tx.type")

test.new.var(old.vars, "age.rec", 2)
test.new.var(old.vars, "age.donor", 2)
test.new.var(old.vars, "year", 2)
test.new.var(old.vars, "hla.match", 2:7)
test.new.var(old.vars, "sex", 2)
test.new.var(old.vars, "cold.isc", 2)
```

`age.rec` has the smallest $p$-value

## `tx.type` + `age.rec` + ?

```{r, echo=TRUE}
old.vars <- c("tx.type", "age.rec")

test.new.var(old.vars, "age.donor", 3)
test.new.var(old.vars, "year", 3)
test.new.var(old.vars, "hla.match", 3:8)
test.new.var(old.vars, "sex", 3)
test.new.var(old.vars, "cold.isc", 3)
```

`age.donor` has the smallest $p$-value

## `tx.type` + `age.rec` + `age.donor` + ?

```{r, echo=TRUE}
old.vars <- c("tx.type", "age.rec", "age.donor")

test.new.var(old.vars, "year", 4)
test.new.var(old.vars, "hla.match", 4:9)
test.new.var(old.vars, "sex", 4)
test.new.var(old.vars, "cold.isc", 4)
```

`year` has the smallest $p$-value

## `tx.type` + `age.rec` + `age.donor` + `year` + ?

```{r, echo=TRUE}
old.vars <- c("tx.type", "age.rec", "age.donor", "year")

test.new.var(old.vars, "hla.match", 5:10)
test.new.var(old.vars, "sex", 5)
test.new.var(old.vars, "cold.isc", 5)
```

`hla.match` has the smallest $p$-value

## `tx.type` + `age.rec` + `age.donor` + `year` +  `hla.match` + ?

```{r, echo=TRUE}
old.vars <- c("tx.type", "age.rec", "age.donor", "year", "hla.match")

test.new.var(old.vars, "sex", 11)
test.new.var(old.vars, "cold.isc", 11)
```

Neither has $p$-value less than 0.05. Stop.

# Full Model

```{r}
surv.full <- Surv(follow.up, death) ~ tx.type + age.rec + age.donor + year +
                  hla.match
cox.full <- coxph(surv.full, data = dat, method = "breslow")
summary(cox.full)
```

```{r, fig.width=6, fig.height=6}
print(1)
tidy(cox.full, exponentiate = TRUE, conf.int = TRUE) |>
  mutate(
    term = recode(
      term,
      "tx.typeLiving" = "Living donor",
      "age.rec" = "Recipient age",
      "hla.match" = "HLA match",
      "age.donor" = "Donor age",
      "year" = "Transplant year"
    )
  ) |>
  ggplot(aes(x = estimate, y = reorder(term, estimate))) +
  geom_vline(xintercept = 1, linetype = "dashed") +
  geom_errorbarh(
    aes(xmin = conf.low, xmax = conf.high),
    height = 0.2
  ) +
  scale_x_log10() +
  geom_point(size = 2) +
  labs(
    title = "Hazard Ratios from Full Cox Model",
    x = "Log Hazard Ratio",
    y = NULL
  ) +
  my.theme
```




# Proportional hazards assumption

```{r}
cox.full
cox.zph(cox.full)
```

```{r, fig.width=15, fig.height=10}
ph_plots <- ggcoxzph(
  cox.zph(cox.full), ggtheme = theme_minimal(), point.size = 5, size = 30
)

var.names <- c("Transplant Type", "Recipient Age", "Donor Age", "Year", 
                "HLA Match")

my_ph_theme <- theme(
  legend.position = "bottom",
  plot.title = element_text(size = 40, face = "bold"),
  axis.title = element_text(size = 35),
  axis.text = element_text(size = 30),
  legend.text = element_text(size = 20)
)

for (i in seq_along(ph_plots)) {
  title <- paste0("Scaled Schoenfeld Residuals: ", var.names[i])
  single_plot <- ph_plots[[i]] + my_ph_theme + labs(title = title)
  print(single_plot)
}
```






## What happened to `year`?

```{r, fig.width=10, fig.height=7}
ggplot(data = dat) +
  geom_boxplot(aes(x = factor(year), y = follow.up)) +
  my.theme
```

```{r, fig.width=10, fig.height=7}
ggplot(data = dat) +
  geom_boxplot(aes(x = factor(year), y = follow.up, color = factor(death))) +
  my.theme
```


```{r, fig.width=7, fig.height=5}
ggplot(data = dat) +
  geom_boxplot(aes(x = factor(year), y = follow.up)) +
  facet_grid(death ~ .)
```

Probabily want to omit it

## Without `year`

```{r}
surv.full.1 <- Surv(follow.up, death) ~ tx.type + age.rec + hla.match +
                    age.donor
cox.full.1 <- coxph(surv.full.1, data = dat, method = "breslow")
```

```{r, echo=TRUE}
cox.full.1
```

```{r, fig.width=7, fig.height=5}
tidy(cox.full.1, exponentiate = TRUE, conf.int = TRUE) |>
  mutate(
    term = recode(
      term,
      "tx.typeLiving" = "Living donor",
      "age.rec" = "Recipient age",
      "hla.match" = "HLA match",
      "age.donor" = "Donor age",
    )
  ) |>
  ggplot(aes(x = estimate, y = reorder(term, estimate))) +
  geom_vline(xintercept = 1, linetype = "dashed") +
  geom_errorbarh(
    aes(xmin = conf.low, xmax = conf.high),
    height = 0.2
  ) +
  scale_x_log10() +
  geom_point(size = 2) +
  labs(
    title = "Hazard Ratios from Full Cox Model (Without Year)",
    x = "Hazard Ratio",
    y = NULL
  ) +
  my.theme
```


```{r, fig.width=6, fig.height=6}
hr.full <- tidy(cox.full, exponentiate = TRUE, conf.int = TRUE)
hr.full.1 <- tidy(cox.full.1, exponentiate = TRUE, conf.int = TRUE)
hr.compare <- bind_rows(
  hr.full |>
    mutate(model = "Full model with year"),
  hr.full.1 |>
    mutate(model = "Model without year")
) |>
  mutate(
    term = case_when(
      term == "tx.typeLiving" ~ "Living donor",
      term == "age.rec" ~ "Recipient age",
      term == "age.donor" ~ "Donor age",
      term == "year" ~ "Transplant year",
      TRUE ~ term
    )
  )

hr.compare
ggplot(hr.compare, aes(x = estimate, y = term, color = model)) +
  geom_vline(xintercept = 1, linetype = "dashed") +
  geom_errorbarh(
    aes(xmin = conf.low, xmax = conf.high),
    height = 0.2,
    position = position_dodge(width = 0.6)
  ) +
  geom_point(
    size = 2.5,
    position = position_dodge(width = 0.6)
  ) +
  scale_x_log10() +
  labs(
    title = "Hazard Ratios from Cox Models",
    x = "Log Hazard Ratio",
    y = NULL,
    color = NULL
  ) +
  my.theme
```

---

TODO: write a more generic function (UPDATE: FAILED)

<details>

```{r, eval=FALSE}
# WARNING: BAD, DO NOT USE.
vars <- c("hla.match", "age.donor", "age.rec", "cold.isc", "year", "sex", 
          "tx.type")
included <- vars == "tx.type"

Waldtest <- function(cox.fit, i.betas){
  q <- length(i.betas)
  coefs <- cox.fit$coefficients
  var <- cox.fit$var[i.betas, i.betas]
  Wald <- coefs[i.betas]%*%solve(var)%*%coefs[i.betas]
  p.value <- 1-pchisq(as.numeric(Wald), df = q)
  return(p.value)
}


find.model.vars <- function(included) {
  test.vars <- vars[!included]
  p.values <- sapply(test.vars, function(test.var) {
    new.surv <- reformulate(
      termlabels = c(vars[included], test.var),
      response = "Surv(follow.up, death)"
    )
    fit.tx <- coxph(new.surv, data = dat)
    Waldtest(fit.tx, 1)
  })
  if (all(p.values > 0.05)) {
    return(included)
  }
  new.var <- names(p.values)[which.min(p.values)]
  included[which(vars == new.var)] <- TRUE
  return(find.model.vars(included))
}

included <- find.model.vars(included)
vars[included]

```

</details>


```{r}
# surv <- Surv(follow.up, death) ~ tx.type + age.rec + hla.match
# fit.cox.model(surv, 3)
# surv <- Surv(follow.up, death) ~ tx.type + age.rec + age.donor
# fit.cox.model(surv, 3)
# surv <- Surv(follow.up, death) ~ tx.type + age.rec + cold.isc
# fit.cox.model(surv, 3)
# surv <- Surv(follow.up, death) ~ tx.type + age.rec + year
# fit.cox.model(surv, 3)
# surv <- Surv(follow.up, death) ~ tx.type + age.rec + sex
# fit.cox.model(surv, 3)
```



---


# Old

<details>

## Death & Censored


```{r, echo=TRUE}
dat |>
  group_by(death) |>
  summarise(
    n = n(),
    percentage = n() / nrow(dat) * 100
  )
```

Most of the patients (95.24%) were censored.

```{r}
n.pop <- nrow(dat)
dat.accum <- dat[dat$follow.up > 0,] |>
  select(follow.up, death) |>
  mutate(censored = ifelse(death == 1, 0, 1)) |>
  group_by(follow.up) |>
  summarize(
    death = sum(death),
    censored = sum(censored),
    .groups = "drop"
  ) |>
  arrange(follow.up) |>
  mutate(
    death.accum = cumsum(death),
    censored.accum = cumsum(censored),
    event.accum = death.accum + censored.accum,
    n.at.risk = n.pop - c(0, event.accum[-n()])
  )
dat.accum |>
  pivot_longer(
    cols = c(death.accum, censored.accum, n.at.risk),
    names_to = "type",
    values_to = "accum",
  ) |>
  ggplot(aes(x = follow.up, y = accum, color = type)) +
  geom_step(linewidth = 1, direction = "hv") +
  my.theme
```

```{r}
dat[dat$death == 1, ] |>
  ggplot(aes(x = follow.up)) +
  geom_histogram(bins = 50)
```


```{r}
dat[dat$follow.up == 0,]
```

```{r}
head(dat)
```

## Cox Model - Age as a Continuous Variable

```{r, echo=TRUE}
cox.age.rec <- coxph(Surv(follow.up, death) ~ age.rec, data = dat)
cox.age.rec |> summary()
```

## Cox Model - Age as a Categorical Variable


```{r, fig.width=10, fig.height=10}
cox.final <- coxph(Surv(follow.up, death) ~ tx.type + age.rec + hla.match + age.donor + year, data = dat)
cox.zph(cox.final)
plot(cox.zph(cox.final))

ggcoxzph(cox.zph(cox.final),
         ggtheme = theme_minimal() +
         theme(
           legend.position = "bottom",
           plot.title = element_text(size = 17, face = "bold"),
           axis.title = element_text(size = 15),
           axis.text = element_text(size = 12),
           legend.text = element_text(size = 12),
           strip.text = element_blank(),
           plot.margin = margin(20, 30, 20, 30)
         ))
```

## Table 1 (L)


### HLA match `hla.match`

```{r}
dat$hla.match |> table(useNA = "always")
```

```{r}
ggplot(dat, aes(x = hla.match)) +
  geom_bar() +
  labs(x = "HLA match", y = "Count") +
  theme_minimal()

```

```{r}
ggplot(dat, aes(x = hla.match, fill = tx.type)) +
  geom_bar(position = "dodge") +
  labs(x = "HLA match", y = "Count") +
  theme_minimal()
```

::: {.callout-warning}
TODO: change to percentage within each `tx.type`
:::

::: {.callout-note}
Living donors have less `hla.match` then cadaveric donors
:::


### Donor age `age.donor`

```{r}
#| echo: true
mean(dat$age.donor, na.rm = TRUE)
median(dat$age.donor, na.rm = TRUE)
```

```{r}
ggplot(dat, aes(x = age.donor)) +
  geom_bar() +
  labs(x = "Donor Age", y = "Count") +
  theme_minimal()
```

```{r, fig.width = 8, fig.height = 12}
ggplot(dat, aes(x = age.donor)) +
  geom_bar() +
  labs(x = "Donor Age", y = "Count") +
  theme_minimal() +
  facet_grid(hla.match ~ .)
```

```{r, fig.width= 8, fig.height= 12}
ggplot(dat, aes(x = age.donor, color = tx.type)) +
  geom_density() +
  labs(x = "Donor Age", y = "Density") +
  theme_minimal() +
  facet_grid(hla.match ~ .)
```

```{r}
ggplot(dat, aes(x = age.donor, color = hla.match)) +
  geom_density() +
  labs(x = "Donor Age", y = "Count") +
  theme_minimal()
```

```{r}
ggplot(dat, aes(x = as.factor(tx.type), y = age.donor)) +
  geom_boxplot() +
  theme_minimal()
```

::: {.callout-note}
There is age difference between different `tx.type`
:::


### Recipient Age `age.rec`

```{r}
#| echo: true
mean(dat$age.rec, na.rm = TRUE)
median(dat$age.rec, na.rm = TRUE)
```


```{r}
ggplot(dat, aes(x = age.rec)) +
  geom_bar() +
  labs(x = "Recipient Age", y = "Count") +
  theme_minimal()

```

```{r}
ggplot(dat, aes(x = as.factor(age.rec), y = age.donor)) +
  geom_boxplot() +
  theme_minimal()

```

```{r}
ggplot(dat, aes(x = age.rec, fill = tx.type)) +
  geom_bar(position = "dodge") +
  theme_minimal()

```

```{r}
ggplot(dat, aes(x = age.rec, color = hla.match)) +
  geom_density() +
  theme_minimal()
```

```{r}
ggplot(dat, aes(x = as.factor(age.rec), y = cold.isc)) +
  geom_boxplot() +
  theme_minimal()
```


### Cold Ischemia Time `cold.isc`

```{r}
#| echo: true
mean(dat$cold.isc, na.rm = TRUE)
median(dat$cold.isc, na.rm = TRUE)
```

```{r}
ggplot(dat, aes(x = cold.isc)) +
  geom_density() +
  labs(x = "Cold Ischemia Time (hours)", y = "Probability Density") +
  theme_minimal()
```

```{r}
ggplot(dat, aes(x = cold.isc, color = tx.type, group = tx.type)) +
  geom_density() +
  labs(x = "Cold Ischemia Time (hours)", y = "Probability Density") +
  theme_minimal()
```

```{r}
ggplot(dat, aes(x = cold.isc)) +
  geom_density() +
  theme_minimal() +
  facet_grid(tx.type ~ .)
```

### Transplant Type `tx.type`

```{r}
dat$tx.type |> table(useNA = "always")
```

```{r}
#| echo: true
dat$tx.type |> table()
```

```{r}
ggplot(dat, aes(x = tx.type)) +
  geom_bar() +
  labs(x = "Transplant Type", y = "Count") +
  theme_minimal()

```

### Year `year`

```{r}
dat$year |> table()
```

```{r}
ggplot(dat, aes(x = year)) +
  geom_bar() +
  labs(x = "Year", y = "Count") +
  theme_minimal()
```

```{r}
ggplot(dat, aes(x = year, y = follow.up)) +
  geom_boxplot()
```

```{r}
ggplot(dat, aes(x = year, fill = tx.type)) +
  geom_bar(position = "dodge")
```

```{r}
ggplot(dat, aes(x = year, y = age.rec)) +
  geom_boxplot()
```

```{r}
ggplot(dat, aes(x = year, y = age.donor)) +
  geom_boxplot()
```

## Kaplan-Meier 

### Overall (L)

```{r}
km_all <- survfit(Surv(follow.up, death) ~ 1, data = dat)
summary(km_all, times = c(4, 8, 12))
```

```{r}
km_all |>
  ggsurvfit(type = "survival") +
  add_confidence_interval() +
  scale_y_continuous(limits = c(0, 1), labels = scales::label_percent()) +
  labs(
    x = "Years of Follow-up",
    y = "Overall Survival Probability"
  ) +
  theme_minimal()
```

### `tx.type` (M)

```{r, fig.width=7, fig.height=5}
km.tx <- survfit(Surv(follow.up, death) ~ tx.type, data = dat)

km.tx |>
  ggsurvfit(type = "survival") +
  add_confidence_interval() +
  scale_x_continuous(
    breaks = seq(0, 20, by = 4)
  ) +
  scale_y_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.2),
    labels = scales::label_number(accuracy = 0.1)
  ) +
  labs(
    x = "Years of Follow-up",
    y = "Overall Survival Probability"
  ) +
  theme_minimal() +
  theme(
    legend.position = "bottom",
    plot.title = element_text(size = 17, face = "bold"),
    axis.title = element_text(size = 15),
    axis.text = element_text(size = 10),
    legend.text = element_text(size = 12),
    plot.margin = margin(20, 30, 20, 30)
  )
```

## Cox Model

```{r}
get.life.table <- function(dat, time.intervals) {
  n.pop <- nrow(dat)

  dat |>
    recode.dat(time.intervals) |>
    group_by(fu.interval) |>
    summarize(
      n.censored = sum(.data$death == 0),
      n.event = sum(.data$death),
    ) |>
    ungroup() |>
    calculate.hazard(n.pop)
}

get.life.table.by.groups <- function(dat, time.intervals, grps) {
  grps |>
    lapply(function(grp) {
      dat |>
        get.life.table.by.group(time.intervals, grp) |>
        mutate(
          grp.name = grp,
          grp.value = pick(1)[[1]]
        ) |>
        select(-1)
    }) |>
    bind_rows()
}

get.life.table.by.group <- function(dat, time.intervals, grp) {
  dat |>
    recode.dat(time.intervals) |>
    group_by(fu.interval, .data[[grp]]) |>
    summarize(
      n.censored = sum(.data$death == 0),
      n.event = sum(.data$death),
      .groups = "keep"
    ) |>
    ungroup(fu.interval) |>
    group_modify(function(df.sub, grp) {
      grp.name <- names(grp)
      grp.value <- grp[[1]]
      n.pop <- (dat[[grp.name]] == grp.value) |> sum()
      calculate.hazard(df.sub, n.pop)
    }) |>
    ungroup()
}

calculate.hazard <- function(life.table, n.pop) {
  n.removed <- life.table$n.event + life.table$n.censored
  n.removed.accum <- c(0, cumsum(n.removed)[-length(n.removed)])
  life.table |>
    mutate(
      n.at.risk = n.pop - n.removed.accum,
      # TODO: how to account for censored? How do we adjust for uneven interval?
      hazard.rate = n.event / n.at.risk
    )
}

recode.dat <- function(dat, time.intervals) {
  df <- dat[dat$follow.up <= sum(time.intervals), ]
  time.points <- cumsum(time.intervals)
  df$fu.interval <- sapply(df$follow.up, function(time) {
      time.points[time <= time.points][1]
  })

  df
}
```

### `death` Distribution (?)

```{r}
# dat |>
#   mutate(
#     accum.death = cumsum(death),
#     accum.censored = if_else(death == 1, 0, 1) |> cumsum()
#   ) |>
#   ggplot() +
#   geom_pont(aes(x = follow.up, y = accum.death, color = death))
```

```{r}

```

```{r}
plot.death = dat[dat$death == 1,] |>
  ggplot(aes(x = follow.up)) +
  geom_histogram(bins = 50)
plot.death
```


### Overall (L)

::: {.callout-note}
skip overall, jump directly to `tx.type`
:::

```{r}
time.intervals <- c(1/3, 1/3, 1/3, 1, 1, 1, 1)
get.life.table(dat, time.intervals)
```

### `tx.type` (M)


### `age` (continuous) (L)

### `age` (categorical) (M)

### Full model (L)

```{r}
m1 <- coxph(Surv(follow.up, death) ~ hla.match + tx.type, data = dat)
summary(m1)

m2 <- coxph(Surv(follow.up, death) ~ hla.match * tx.type, data = dat)
summary(m2)

anova(m1, m2, test = "LRT")
```

### Discussion: include `year` or not?

## Assumption Testing


  ## Why Survival Analysis (L)

Motivation: study the distribution of time to event $T$.

Example: time of death after kidney transplant. 


```{r}
ex <- data.frame(
  id = c(1, 2, 3, 4, 5),
  transplant = c(2000, 2000, 2001, 2003, 2004),
  death = c(2005, 2009, 2005, 2004, 2016)
)

ex_table_1 <- ex |>
  gt() |>
  cols_label(
    id = "ID",
    transplant = "Transplant",
    death = "Death"
  ) %>%
  cols_align(align = "center", columns = everything())

ex_plot_real_time <- ggplot(ex) +
  geom_segment(aes(x = transplant, xend = death, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = transplant, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = death, y = factor(id), color = "death"), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  theme_minimal()
```

```{r}
ex_table_1
ex_plot_real_time
```

---

We then calculate time to death for each respondents. 

With this, all we need is to fit a linear model `t ~ X` or `log(t) ~ X`

```{r}
ex_t <- ex |>
  mutate(
    t = death - transplant
  )

ex_table_2 <- ex_t |>
  gt() |>
  cols_label(
    id = "ID",
    transplant = "Transplant",
    death = "Death",
    t = "Time to death"
  ) |>
  cols_align(align = "center", columns = everything())

ex_plot_uniform_time <- ggplot(ex_t) +
  geom_segment(aes(x = 0, xend = t, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = 0, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = t, y = factor(id), color = "death"), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  theme_minimal()

```


```{r}
ex_table_2
ex_plot_uniform_time
```

---

What if we do not know when exactly some respondents die?

Scenario 1: the study ends at the year 2008?

```{r}
ex_t_c <- ex_t |>
  mutate(
    death_censored = if_else(death <= 2008, death, 2008),
    death_censored_txt = if_else(death <= 2008, as.character(death), "> 2008"),
    status = if_else(death <= 2008, 1, 0),
    t_1 = death_censored - transplant,
    t_1_txt = if_else(death <= 2008, as.character(t_1),
                      paste(">", as.character(t_1)))
  )
```

```{r}
ex_table_3 <- ex_t_c |>
  select(id, transplant, death_censored_txt, t_1_txt) |>
  gt() |>
  cols_label(
    id = "ID",
    transplant = "Transplant",
    death_censored_txt = "Death",
    t_1_txt = "Time to death"
  ) |>
  cols_align(align = "center", columns = everything())

ex_plot_real_time_1 <- ggplot(ex_t_c) +
  geom_segment(aes(x = transplant, xend = death_censored, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = transplant, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = death_censored, y = factor(id), color =
                   if_else(status == 1, "death", "censored")), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D",
                                "censored" = "orange")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  xlim(2000, 2016) +
  geom_vline(xintercept = 2008, linetype = "dashed", color = "orange",
             linewidth = 0.8) +
  theme_minimal()


ex_plot_uniform_time_1 <- ggplot(ex_t_c) +
  geom_segment(aes(x = 0, xend = t_1, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = 0, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = t_1, y = factor(id), color =
                   if_else(status == 1, "death", "censored")), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D",
                                "censored" = "orange")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  theme_minimal()
```


```{r}
ex_table_3
ex_plot_real_time_1
ex_plot_uniform_time_1
```

**Right Censoring**: only observe the event (death) if it occurs before a 
certain time (2008).

---

Scenario 2: respondent 3 move away; loss follow up

```{r}
ex_alt <- ex_t_c
ex_alt$death_censored_txt[3] <- "> 2005"
ex_alt$status[3] <- 0
ex_alt$t_1_txt[3] <- "> 4"


ex_table_4 <- ex_alt |>
  select(id, transplant, death_censored_txt, t_1_txt) |>
  gt() |>
  cols_label(
    id = "ID",
    transplant = "Transplant",
    death_censored_txt = "Death",
    t_1_txt = "Time to death"
  ) |>
  cols_align(align = "center", columns = everything())

ex_plot_real_time_2 <- ggplot(ex_alt) +
  geom_segment(aes(x = transplant, xend = death_censored, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = transplant, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = death_censored, y = factor(id), color =
                   if_else(status == 1, "death", "censored")), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D",
                                "censored" = "orange")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  xlim(2000, 2016) +
  geom_vline(xintercept = 2008, linetype = "dashed", color = "orange",
             linewidth = 0.8) +
  theme_minimal()


ex_plot_uniform_time_2 <- ggplot(ex_alt) +
  geom_segment(aes(x = 0, xend = t_1, y = factor(id),
                   yend = factor(id)), color = "grey50", linewidth = 1) +
  geom_point(aes(x = 0, y = factor(id), color = "trans"), size = 3) +
  geom_point(aes(x = t_1, y = factor(id), color =
                   if_else(status == 1, "death", "censored")), size = 3) +
  scale_color_manual(values = c("trans" = "#00BFC4", "death" = "#F8766D",
                                "censored" = "orange")) +
  scale_y_discrete(limits = rev) +
  labs(x = "Year", y = "Subject ID", color = "Event") +
  theme_minimal()
```

```{r}
ex_table_4
ex_plot_real_time_2
ex_plot_uniform_time_2
```

---

How many patients are right censored?

```{r}
dat |>
  mutate(Overall = "Overall") |>
  pivot_longer(
    cols = c(Overall, sex, tx.type), 
    names_to = "Attribute", 
    values_to = "Category"
  ) |>
  count(Attribute, Category, death) |>
  ggplot(aes(x = Category, y = n, fill = factor(death))) +
  geom_col(position = "dodge") +
  facet_wrap(~ Attribute, scales = "free_x") +
  labs(x = "Group", y = "Count", fill = "Death Status") +
  theme_minimal()
```

## Challenges in Survival Analysis (L)

- **Right Censoring**: only observe the event if it occurs before a certain 
  time.
- **Left Censoring**: event has occurred prior to the start of a research
  - Follow up every 3 years.
  - Event has occurred -> event happened sometime before follow up.
- **Left Truncation**: delayed entry; respondents are included only if they
  survived long enough.
  - Start follow up with patients 100 days after the transplant
  - Patients dies within 100 day wouldn't be included in the dataset
- **Right Truncation**: respondents are included only if they have already
  experienced the event.
  - Retrospective analysis from deceased patients between 1990 and 2000.
  - Patients not dead before 2000 are not included in the dataset.
</details>

