#---------------------------------------------------------
# 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).
#
#  ! Analyses are run on a simulated dataset.       !
#  ! Results and Figure will differ from results    ! 
#  ! presented in the manuscript.                   !
# 
# Author(s): Giovenale Moirano
#
# Date Created:5 May 2024
#
# Email: giovenale.moirano@bsc.es
#
#---------------------------------------------------------
# 1. Clean Environment
#---------------------------------------------------------

rm(list = ls())

#---------------------------------------------------------
# 2. 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")

#------------------------------------------------------------
# 3.Set WD
#------------------------------------------------------------

#setwd("mydirectory/Code_wnv_cc")

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

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

data$date <- as.Date(format(
  as.Date("1970-01-01") +
    data$sampling_date - 1,
  "%Y-%m-%d"
))

# Define matching strata for conditional logistic analysis
data$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 c(7, 14, 21, 28, 35, 42, 49, 56)) {
  a[[ceiling(i / 7)]] <- apply(t_mat[, (i - 7):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 c(7, 14, 21, 28, 35, 42, 49, 56)) {
  a2[[ceiling(i / 7)]] <- apply(p_mat[, (i - 7):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/7.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
))
prep_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)]
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
lag_knots <- c(1.66, 4.32)

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(id),
  data = data, method = "approximate"
)

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


pred_best_t <- crosspred(temp_cb, mod,
  cen = 24,
  at = c(16:28), bylag = 0.25
)

pred_best_p <- crosspred(prep_cb, mod,
  cen = 23,
  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(24, 24), c(0, 8), lty = 2)
    lines(c(25, 25), 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(23, 23), c(0, 8), lty = 2, lwd = 1.5)
    lines(c(33, 33), 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(25), xlab = "Lag (Weeks)", ylab = "OR",
  ci = "area", ylim = c(0.95, 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(35), 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 = round(24), at = c(16:29), bylag = 1)
pred_best_p <- crosspred(prep_cb, mod, cen = round(23), at = c(0:90), bylag = 1)

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 = 23, lty = "dashed", lwd = 1.5)
abline(v = 40, col = "lightgreen", lwd = 1.5)
abline(v = 53, col = "green", lwd = 1.5)
abline(v = 87, col = "darkgreen", lwd = 1.5)



plot(pred_best_t, "overall",
  ylim = c(0.0001, 8),
  col = "red", lwd = 2, ylab = "OR", ci = "area", log = "y", main = "A",
  xlim = c(18, 29), yaxt = "n", xlab = "Weekly Average Temperature"
)

y <- (c(0.001, 0.01, 0.1, 1, 5))
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 = 24, lty = "dashed", lwd = 1.5)
abline(v = 25.5, col = "coral1", lwd = 1.5)
abline(v = 26.5, col = "coral3", lwd = 1.5)
abline(v = 28.5, col = "darkred", 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(25, 26.5, 28.5)) {
  temp_att[[i]] <- attrdl(
    x = t_mat_avg, dir = "back", cases = data$caco,
    model = mod, basis = temp_cb, tot = TRUE, cen = 24,
    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 c(40, 53, 87)) {
  prep_att[[i]] <- attrdl(
    x = p_mat_avg, dir = "back", cases = data$caco,
    model = mod, basis = prep_cb, cen = 23, 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)))
