#---------------------------------------------------------
# Script name: exp_res_health_impact.R
#
# Purpose of script: 
#
# Analyse the simulated case crossover data.frame and 
# produce results of the Manuscript for the estimates 
# of the Exposure-Response Functions(Fig 3, Fig 4),
# and for the estimates of the Attributable Fractions
# (Table 2).
#---------------------------------------------------------
    
#  ------------------------------------------------------
#  ! This script is run on simulated data:              !
#  !                                                    !
#  ! - "case_cross_data.csv" is the simulated           !
#  !    case-crossover dataset created with script      !
#  !    "1.from_cases_to_case_crossover.R"              !
#  !                                                    !
#  ! Since this script is run on a simulated dataset    !
#  ! results and figure obtained will slightly differ   !
#  ! from those presented in the manuscript.            !
#  ------------------------------------------------------
#
# Author(s): Giovenale Moirano
# Date Created: 05 May 2024
# Email: giovenale.moirano@bsc.es
#
#---------------------------------------------------------
# 1. Clean Environment
#---------------------------------------------------------

rm(list = ls())

#------------------------------------------------------------
# 2.Set WD
#------------------------------------------------------------

# setwd("mydirectory/")

#---------------------------------------------------------
# 3. Loadpackages
#---------------------------------------------------------

packages <- c(
  "ggmap", "sf", "tidyr",
  "lubridate", "survival",
  "dlnm", "dplyr", "ggplot2"
  )
install.packages(setdiff(packages, rownames(installed.packages())))
lapply(packages, require, character.only = TRUE)

#Source function to compute attributable fraction from DLNMs

source("functions/attrdl.R")


#------------------------------------------------------------
# 4. Load CC_weekly_dataset
#------------------------------------------------------------

data <- read.csv("data/7.case_cross_data.csv")

# Define matching strata for conditional logistic analysis
data$clogit_id <- as.numeric(substr(data$ID, 3, 6))

#------------------------------------------------------------
# 5. Create lagged exposures Matrix for Weekly Average Temp
# in the 8 weeks preceding the index date
#------------------------------------------------------------

# 5a. For each case and control period, extract daily temperatures
# based on the starting prefix ("tg")

t_mat <- as.matrix(data[, which(substr(names(data), 1, 2) == "tg")])
dim(t_mat)

# 5b. Compute weekly average temperature

a <- NULL
for (i in seq(from = 7, to = 56, by = 7)) {
  a[[ceiling(i / 7)]] <- apply(t_mat[, (i - 6):i], 1, mean)
}

t_mat_avg <- as.matrix(as.data.frame(a))
hist(t_mat_avg)

#------------------------------------------------------------
# 6. Create lagged exposures matrix for Weekly Cumulative Prep
# in the  8 weeks preceding the index date
#------------------------------------------------------------

# 6a. Extract daily precipitation based on the prefix ("pr")

p_mat <- as.matrix(data[, which(substr(names(data), 1, 2) == "pr")])
dim(p_mat)


# 6b. Compute weekly cumulative prep

a2 <- NULL
for (i in seq(from = 7, to = 56, by = 7)) {
  a2[[ceiling(i / 7)]] <- apply(p_mat[, (i - 6):i], 1, sum)
}

p_mat_avg <- as.matrix(as.data.frame(a2))
dim(p_mat_avg)

hist(p_mat_avg)

#------------------------------------------------------------
# 7. Import time series of Temp and Prep for all NUTS with cases
# and compute percentiles of interest.
#------------------------------------------------------------

clima_all <- read.csv(file = "data/6.weekly_prep_temp.csv")

clima_all <- clima_all %>%
  mutate(
    week = lubridate::week(date),
    year = lubridate::year(date)
  ) %>%
  filter(week > 19 & week <= 44) %>%
  group_by(week, year, NUTS_ID) %>%
  summarise(
    t_mean = mean(tg, na.rm = T),
    prep_cum = sum(prep, na.rm = T)
  )

# Define knots based on percentiles

tg_per <- c(quantile(clima_all$t_mean,
  probs = c(0.10, 0.25, 0.33, 0.50, 0.66, 0.75, 0.9, 0.95, 0.99),
  na.rm = TRUE
))

prcp_per <- c(quantile(clima_all$prep_cum,
  probs = c(0.10, 0.25, 0.33, 0.50, 0.66, 0.75, 0.9, 0.95, 0.99),
  na.rm = TRUE
))

temp_knots <- tg_per[c(3, 5)]

#equally spaced knots 
lag_knots <- c(1.66, 4.32)


#----------------------------------------------------------------------
# 8. Run conditional logistic regression, conditioning on stratum (ID)
#----------------------------------------------------------------------

# 8a. Create Crossbasis for temp
temp_cb <- crossbasis(t_mat_avg,
  lag = c(0, 7),
  argvar = list(
    fun = "ns",
    knots = temp_knots, intercept = F
  ),
  arglag = list(
    fun = "bs", degree = 3,
    knots = lag_knots, intercept = T
  )
)

# 8b. Create Crossbasis for prep

prep_cb <- crossbasis(p_mat_avg,
  lag = c(0, 7),
  argvar = list(fun = "lin", intercept = F),
  arglag = list(
    fun = "bs", degree = 3,
    knots = lag_knots, intercept = T
  )
)

# 8c. Fit conditional logistic regression

mod <- clogit(caco ~ temp_cb + prep_cb + strata(clogit_id),
  data = data, method = "approximate"
)

#------------------------------------------------------------
# 9. Extract predictions from crossbasis of temp and prep
#------------------------------------------------------------


pred_best_t <- crosspred(temp_cb, mod,
  cen = tg_per[6],
  at = c(16:28), bylag = 0.25
)

pred_best_p <- crosspred(prep_cb, mod,
  cen = prcp_per[6],
  at = c(seq(0, 60, 5)), bylag = 0.25
)



#------------------------------------------------------------
# 10. Contour plot (Fig 3A, Fig 3B)
#------------------------------------------------------------
# 10a. Contour Plots  Temp
seqlag <- function(lag, by = 1) seq(from = lag[1], to = lag[2], by = by)
levels <- pretty(pred_best_t$matRRfit, 30)
col1 <- colorRampPalette(c("blue", "white"))
col2 <- colorRampPalette(c("white", "red"))
col <- c(col1(sum(levels < 1)), col2(sum(levels > 1)))
filled.contour(
  x = pred_best_t$predvar, y = (seqlag(pred_best_t$lag, pred_best_t$bylag) + 1),
  z = pred_best_t$matRRfit, col = col, plot.title = title(
    main = "A", adj = 0.6,
    xlab = "Weekly Avg Temp (°C)",
    ylab = "Lag (weeks)"
  ),
  levels = levels, key.title = title("OR", cex.main = 0.75, line = 0.2),
  plot.axes = {
    axis(1)
    axis(2)
    lines(c(tg_per[6], tg_per[6]), c(0, 8), lty = 2)
    lines(c(tg_per[6]+1, tg_per[6]+1), c(0, 8), lty = 1)
  }
)


# 10b. Contour Plots  Temp

seqlag <- function(lag, by = 1) seq(from = lag[1], to = lag[2], by = by)
levels <- pretty(pred_best_p$matRRfit, 30)
col1 <- colorRampPalette(c("goldenrod3", "white"))
col2 <- colorRampPalette(c("white", "forestgreen"))
col <- c(col1(sum(levels < 1)), col2(sum(levels > 1)))
filled.contour(
  x = pred_best_p$predvar, y = (seqlag(pred_best_p$lag, pred_best_p$bylag) + 1),
  z = pred_best_p$matRRfit, col = col, plot.title = title(
    main = "B", adj = 0.60,
    xlab = "Weekly Cum Prep (mm)",
    ylab = "Lag (weeks)"
  ),
  levels = levels, key.title = title("OR", cex.main = 0.75, line = 0.2),
  plot.axes = {
    axis(1)
    axis(2)
    lines(c(prcp_per[6], prcp_per[6]), c(0, 8), lty = 2, lwd = 1.5)
    lines(c(prcp_per[6]+10, prcp_per[6]+10), c(0, 8), lty = 1, lwd = 1.5)
  }
)


#------------------------------------------------------------
# 10. Lag specific estimates (Fig 3C, Fig 3D)
#------------------------------------------------------------



# Plot slices for each lag
plot(pred_best_t, "slices",
  var = round(tg_per[6]+1), xlab = "Lag (Weeks)", ylab = "OR",
  ci = "area", ylim = c(0.85, 1.30),
  xaxt = "n", col = "red", lwd = 2, main = "C"
)
custom_x_ticks <- c(0:7)
custom_x_labels <- c(paste(1:8))
axis(1, at = custom_x_ticks, labels = custom_x_labels)


plot(pred_best_p, "slices",
  var = round(30), xlab = "Lag (Weeks)", ylab = "OR", ci = "area",
  ylim = c(0.95, 1.21), main = "D",
  xaxt = "n", col = "forestgreen", lwd = 2
)
custom_x_ticks <- c(0:7)
custom_x_labels <- c(paste(1:8))
axis(1, at = custom_x_ticks, labels = custom_x_labels)


#------------------------------------------------------------
# 11. Cumulative estimates (Fig 4)
#------------------------------------------------------------


set.seed(234)
rug_t <- sample(clima_all$t_mean, 500, replace = F)
rug_p <- sample(clima_all$prep_cum, 500, replace = F)
pred_best_t <- crosspred(temp_cb, mod, cen = tg_per[6], at = c(16:29), bylag = 1)
pred_best_p <- crosspred(prep_cb, mod, cen = prcp_per[6], at = c(0:90), bylag = 1)

tg_per
plot(pred_best_t, "overall",
     ylim = c(0.0001, 8),
     col = "red", lwd = 2, ylab = "OR", ci = "area", log = "y", main = "A",
     xlim = c(20, 29), yaxt = "n", xlab = "Weekly Average Temperature")
y <- c(0.001, 0.01, 0.1, 1, 10)
custom_labels <- c("0.001", "0.01", "0.1", "1.0", "10.0")
axis(side = 2, at = y, labels = custom_labels)
rug(rug_t, ticksize = 0.05, side = 1, lwd = 0.0001, col = par("fg"))
abline(v = tg_per[6], lty = "dashed", lwd = 1.5)
abline(v = tg_per[7], col = "coral1", lwd = 1.5)
abline(v = tg_per[8], col = "coral3", lwd = 1.5)
abline(v = tg_per[9], col = "darkred", lwd = 1.5)



plot(pred_best_p, "overall",
  ylim = c(0.1, 150), log = "y",
  col = "forestgreen", lwd = 2, ylab = "OR", ci = "area", xlab = "Weekly Cumulative Precipitation",
  xlim = c(0, 90), main = "B"
)
rug(rug_p, ticksize = 0.05, side = 1, lwd = 0.0001, col = par("fg"))
abline(v = prcp_per[6], lty = "dashed", lwd = 1.5)
abline(v = prcp_per[7], col = "lightgreen", lwd = 1.5)
abline(v = prcp_per[8], col = "green", lwd = 1.5)
abline(v = prcp_per[9], col = "darkgreen", lwd = 1.5)



#------------------------------------------------------------
# 11. Compute attributable fractions(AFs) with the 
# 'attrdl' function (Table 2)
#------------------------------------------------------------

# 11a. Compute for thresholds of temp the corresponding AFs
temp_att <- NULL
for (i in c(tg_per[7:9])) {
  temp_att[[i]] <- attrdl(
    x = t_mat_avg, dir = "back", cases = data$caco,
    model = mod, basis = temp_cb, tot = TRUE, cen = tg_per[6],
    range = c(i, 35), sim = TRUE,
    type = "af", nsim = 5000
  )
}

temp_att <- Filter(Negate(is.null), temp_att)
lapply(temp_att, function(x) quantile(x, probs = c(0.5)))
lapply(temp_att, function(x) quantile(x, probs = c(0.025, 0.975)))


# 11.b Compute for thresholds of prep the corresponding AFs

prep_att <- NULL
for (i in prcp_per[7:9]) {
  prep_att[[i]] <- attrdl(
    x = p_mat_avg, dir = "back", cases = data$caco,
    model = mod, basis = prep_cb, cen = prcp_per[6], range = c(i, 100),
    sim = TRUE, type = "af", nsim = 5000
  )
}

prep_att <- Filter(Negate(is.null), prep_att)
lapply(prep_att, FUN = mean)
lapply(prep_att, function(x) quantile(x, probs = c(0.025, 0.975)))
