# Process D47 data for plotting in manuscript

require(tidyverse) # for data treatment
require(bfsl) # for York regressions

# Load combined aragonite dataset
dat <- as.data.frame(read.csv("01_Aragonite_compilation.csv", header = TRUE))
dat$sample <- paste(dat$Temp, dat$Analysis, sep = "_")

source("03_Average_error_propagation.r")

# ------------------------Summarize stats per data ID---------------------------
D47stats <- dat[-which(dat$D47_outlier == TRUE),] %>% # Summarize D47 statistics
    group_by(ID) %>%
    summarize(
        Temp = propagate_MC(x = Temp, x_sd = Temp_SD, na.rm = TRUE, output = "average"),
        Temp_SD = propagate_MC(x = Temp, x_sd = Temp_SD, na.rm = TRUE, output = "SD"),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_mean = propagate_MC(x = D47, x_sd = D47_SD, na.rm = TRUE, output = "average"),  # Calculate means per sample
        sd = propagate_MC(x = D47, x_sd = D47_SD, na.rm = TRUE, output = "SD"),  # Calculate stdevs per sample
        N = n(), # Calculate the number of modelled values, excluding NA's
        se = sd / sqrt(N), # Calculate the standard error
        CL95 = qt(0.95, N) * se, # Calculate the 95% confidence level
        param49_mean = propagate_MC(x = param49, x_sd = param49_sd, na.rm = TRUE, output = "average"), # Propagate param49 mean per sample
        param49_sd = propagate_MC(x = param49, x_sd = param49_sd, na.rm = TRUE, output = "SD"), # Propagate param49 SD per sample
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    ) %>%
    ungroup()

# Summarize stats for Arctica islandica samples per specimen
Aisstats <- dat[which(dat$D47_outlier != TRUE & dat$Analysis == "this study"), ] %>% # Summarize D47 statistics
    group_by(Specimen) %>%
    summarize(
        sample = first(sample),
        Temp = propagate_MC(x = Temp, x_sd = Temp_SD, na.rm = TRUE, output = "average"),
        Temp_SD = propagate_MC(x = Temp, x_sd = Temp_SD, na.rm = TRUE, output = "SD"),
        Analysis = first(Analysis),
        type = first(type),
        D47_mean = propagate_MC(x = D47, x_sd = D47_SD, na.rm = TRUE, output = "average"),  # Calculate means per sample
        sd = propagate_MC(x = D47, x_sd = D47_SD, na.rm = TRUE, output = "SD"),  # Calculate stdevs per sample
        N = n(), # Calculate the number of modelled values, excluding NA's
        se = sd / sqrt(N), # Calculate the standard error
        CL95 = qt(0.95, N) * se, # Calculate the 95% confidence level
        param49_mean = propagate_MC(x = param49, x_sd = param49_sd, na.rm = TRUE, output = "average"), # Propagate param49 mean per sample
        param49_sd = propagate_MC(x = param49, x_sd = param49_sd, na.rm = TRUE, output = "SD"), # Propagate param49 SD per sample
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    ) %>%
    ungroup()

write.csv(D47stats_old, "out/Aragonite_dataset_naive_stats.csv")

# Monte Carlo sample from individual aliquot distributions for violin plots and polynomial regression including errors on D47
Nsim <- 10 ^ 4
violin_data <- data.frame(sample = rep(dat$sample, Nsim),
    type = rep(dat$type, Nsim),
    Analysis = rep(dat$Analysis, Nsim),
    ID = rep(dat$ID, Nsim),
    Specimen = rep(dat$Specimen, Nsim),
    Temp = rep(dat$Temp, Nsim),
    Temp_sampled = rnorm(Nsim * length(dat$Temp), dat$Temp, dat$Temp_SD),
    D47 = rnorm(Nsim * length(dat$D47), dat$D47, dat$D47_SD),
    param49 = rnorm(Nsim * length(dat$param49), dat$param49, dat$param49_sd),
    outlier = rep(dat$D47_outlier, Nsim)
)

violin_data$x <- 10 ^ 6 / (violin_data$Temp_sampled + 273.15) ^ 2 # Create 10^6/T^2 vector

# ------------------------Pairwise comparisons----------------------------------

Aisdata <- dat[which(dat$D47_outlier != TRUE & dat$Analysis == "this study"), ] # Isolate Arctica islandica data from this study
Ais_temp_aov <- aov(D47 ~ ID, data = Aisdata) # Conduct one-way ANOVA on temperature bins
capture.output(summary(Ais_temp_aov), file = "out/Ais_Pairwise_comp_temp_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_temp_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on temperature bins
write.csv(TukeyHSD(Ais_temp_aov)$ID, "out/Ais_Pairwise_comp_temp.csv") # Export summary of Tukey multiple pairwise-comparisons

Ais_spec1_aov <- aov(D47 ~ Specimen, data = Aisdata[which(Aisdata$Temp == 1.1), ]) # Conduct one-way ANOVA on Specimen bins within the 1 degree temperature treatment
capture.output(summary(Ais_spec1_aov), file = "out/Ais_Pairwise_comp_spec1_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_spec1_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on specimen bins
write.csv(TukeyHSD(Ais_spec1_aov)$Specimen, "out/Ais_Pairwise_comp_spec1.csv") # Export summary of Tukey multiple pairwise-comparisons

Ais_spec18_aov <- aov(D47 ~ Specimen, data = Aisdata[which(Aisdata$Temp == 18.0), ]) # Conduct one-way ANOVA on Specimen bins within the 18 degree temperature treatment
capture.output(summary(Ais_spec18_aov), file = "out/Ais_Pairwise_comp_spec18_summary.txt") # Print summary of ANOVA
TukeyHSD(Ais_spec18_aov) # Print results of Tukey multiple pairwise-comparisons (post-hoc Tukey's test) on specimen bins
write.csv(TukeyHSD(Ais_spec18_aov)$Specimen, "out/Ais_Pairwise_comp_spec18.csv") # Export summary of Tukey multiple pairwise-comparisons

# ----------------------------Regressions---------------------------------------

# TLinear York regression both with and without high temperature datapoints
D47m_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE] + dat$Temp_SD[dat$D47_outlier == FALSE] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE] - dat$Temp_SD[dat$D47_outlier == FALSE] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE],
    r = 0)
newdat_York <- data.frame(x = 10 ^6 / (seq(0, 1000, 0.1) + 273.15) ^ 2)
D47m_York_pred <- predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_York_result <- cbind(newdat_York, D47m_York_pred$fit)

D47m_lowT_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + dat$Temp_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] - dat$Temp_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & dat$Analysis != "Muller17"],
    r = 0)
newdat_lowT_York <- data.frame(x = 10 ^6 / (seq(0, 100, 0.1) + 273.15) ^ 2)
D47m_lowT_York_pred <- predict(D47m_lowT_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_lowT_York_result <- cbind(newdat_lowT_York, D47m_lowT_pred$fit)

# Calculate linear York regression on A. islandica and all bivalve data
Ais_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] - dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica")],
    r = 0)
Ais_York_pred <- predict(Ais_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
Ais_York_result <- cbind(newdat_lowT_York, Ais_York_pred$fit)

Mollusk_York <- bfsl(x = 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2,
    y = dat$D47[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")],
    sd_x = abs(10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2 - 10^6 / (dat$Temp[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] - dat$Temp_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")] + 273.15) ^ 2) / 2,
    sd_y = dat$D47_SD[dat$D47_outlier == FALSE & (dat$Analysis == "this study" | dat$ID == "A.islandica" | dat$Analysis == "Caldarescu21")],
    r = 0)
Mollusk_York_pred <- predict(Mollusk_York, newdata = newdat_lowT_York, se.fit = TRUE, interval = "confidence", level = 0.95)
Mollusk_York_result <- cbind(newdat_lowT_York, Mollusk_York_pred$fit)

# Third order polynomial regression following Müller et al., 2019 and Jautzy et al., 2020
D47m_poly <- lm(D47 ~ poly(I(10^6 / (Temp + 273.15) ^ 2), 3), data = dat, subset = which(dat$D47_outlier == FALSE))
D47m_poly_pred <- predict.lm(D47m_poly, newdata = reaname(newdat_York, Temp = x), se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_poly_result <- cbind(10^6 / (newdat + 273.15) ^2, D47m_poly_pred$fit)

# Polynomial regression with errors on D47 and Temp using MC simulation
D47m_poly_MC <- lm(D47 ~ poly(x, 3), data = violin_data, subset = which(violin_data$outlier == FALSE))
D47m_poly_MC_pred <- predict.lm(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "confidence", level = 0.95)
D47m_poly_MC_result <- cbind(newdat_York, D47m_poly_MC_pred$fit)
# Readjust 95% CL calculations for actual degrees of freedom
D47m_poly_MC_result$lwr <- D47m_poly_MC_result$fit - (D47m_poly_MC_result$fit - D47m_poly_MC_result$lwr) * sqrt(D47m_poly_MC$df.residual) / sqrt(length(violin_data$D47) / Nsim - 4)
D47m_poly_MC_result$upr <- D47m_poly_MC_result$fit + (D47m_poly_MC_result$upr - D47m_poly_MC_result$fit) * sqrt(D47m_poly_MC$df.residual) / sqrt(length(violin_data$D47) / Nsim - 4)

# -----------------------Add Preexisting calibrations---------------------------
# Add dummy data to plot Anderson calibration
Anderson21 <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47 = 0.0391 * 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2 + 0.154) # Latest Anderson calibration

# Add dummy data to plot Meinicke calibration
MeinickeICDES <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47 = 0.0397 * 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2 + 0.1518) # Recalculated Meinicke calibration

# Add theoretical calcite and aragonite calibration lines by Guo et al. 2009
Guo09 <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47_cc = -3.33040 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 5.54042 / (seq(0, 1000, 0.1) + 273.15) + 0.23252,
    D47_ar = -3.43068 * 10 ^ 9 / (seq(0, 1000, 0.1) + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (seq(0, 1000, 0.1) + 273.15) ^ 3 - 8.06003 * 10 ^ 3 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893)

# Arctica islandica plot (Figure 1)
# See A_islandica_plot.r

# Full aragonite dataset plot (Figure 2)
# See Full_aragonite_plot.r

# Summarize regression stats
regstats <- data.frame(regression = c("All data lm", "low T lm", "All data York", "low T York", "A. islandica York", "Mollusk York"),
    slope = c(D47m$coefficients[[2]], D47m_lowT$coefficients[[2]], D47m_York$coefficients[[2]], D47m_lowT_York$coefficients[[2]], Ais_York$coefficients[[2]], Mollusk_York$coefficients[[2]]),
    slope_SE = c(summary(D47m)$coeff[[4]], summary(D47m_lowT)$coeff[[4]], D47m_York$coefficients[[4]], D47m_lowT_York$coefficients[[4]], Ais_York$coefficients[[4]], Mollusk_York$coefficients[[4]]),
    intercept = c(D47m$coefficients[[1]], D47m_lowT$coefficients[[1]], D47m_York$coefficients[[1]], D47m_lowT_York$coefficients[[1]], Ais_York$coefficients[[1]], Mollusk_York$coefficients[[1]]),
    intercept_SE = c(summary(D47m)$coeff[[3]], summary(D47m_lowT)$coeff[[3]], D47m_York$coefficients[[3]], D47m_lowT_York$coefficients[[3]], Ais_York$coefficients[[3]], Mollusk_York$coefficients[[3]]),
    SER = c(sigma(D47m), sigma(D47m_lowT), sqrt(sum(D47m_York$residuals ^ 2) / D47m_York$df.residual), sqrt(sum(D47m_lowT_York$residuals ^ 2) / D47m_lowT_York$df.residual), sqrt(sum(Ais_York$residuals ^ 2) / Ais_York$df.residual), sqrt(sum(Mollusk_York$residuals ^ 2) / Mollusk_York$df.residual))
)

regstats_poly <- data.frame(regression = c("Polynomial fit_means", "Polynomial fit_MC"),
    Intercept = c(summary(D47m_poly)$coefficients[1, 1], summary(D47m_poly_MC)$coefficients[1, 1]),
    Intercept_SE = c(summary(D47m_poly)$coefficients[1, 2], summary(D47m_poly_MC)$coefficients[1, 2]),
    Term1 = c(summary(D47m_poly)$coefficients[2, 1], summary(D47m_poly_MC)$coefficients[2, 1]),
    Term1_SE = c(summary(D47m_poly)$coefficients[2, 2], summary(D47m_poly_MC)$coefficients[2, 2]),
    Temm2 = c(summary(D47m_poly)$coefficients[3, 1], summary(D47m_poly_MC)$coefficients[3, 1]),
    Term2_SE = c(summary(D47m_poly)$coefficients[3, 2], summary(D47m_poly_MC)$coefficients[3, 2]),
    Term3 = c(summary(D47m_poly)$coefficients[4, 1], summary(D47m_poly_MC)$coefficients[4, 1]),
    Term3_SE = c(summary(D47m_poly)$coefficients[4, 2], summary(D47m_poly_MC)$coefficients[4, 2]),
    SER = c(sigma(D47m_poly), sigma(D47m_poly_MC))
)

# Export summary of regression stats
# write.csv(regstats, "<path>/Aragonite_calibration_regression_statistics.csv")
# write.csv(regstats_poly, "<path>/Aragonite_calibration_polynomial_regression_statistics.csv")

# -------------------------Regression residuals---------------------------------
# Extract D47 values and their errors for temperatures of all samples
newdat_York <- data.frame(x = 10 ^6 / (dat$Temp + 273.15) ^ 2)
dat$D47res_York <- dat$D47 - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_lowT_York <- dat$D47 - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_poly <- dat$D47 - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
dat$D47res_Anderson <- dat$D47 - (0.0391 * 10 ^ 6 / (dat$Temp + 273.15) ^ 2 + 0.154)
dat$D47res_Meinicke <- dat$D47 - (0.0397 * 10 ^ 6 / (dat$Temp + 273.15) ^ 2 + 0.1518)

newdat_York <- data.frame(x = 10 ^6 / (D47stats$Temp + 273.15) ^ 2)
D47stats$D47res_York <- D47stats$D47_mean - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_lowT_York <- D47stats$D47_mean - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_poly <- D47stats$D47_mean - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
D47stats$D47res_Anderson <- D47stats$D47_mean - (0.0391 * 10 ^ 6 / (D47stats$Temp + 273.15) ^ 2 + 0.154)
D47stats$D47res_Meinicke <- D47stats$D47_mean - (0.0397 * 10 ^ 6 / (D47stats$Temp + 273.15) ^ 2 + 0.1518)

newdat_York <- data.frame(x = 10 ^6 / (Aisstats$Temp + 273.15) ^ 2)
Aisstats$D47res_York <- Aisstats$D47_mean - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_lowT_York <- Aisstats$D47_mean - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_poly <- Aisstats$D47_mean - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
Aisstats$D47res_Anderson <- Aisstats$D47_mean - (0.0391 * 10 ^ 6 / (Aisstats$Temp + 273.15) ^ 2 + 0.154)
Aisstats$D47res_Meinicke <- Aisstats$D47_mean - (0.0397 * 10 ^ 6 / (Aisstats$Temp + 273.15) ^ 2 + 0.1518)

newdat_York <- data.frame(x = 10 ^6 / (violin_data$Temp + 273.15) ^ 2)
violin_data$D47res_York <- violin_data$D47 - predict(D47m_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_lowT_York <- violin_data$D47 - predict(D47m_lowT_York, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_poly <- violin_data$D47 - predict(D47m_poly_MC, newdata = newdat_York, se.fit = TRUE, interval = "none", level = 0.95)$fit
violin_data$D47res_Anderson <- violin_data$D47 - (0.0391 * 10 ^ 6 / (violin_data$Temp + 273.15) ^ 2 + 0.154)
violin_data$D47res_Meinicke <- violin_data$D47 - (0.0397 * 10 ^ 6 / (violin_data$Temp + 273.15) ^ 2 + 0.1518)

D47m_York_result_res <- D47m_York_result - D47m_York_result$fit
D47m_York_result_res$x <- D47m_York_result_res$x + D47m_York_result$fit
D47m_York_result_res$Anderson <- Anderson21$D47 - D47m_York_result$fit
D47m_York_result_res$Meinicke <- MeinickeICDES$D47 - D47m_York_result$fit
D47m_lowT_York_result_res <- D47m_lowT_York_result - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$x <- D47m_lowT_York_result_res$x + D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Anderson <- Anderson21$D47[1:1001] - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Meinicke <- MeinickeICDES$D47[1:1001] - D47m_lowT_York_result$fit
D47m_poly_MC_result_res <- D47m_poly_MC_result - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$x <- D47m_poly_MC_result_res$x + D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Anderson <- Anderson21$D47 - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Meinicke <- MeinickeICDES$D47 - D47m_poly_MC_result$fit

# Export summary of regression residuals
# write.csv(Aisstats, "<path>/Arctica_dataset_propagated_stats.csv")
# write.csv(D47stats, "<path>/Aragonite_dataset_propagated_stats.csv")

# Plot of residuals with respect to regressions (Figure 3)
# See Aragonite_residual_plot.r

# Prepare summary of calibration offsets
calibration_offset <- data.frame(D47_offset = c(dat$D47res_Anderson[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))], dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))]),
    D47_SD = rep(dat$D47_SD[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))], 2),
    Calibration = c(rep("Anderson et al., 2021", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])), rep("Meinicke et al., 2020", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])))
)

# Calculate the temperature equivalent of the calibration offset
mean_Temp <- mean(dat$Temp[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])
mean_D47 <- 0.0391 * 10 ^ 6 / (mean_Temp + 273.13) ^ 2 + 0.154

# Statistics of difference with calibration
Calibration_offset_stats <- calibration_offset %>% # Summarize D47 offset statistics
    group_by(Calibration) %>%
    summarize(
        N = n(), # Calculate the number of modelled values, excluding NA's
        D47_offset_Average = propagate_MC(x = D47_offset, x_sd = D47_SD, na.rm = TRUE, output = "average"),
        D47_offset_SD = propagate_MC(x = D47_offset, x_sd = D47_SD, na.rm = TRUE, output = "SD"),
        D47_offset_SE = D47_offset_SD / sqrt(N - 1), # Calculate the standard error
        D47_offset_CL95 = qt(0.95, N - 1) * D47_offset_SE # Calculate the 95% confidence level
    ) %>%
    ungroup()

Calibration_offset_stats$Temp_offset_Average <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - 0.154)) - 273.15 - mean_Temp
Calibration_offset_stats$Temp_offset_SD <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_SD - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average
Calibration_offset_stats$Temp_offset_SE <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_SE - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average
Calibration_offset_stats$Temp_offset_CL95 <- sqrt(0.0391 * 10 ^ 6 / (mean_D47 - Calibration_offset_stats$D47_offset_Average - Calibration_offset_stats$D47_offset_CL95 - 0.154)) - 273.15 - mean_Temp - Calibration_offset_stats$Temp_offset_Average

# write.csv(Calibration_offset_stats, "<path>/Calibration_offset_stats.csv")

# Plot calibration offsets (Figure 4)
# See Calibration_offset_plot.r


### Sensitivity analysis and its corresponding power and sample size functions

ARsens.test=function(ivmodel, beta0=0, alpha=0.05, deltarange=NULL){
  if(is.null(deltarange))
    return(NULL)

  Yadj = ivmodel$Yadj; Dadj = ivmodel$Dadj; Zadj = ivmodel$Zadj;
  n=ivmodel$n;  k=ivmodel$p;  l=ivmodel$L

  if(ncol(Yadj)>1){
    print("The outcome variable should be in one dimension!")
	return(NULL)
  }
  if(ncol(Dadj)>1){
    print("The treatment variable should be in one dimension!")
	return(NULL)
  }
  if(l+k>=n){
    print("Too many IVs, AR can't handle!")
    return(NULL)
  }

  if(l!=1){
    print("Please input exact one IV for AR sensitivity analysis")
	return(NULL)
  }

  if(is.numeric(deltarange) & length(deltarange)==2){
    ncp=max(deltarange^2)*sum(Zadj^2)
  }else{
    print("Wrong input of the sensitivity range.")
    return(NULL)
  }

### test
  temp=Yadj-beta0*Dadj
  ncFstat=c(sum(qr.fitted(ivmodel$ZadjQR, temp)^2))/c(sum(temp^2)-sum(qr.fitted(ivmodel$ZadjQR, temp)^2))*(n-k-l)/l
  p.value=1-pf(ncFstat, df1=l, df2=n-k-l, ncp=ncp)

### confidence interval
  cval=qf(1-alpha, df1=l, df2=n-k-l, ncp=ncp)*l/(n-k-l)
  coef.beta0sq=cval*sum(Dadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Dadj)^2)
  coef.beta0=-2*cval*sum(Dadj*Yadj)+2*(cval+1)*sum(Dadj*qr.fitted(ivmodel$ZadjQR, Yadj))
  coef.constant=cval*sum(Yadj^2)-(cval+1)*sum(qr.fitted(ivmodel$ZadjQR, Yadj)^2)
  Delta=coef.beta0^2-4*coef.constant*coef.beta0sq

  ci=matrix(NA, ncol=2)
  colnames(ci)<-c("lower", "upper")

  if(coef.beta0sq==0){
    if(coef.beta0>0){
      info=c("[",-coef.constant/coef.beta0,",Infinity)")
      ci[1,]=c(-coef.constant/coef.beta0, Inf)
    }
    if(coef.beta0<0){
      info=c("(-Infinity,",-coef.constant/coef.beta0,"]");
      ci[1,]=c(-Inf, -coef.constant/coef.beta0)
    }
    if(coef.beta0==0){
      if(coef.constant>=0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.constant<0){
        info="Empty Set"
      }
    }
  }

  if(coef.beta0sq!=0){
    if(Delta<=0){
      if(coef.beta0sq>0){
        info="Whole Real Line"
        ci[1,]=c(-Inf, Inf)
      }
      if(coef.beta0sq<0){
        info="Empty Set"
      }
    }
    if(Delta>0){
      # Roots of quadratic equation
      root1=(-coef.beta0+sqrt(Delta))/(2*coef.beta0sq)
      root2=(-coef.beta0-sqrt(Delta))/(2*coef.beta0sq)
      upper.root=max(root1,root2)
      lower.root=min(root1,root2)
      if(coef.beta0sq<0){
        info=paste("[",lower.root,",",upper.root,"]")
        ci[1, ]=c(lower.root, upper.root)
      }
      if(coef.beta0sq>0){
        info= paste("(-Infinity,",lower.root,"] union [",upper.root,",Infinity)")
        ci[1, ]=c(-Inf, lower.root)
        ci<-rbind(ci, c(upper.root, Inf))
      }
    }
  }

  return(list(ncFstat=ncFstat, df=c(l, n-k-l), ncp=ncp,
              p.value=p.value, ci.info=info, ci=ci, deltarange=deltarange))
}

ARsens.size=function(power, k, beta, gamma, Zadj_sq, sigmau, sigmav,
                     rho, alpha=0.05, deltarange=deltarange, delta=NULL){
  if(!is.numeric(gamma) | length(gamma)!=1){
	print("Wrong input of gamma or gamma is not one dimension")
	stop()
  }

  if(!is.numeric(Zadj_sq) | length(Zadj_sq)!=1){
	print("Wrong input of Zadj_sq or Zadj_sq is not one dimension")
	stop()
  }

  if(is.numeric(deltarange) & length(deltarange)==2){
    deltarange<-sort(deltarange)
    ncp2=max(deltarange^2)*Zadj_sq
	if(is.null(delta)){
	  if((deltarange[1] < -gamma*beta/sigmau) &
	     (deltarange[2] > -gamma*beta/sigmau)){
	    ncp1=0
	  }else{
	    ncp1=min((beta*gamma+deltarange[1]*sigmau)^2,
		         (beta*gamma+deltarange[2]*sigmau)^2)*
		     Zadj_sq/(sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)
	  }
	}else{
	  ncp1=(beta*gamma+delta*sigmau)^2*Zadj_sq/
	       (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)
	}
  }else{
    print("Wrong input of the sensitivity range.")
    stop()
  }

  if(ncp1<=ncp2){
    print("Sensitivity range too large")
	stop()
  }else{
    oldn<-k+2
    state<-1
    while(state){
      temp = qf(1-alpha, df1=1, df2=oldn-k-1, ncp=ncp2*oldn)
      temppower = 1-pf(temp, df1=1, df2=oldn-k-1, ncp=ncp1*oldn)
      if(temppower < power){
	    oldn <- oldn*2
	  }else{
	    state <- 0
	  }
    }

    lower <- oldn%/%2
    upper <- oldn
    while((upper-lower)>2){
      new <- (upper+lower)%/%2
      temp = qf(1-alpha, df1=1, df2=oldn-k-1, ncp=ncp2*new)
      temppower = 1-pf(temp, df1=1, df2=oldn-k-1, ncp=ncp1*new)
      if(temppower < power){
	    lower <- new
	  }else{
	    upper <- new
	  }
    }
  }
  return(upper)
}

#####  calculate the power of AR sensitivity analysis

ARsens.power=function(n, k, beta, gamma, Zadj_sq, sigmau, sigmav,
                      rho, alpha=0.05, deltarange=deltarange, delta=NULL){
  if(!is.numeric(gamma) | length(gamma)!=1){
	print("Wrong input of gamma or gamma is not one dimension")
	stop()
  }

  if(!is.numeric(Zadj_sq) | length(Zadj_sq)!=1){
	print("Wrong input of Zadj_sq or Zadj_sq is not one dimension")
	stop()
  }

  if(is.numeric(deltarange) & length(deltarange)==2){
    deltarange<-sort(deltarange)
    ncp2=max(deltarange^2)*n*Zadj_sq
	if(is.null(delta)){
	  if((deltarange[1] < -gamma*beta/sigmau) &
	     (deltarange[2] > -gamma*beta/sigmau)){
	    ncp1=0
	  }else{
	    ncp1=min((beta*gamma+deltarange[1]*sigmau)^2,
		         (beta*gamma+deltarange[2]*sigmau)^2)*
		     n*Zadj_sq/(sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)
	  }
	}else{
	  ncp1=(beta*gamma+delta*sigmau)^2*n*Zadj_sq/
	       (sigmau^2+2*rho*sigmau*sigmav*beta+sigmav^2*beta^2)
	}
  }else{
    print("Wrong input of the sensitivity range.")
    stop()
  }

  temp = qf(1-alpha, df1=1, df2=n-k-1, ncp=ncp2)
  power = 1-pf(temp, df1=1, df2=n-k-1, ncp=ncp1)

  return(power)
}


# install.packages("forecast")
# install.packages("tsbox")
# install.packages("lubridate")
# install.packages("knitr")
# install.packages("pracma")
# install.packages("arfima")
# install.packages("Metrics")
# install.packages("fracdiff")

# set working directory
setwd(paste("E://Projects/Master-Diploma/CryptoAnalyzer",
"/R-crypto_forecasting/updated_datasets", sep = ""))

# get crypto data
get_data <- function(file_name) {
    return(read.csv(file_name, header = T, na.string = "?"))
}

# create time series from crypto data
get_time_series <- function(ts_table) {
    start_full_date <- ts_table$Date[1]
    close_full_date <- ts_table$Date[length(ts_table$Date)]
    start_date <- strsplit(start_full_date, " ")[[1]][1]
    close_date <- strsplit(close_full_date, " ")[[1]][1]
    time_seq <- seq(from = as.Date(start_date),
                    to = as.Date(close_date),
                    by = 1)
    ts_data <- xts::xts(x = ts_table$Close, order.by = time_seq)
    return(tsbox::ts_ts(ts_data))
}

# export forecasted values to csv file
forecasted_to_csv <- function(dates, forecasted_vals, csv_path) {
    forecasted_df <- data.frame(Date = dates, Close = forecasted_vals)
    write.csv(forecasted_df,
              csv_path,
              row.names = FALSE,
              quote = FALSE)
}

# find best arfima model from input quantity of ar and ma parameters
find_best_arfima_model <- function(ar_params, ma_params, train, horizon) {
    min_mse <- Inf
    return_params <- c(0, 0, 0)

    for (ar in ar_params) {
        for(ma in ma_params) {
            d_test <- fracdiff::fracdiff(train, nar = ar, nma = ma)$d
            model_arfima_test <- arfima::arfima(train,
                                    order = c(ar, ma, d_test),
                                    numeach = c(1, 1))
            forecasted_arfima_test <- predict(model_arfima_test,
                                    n.ahead = horizon)
            forecasted_arfima_test_vals <- forecasted_arfima_test[[1]]$Forecast
            test_mse <- Metrics::rmse(test, forecasted_arfima_test_vals)

            if (min_mse > test_mse) {
                min_mse <- test_mse
                return_params <- c(ar, ma, d_test)
            }
        }
    }

    return(return_params)
}

btc_close <- get_data("BitcoinTransformedClose.csv")
fix(btc_close)

ts_data <- get_time_series(btc_close)

# get Hurst exponent using R/S analysis
print(pracma::hurstexp(ts_data))

horizon <- 30

train <- head(ts_data, -horizon)
# train <- tail(head(ts_data, -horizon), 500)
test <- tail(ts_data, horizon)

forecast::tsdisplay(train, main = "Bitcoin close price")

cat("\n")

# time measuring of auto arfima modeling and forecasting
start_time <- Sys.time()

model <- forecast::arfima(train)
print(summary(model))
forecast::tsdisplay(model$residuals, main = "Residuals")
forecasted_out <- forecast::forecast(model, level = c(95), h = horizon)

end_time <- Sys.time()
time_taken <- end_time - start_time

cat("\n")
print(time_taken)

forecasted_dates_numeric <- as.numeric(row.names(as.data.frame(forecasted_out)))

forecasted_values <- forecasted_out[2]$mean
forecasted_dates <- format(lubridate::date_decimal(forecasted_dates_numeric),
                    "%Y-%m-%d")

par(c(1, 1))
plot(forecasted_out,
     xaxt = "n",
     xlab = "Date",
     ylab = "Bitcoin close price (USD)",
     xlim = c(time(train)[length(train) - 60],
            forecasted_dates_numeric[length(forecasted_dates_numeric)]),
    #  main = "ARFIMA model predictions",
     showgap = FALSE,
     shadecols = "#205bff6a",
     fcol = "#1d1dff")
axis(1,
     time(ts_data),
     format(lubridate::date_decimal(as.numeric(time(ts_data))), "%Y-%m-%d"))

# forecasted_to_csv(forecasted_dates,
#                   forecasted_values,
#                   "BitcoinForecasted.csv")
cat("\n")
print(forecast::arimaorder(model))
print("ARFIMA accuracy: ")
print(forecast::accuracy(forecasted_out, test))

# auto arima modelling and forecasting
model_arima <- forecast::auto.arima(train)
forecasted_arima_out <- forecast::forecast(model_arima,
                                  level = c(95),
                                  h = horizon)
cat("\n")
print(forecast::arimaorder(model_arima))
print("ARIMA accuracy: ")
print(forecast::accuracy(forecasted_arima_out, test))
cat("\n")

# manually fitted arfima modeling and forecasting
m_gph <- fracdiff::fdGPH(train)
diff_train <- fracdiff::diffseries(train, d = m_gph$d)
forecast::tsdisplay(diff_train, main = "Differenciated BTC close price")

# from acf and pacf plots get significant spikes
ar_params <- c(0, 1, 2, 3, 4, 5, 6)
ma_params <- c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

oldw <- getOption("warn")
options(warn = -1)
param_vec <- (find_best_arfima_model(ar_params, ma_params, train, horizon))
options(warn = oldw)

ar_param <- param_vec[1]
ma_param <- param_vec[2]
d_param <- param_vec[3]

model_arfima_man <- arfima::arfima(train,
                                   order = c(ar_param, ma_param, d_param),
                                   numeach = c(1, 1))
forecasted_arfima_man_out <- predict(model_arfima_man,
                                     n.ahead = horizon)

plot(residuals(model_arfima_man)[[1]],
               ylab = "",
               type = "b",
               main = paste0("Residuals of ARFIMA(",
                 ar_param, ",", ma_param, ",", d_param, ")"))
acf(residuals(model_arfima_man)[[1]],
 main = paste0("Residuals of ARFIMA(",
  ar_param, ",", ma_param, ",", d_param, ") ACF"))
pacf(residuals(model_arfima_man)[[1]],
 main = paste0("Residuals of ARFIMA(",
  ar_param, ",", ma_param, ",", d_param, ") PACF"))

forecasted_arfima_man_values <- forecasted_arfima_man_out[[1]]$Forecast

cat("\n")
print("p d q")
print(paste(ar_param, d_param, ma_param))
print("ARFIMA manually fitted accuracy: ")
cat("\n")
print(paste0("Test set RMSE: ",
             Metrics::rmse(test, forecasted_arfima_man_values)))
print(paste0("Test set MAPE (%): ",
             Metrics::mape(test, forecasted_arfima_man_values) * 100))

# models comparison using AIC statistics
print(knitr::kable(AIC(model, model_arima, model_arfima_man)))
cat("\n")


### fimd3.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 7mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.11

library("mice")
library("lattice")
library("gamlss")
library("rpart")

### Section 3.1 How to generate multiple imputations

### In order to draw figure 3.1, we define two tweaked
### mice.impute.xxx functions that will store the coefficients
### of the imputation models in the global environment.
### Normally, we would not be so interested in the
### parameter estimates of the imputation model, but here
### we need them for Figure 3.1.
mice.impute.normdump <- function (y, ry, x, ...)
{
    x <- cbind(1, as.matrix(x))
    parm <- .norm.draw(y, ry, x, ...)
    betadump <<- c(betadump,parm$beta)
    return(x[!ry, ] %*% parm$beta + rnorm(sum(!ry)) * parm$sigma)
}
mice.impute.pmmdump <- function (y, ry, x, ...)
{
    x <- cbind(1, as.matrix(x))
    parm <- .norm.draw(y, ry, x, ...)
    yhatobs <- x[ry, ] %*% parm$coef
    yhatmis <- x[!ry, ] %*% parm$beta
    betadump <<- c(betadump,parm$beta)
    return(apply(as.array(yhatmis), 1, .pmm.match, yhat = yhatobs,
        y = y[ry], ...))
}

### Figure 3.1
par(mfrow=c(3,2))
data <- whiteside
lwd <- 1.5
plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
points(x=5, y=3.6, pch=4, cex=2, lwd=lwd, col=mdc(2))
legend(x="bottomleft", legend="deleted observation", pch=4, col=mdc(2),
       pt.lwd=lwd, bty="n", pt.cex=2)
text(x=9, y=6.5, label="a",cex=2)

data[47,"Gas"] <- NA
plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
abline(m1<-lm(Gas~Temp, data=data, na.action=na.omit), col=mdc(4))
points(5,4.04, lwd=lwd, col=mdc(2),pch=19)
text(x=9, y=6.5, label="b",cex=2)

plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
imp <- mice(data, m=1, maxit=0)
pred <- imp$pred
pred["Gas","Insul"] <- 0
imp <- mice(data, m=5, pred=pred, meth="norm.nob", maxit=1, print=FALSE, seed=45433)
abline(m1<-lm(Gas~Temp, data=data, na.action=na.omit), col=mdc(4))
points(rep(5,5),imp$imp$Gas, lwd=lwd, col=mdc(2),pch=19)
text(x=9, y=6.5, label="c",cex=2)

plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
imp <- mice(data, m=1, maxit=0)
pred <- imp$pred
pred["Gas","Insul"] <- 0
betadump <- vector("list", 0)
imp <- mice(data, m=5, pred=pred, meth="normdump", maxit=1, print=FALSE, seed=83126)
abline(m1<-lm(Gas~Temp, data=data, na.action=na.omit), col=mdc(4))
betadump <- matrix(betadump, nc=2, byrow=TRUE)
for (i in 1:5) abline(coef=unlist(betadump[i,]), col=mdc(5))
points(rep(5,5),imp$imp$Gas, lwd=lwd, col=mdc(2),pch=19)
text(x=9, y=6.5, label="d",cex=2)

pch <- c(rep(3,26),rep(1,30))
plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd, pch=pch,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
imp <- mice(data, m=5, meth="norm", maxit=1, print=FALSE, seed=11727)
abline(m1<-lm(Gas~Temp, data=data, na.action=na.omit, subset=Insul=="Before"), col=mdc(4))
abline(m2<-lm(Gas~Temp, data=data, na.action=na.omit, subset=Insul=="After"), col=mdc(4))
points(rep(5,5),imp$imp$Gas, lwd=lwd, col=mdc(2),pch=19)
legend(x="bottomleft", legend=c("before insulation","after insulation"), pch=c(3,1),bty="n", pt.lwd=lwd)
text(x=9, y=6.5, label="e",cex=2)

pch <- c(rep(3,26),rep(1,30))
plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd, pch=pch,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
betadump <- vector("list", 0)
imp <- mice(data, m=5, meth="pmmdump", maxit=1, print=FALSE, seed=68006)
betadump <- matrix(betadump, nc=3, byrow=TRUE)
m1<-lm(Gas~Temp+Insul, data=data, na.action=na.omit)
an <- coef(m1)[1]
ai <- an + coef(m1)[3]
b <- coef(m1)[2]
abline(a=ai, b=b, col=mdc(4))
abline(a=an, b=b, col=mdc(4))
eta <- 0.6
ylo <- ai+b*(5-eta)
yhi <- ai+b*(5+eta)
lines(x=c(5-eta,5+eta),y=c(ylo,yhi),lwd=3,col=mdc(5))
xlo <- (ylo-an)/b
xhi <- (yhi-an)/b
lines(x=c(xlo,xhi),y=c(ylo,yhi),lwd=3,col=mdc(5))

donors <- subset(data, (Insul=="After"&Temp>5-eta&Temp<5+eta)
                 |    (Insul=="Before"&Temp>xlo&Temp<xhi))
points(x=donors$Temp, y=donors$Gas, cex=1.8, col=mdc(5), lwd=lwd)
legend(x="bottomleft", legend=c("before insulation","after insulation"), pch=c(3,1),bty="n", pt.lwd=lwd)
text(x=9, y=6.5, label="f",cex=2)

### Section 3.2.3 Performance

### number of simulations
### use nsim <- 10 for testing
###     nsim <- 10000 for the real stuff (TIME CONSUMING)
nsim <- 10

### create data
createdata <- function(beta0=5.49, beta1=-0.29, sigma=0.86, n=50, mx=5, sdx=3) {
  x <- round(rnorm(n,mean=mx,sd=sdx),1)
  eps <- rnorm(n,mean=0,sd=sigma)
  y <- round(beta0 + x * beta1 + eps, 1)
  return(data.frame(x=x, y=y))
}

### make 50% random missing data
makemissing <- function(data, p=0.5){
  rx <- rbinom(nrow(data), 1, p)
  data[rx==0,"y"] <- NA
  return(data)
}

### test function for three imputation functions
test.impute <- function(data, m=5, method="norm", ...){
  imp <- mice(data, method=method, m=m, print=FALSE, ridge=0, ...)
  fit <- with(imp, lm(y~x))
  est <- pool(fit)
  tab <- summary(est)
  return(tab["x",c("est","se","lo 95","hi 95","fmi","lambda")])
}

### put everything together
simulate <- function(nsim=10, seed=41872){
  set.seed(seed)
  res <- array(NA,dim=c(4, nsim, 6))
  dimnames(res) <- list(c("predict","pred + noise","Bayes MI","boot MI"),
                      as.character(1:nsim),
                      c("est","se","lo 95","hi 95","fmi","lambda"))
  im <- c("norm.predict","norm.nob","norm","norm.boot")
  for(i in 1:nsim){
    data <- createdata()
    data <- makemissing(data)
    res[1,i,] <- test.impute(data, method=im[1], m=2)
    res[2,i,] <- test.impute(data, method=im[2])
    res[3,i,] <- test.impute(data, method=im[3])
    res[4,i,] <- test.impute(data, method=im[4])
  }
  return(res)
}

summarize.results <- function(res) {
  apply(res,c(1,3),mean,na.rm=TRUE)

  ## bias of beta1
  true <- -0.29
  bias <- rowMeans(res[,,1] - true)

  ## coverage
  isin <- res[,,3] < true & true < res[,,4]
  cov <- rowMeans(isin)

  ## average width of 95 c.i.
  intwidth <- res[,,4] - res[,,3]
  aiw <- rowMeans(intwidth)

  return(list(bias=bias, cov=cov, aiw=aiw))
}

### do the simulations - MAY BE TIME CONSUMING
res <- simulate(nsim)
summarize.results(res)

### function to simulate performance of CCA
simulate.cca <- function(nsim=10, seed=41872){

  set.seed(seed)
  res <- array(NA,dim=c(1, nsim, 6))
  for(i in 1:nsim){
    data <- createdata()
    data <- makemissing(data)
    fit <- lm(y~x, data=data, na.action=na.omit)
    est <- coef(summary(fit))
    lo95 <- est[,1] - qt(0.975,fit$df) * est[,2]
    hi95 <- est[,1] + qt(0.975,fit$df) * est[,2]
    est <- cbind(est, lo95, hi95)
    res[1,i,] <- c(est["x",c(1:2,5:6)],NA,NA)
  }
  return(res)
}

### simulate - MAY BE TIME CONSUMING
res.cca <- simulate.cca(nsim)
### cannot be analysed by summarize.results() but it should
### be obvious how to calculate bias, coverage and aiw

### Section 3.2.4 Generating MAR missing data

### script to create missing data according to MARRIGHT
logistic <- function(x) exp(x)/(1+exp(x))
set.seed(32881)
n <- 10000
y <- mvrnorm(n=n,mu=c(5,5),Sigma=matrix(c(1,0.6,0.6,1),nrow=2))
p2.marright <- 1 - logistic(-5 + y[,1])
r2.marright <- rbinom(n, 1, p2.marright)
yobs <- y
yobs[r2.marright==0, 2] <- NA

### Figure 3.2

grid <- seq(0,10,0.1)
mr <- logistic(-5 + grid)
mm <- logistic( 0.75-abs(grid-5))
mt <- logistic(-0.75+abs(grid-5))

par(mfrow=c(1,1))
z <- data.frame(grid, mr, mm, mt)
matplot(x=z[,1],y=z[,2:4], type="l", lty=1:3, col=mdc(5) , lwd=2,
        xlab="Y1", ylab="Missingness in Y2", las=1)
legend(x="top", bty="n",
       legend=c("MARRIGHT","MARMID","MARTAIL"), lty=1:3, lwd=2, col=mdc(5), cex=0.8)

### Figure 3.3

y3 <- rbind(y,y,y)
p2.marmid <- 1 - logistic(0.75-abs(y[,1]-5))
p2.martail <- 1 - logistic(0.75+abs(y[,1]-5))
r2.marmid <- rbinom(n, 1, p2.marright)
r2.martail <- rbinom(n, 1, p2.martail)
r2 <- c(r2.marright,r2.marmid,r2.martail)
r2 <- factor(r2, labels=c("Ymis","Yobs"))
typ <- factor(rep(3:1,each=n),labels=c("MARTAIL","MARMID","MARRIGHT"))
d <- data.frame(y1=y3[,1],y2=y3[,2],r2=r2,typ=typ)
trellis.par.set(box.rectangle=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(box.umbrella=list(col=c(mdc(2),mdc(1)),lwd=1.2))
trellis.par.set(plot.symbol=list(col="transparent",lwd=1))
tp <- bwplot(r2~y2|typ, data=d,
             horizontal=TRUE, layout=c(1,3),
             xlab=expression(Y2),
             col=c(mdc(2),mdc(1)),strip=FALSE, xlim=c(2,8),
             strip.left = strip.custom(bg="grey95"))
print(tp)

### Section 3.2.2 Imputation from the t-distribution

mice.impute.TF <- function(y, ry, x,
                  gamlss.trace = FALSE, ...)
{
  require(gamlss)

  # prepare data
  xobs <- x[ry, , drop = FALSE]
  xmis <- x[!ry, , drop = FALSE]
  yobs <- y[ry]
  n1 <- sum(ry)
  n0 <- sum(!ry)

  # draw bootstrap sample
  s <- sample(n1, n1, replace = TRUE)
  dotxobs <- xobs[s, , drop = FALSE]
  dotyobs <- yobs[s]
  dotxy <- data.frame(dotxobs, y = dotyobs)

  # fit the gamlss model
  fit <- gamlss(y ~ ., data = dotxy, family = TF,
                trace = gamlss.trace, ...)
  yhat <- predict(fit, data=dotxy, newdata = xmis)
  sigma <- exp(coef(fit, "sigma"))
  nu <- exp(coef(fit, "nu"))

  # draw the imputations
  return(rTF(n0, yhat, sigma, nu))
}

### Section 3.3.3 Example
data(db)

### Figure 3.4

par(mfrow=c(1,2))
data <- subset(db, age>1&age<2, c("age","head"))
names(data) <- c("age","hc")
truehist(data$hc, col=mdc(1), border="white",
         xlab="Head circumference (cm)",
         ylab="Density",
         ylim=c(0,0.3), xlim=c(38,60),
         nbins=44)

mn <- gamlss(hc~1, data=na.omit(data), family=NO, trace=FALSE)
mu <- coef(mn)
sigma <- exp(coef(mn, "sigma"))
cmfine <- seq(38,60,0.1)
lines(cmfine, dNO(cmfine, mu, sigma), lwd=0.8, lty=2)
mt <- gamlss(hc~1, data=data, family=TF, trace=FALSE)
mu <- coef(mt)
sigma <- exp(coef(mt, "sigma"))
nu <- exp(coef(mt, "nu"))
lines(cmfine, dTF(cmfine, mu, sigma, nu), lwd=0.8, lty=1)
legend(x="right",legend=c("normal","t, df=6.7"),
       lwd=0.8, lty=c(2,1), bty="n", cex=0.7)

plot(x=data$age, y=data$hc, col=mdc(1), cex=0.3,
     xlab="Age (in years)",
     ylab="Head circumference (cm)",
     ylim=c(39,60))

### create a synthetic data set
data(db)
data <- subset(db, age>1&age<2, c("age","head"))
names(data) <- c("age","hc")
synthetic <- rep(c(FALSE,TRUE), each=nrow(data))
data2 <- rbind(data, data)
data2[synthetic,"hc"] <- NA
imp <- mice(data2, m=1, meth="TF", seed=36650, print=FALSE)
syn <- subset(complete(imp), synthetic)

### Figure 3.5

data <- syn
truehist(data$hc, col=mdc(2), border="white",
         xlab="Head circumference (cm)",
         ylab="Density",
         ylim=c(0,0.3), xlim=c(38,60),
         nbins=44)

mn <- gamlss(hc~1, data=na.omit(data), family=NO, trace=FALSE)
mu <- coef(mn)
sigma <- exp(coef(mn, "sigma"))
cmfine <- seq(38,60,0.1)
lines(cmfine, dNO(cmfine, mu, sigma), lwd=0.8, lty=2)
mt <- gamlss(hc~1, data=data, family=TF, trace=FALSE)
mu <- coef(mt)
sigma <- exp(coef(mt, "sigma"))
nu <- exp(coef(mt, "nu"))
lines(cmfine, dTF(cmfine, mu, sigma, nu), lwd=0.8, lty=1)
legend(x="right",legend=c("normal",paste("t, df=",round(nu,1),sep="")),
       lwd=0.8, lty=c(2,1), bty="n", cex=0.7)
plot(x=data$age, y=data$hc, col=mdc(2), cex=0.3,
     xlab="Age (in years)",
     ylab="Head circumference (cm)",
     ylim=c(39,60))

### Section 3.4.1 PMM, Overview
### Figure 3.6

data <- boys[boys$age<=2,c("age","bmi")]
set.seed(87120)
data[sample(92:136,10),"bmi"] <- NA
imp <- mice(data, meth="norm", m=1, seed=32212, print=FALSE)
cd1 <- complete(imp)
imp <- mice(data, m=1, seed=32212, print=FALSE)
cd2 <- complete(imp)
r <- !is.na(data$bmi)
plot(data, col=mdc(1), xlab="Age", ylab="BMI")
points(cd1[!r,], col=mdc(2), pch=19, cex=0.8)
plot(data, col=mdc(1), xlab="Age", ylab="BMI")
points(cd2[!r,], col=mdc(2), pch=19, cex=0.8)

### Section 3.4.2 PMM, Computational details
### Figure 3.7

par(mfrow=c(1,1))
data <- whiteside
lwd <- 1.5
data[47,"Gas"] <- NA

pch <- c(rep(3,26),rep(1,30))
plot(x=data$Temp, y=data$Gas, col=mdc(1), lwd=lwd, pch=pch,
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
betadump <- vector("list", 0)
imp <- mice(data, m=5, meth="pmmdump", maxit=1, print=FALSE, seed=68006)
betadump <- matrix(unlist(betadump), nc=3, byrow=TRUE)
m1<-lm(Gas~Temp+Insul, data=data, na.action=na.omit)
an <- coef(m1)[1]
ai <- an + coef(m1)[3]
b <- coef(m1)[2]
abline(a=ai, b=b, col=mdc(4))
abline(a=an, b=b, col=mdc(4))
## for (i in 56:56) {
##    abline(a=unlist(betadump[i,1]), b=unlist(betadump[i,2]), col=mdc(5))
##    abline(a=unlist(betadump[i,1])+unlist(betadump[i,3]), b=unlist(betadump[i,2]), col=mdc(5))
## }
## points(rep(5,5),imp$imp$Gas, lwd=lwd, col=mdc(2), pch=20)
eta <- 0.6
ylo <- ai+b*(5-eta)
yhi <- ai+b*(5+eta)
lines(x=c(5-eta,5+eta),y=c(ylo,yhi),lwd=3,col=mdc(4))
an <- 7.05; ai<-an-1.7; b <- -0.38
xlo1 <- (ylo-ai)/b
xhi1 <- (yhi-ai)/b
xlo2 <- (ylo-an)/b
xhi2 <- (yhi-an)/b
abline(a=an, b=b, col=mdc(5))
abline(a=ai, b=b, col=mdc(5))
lines(x=c(xlo1,xhi1),y=c(ylo,yhi),lwd=3,col=mdc(5))
lines(x=c(xlo2,xhi2),y=c(ylo,yhi),lwd=3,col=mdc(5))
abline(v=c(5-eta,5+eta),h=c(ylo,yhi),col=mdc(4),lty=3)
rect(xlo1,0,xhi1,8,col=hcl(0,100,40,0.05),border=NA)
rect(xlo2,0,xhi2,8,col=hcl(0,100,40,0.05),border=NA)
# abline(v=c(xlo1,xhi1,xlo2,xhi2),col=mdc(5),lty=3)

donors <- subset(data, (Insul=="After"&Temp>xlo1&Temp<xhi1)
                 |    (Insul=="Before"&Temp>xlo2&Temp<xhi2))
points(x=donors$Temp, y=donors$Gas, cex=1.8, col=mdc(5), lwd=lwd)
legend(x="bottomleft", legend=c("before insulation","after insulation"), pch=c(3,1),bty="n", pt.lwd=lwd)

### Section 3.4.3 PMM, Algorithm

### simulate function used to calculate Table 3.3
simulate <- function(nsim=10, seed=41872){
  set.seed(seed)
  res <- array(NA,dim=c(3, nsim, 6))
  for(i in 1:nsim){
    data <- createdata()
    data <- makemissing(data)
    res[1,i,] <- test.impute(data, m=5)
    res[2,i,] <- test.impute(data, m=5, donors=1)
    res[3,i,] <- test.impute(data, m=5, donors=10)
  }
  return(res)
}

### and perform simulations - MAY BE TIME CONSUMING
res.pmm <- simulate(nsim)
summarize.results(res.pmm)

### Section 3.7.1
### Figure 3.8

par(mfrow=c(1,2))
fit <- rpart(Gas ~ Temp + Insul, data=whiteside)
plot(fit, branch=0, margin=0.15)
text(fit, use=T,pretty=0,dig=3,cex=0.8)

leaf <- row.names(fit$frame)[fit$where]
label <- factor(leaf, labels=c(2,3,1,4,5))
plot(x=whiteside$Temp, y=whiteside$Gas, type="n",
     xlab=expression(paste("Temperature (", degree, "C)")),
     ylab="Gas consumption (cubic feet)")
text(x=whiteside$Temp, y=whiteside$Gas, label=label, col=mdc(4), cex=0.6)

### Section 3.9.4 Converting selection and pattern-mixture models
### Figure 3.9

par(mfrow=c(1,2))
s <- c(
       100, 0.015, 0.058, 0.02, 0.35,
       110, 0.024, 0.074, 0.03, 0.30,
       120, 0.043, 0.103, 0.05, 0.25,
       130, 0.091, 0.164, 0.10, 0.20,
       140, 0.145, 0.185, 0.15, 0.15,
       150, 0.307, 0.247, 0.30, 0.10,
       160, 0.157, 0.099, 0.15, 0.08,
       170, 0.107, 0.049, 0.10, 0.06,
       180, 0.055, 0.016, 0.05, 0.04,
       190, 0.033, 0.005, 0.03, 0.02,
       200, 0.023, 0.000, 0.02, 0.00,
       210, 0.023, 0.000, 0.02, 0.00
       )
sm <- matrix(s, nr=12, nc=5, byrow=TRUE)
snug <- 1.5
xx <- cbind(sm[,1]-5+snug,
        sm[,1]-5-snug,
        sm[,1]-5)
matplot(x=xx[,3], y=cbind(1-sm[,5]),
        col=mdc(1), type="p", lwd=2, lty=1, pch=20,
        xlab="Systolic BP (mmHg)",
        ylab="Observation probability")
matplot(x=xx, y=sm[,2:4], type="s",
        col=c(mdc(4),mdc(5),mdc(6)), lwd=2, lty=1,
        xlab="Systolic BP (mmHg)",
        ylab="Density")


 ZGEEQU Example Program Results

 Matrix A
                          1                       2                       3
 1  ( -1.34E+00,  2.55E+00) (  2.80E+09,  3.17E+10) ( -6.39E+00, -2.20E+00)
 2  ( -1.70E+00, -1.41E+00) (  3.31E+10, -1.50E+09) ( -1.50E-01,  1.34E+00)
 3  (  2.41E-10,  3.90E-11) ( -5.60E-01,  1.47E+00) ( -8.30E-11, -6.90E-11)

 ROWCND = 5.9E-11, COLCND = 1.4E-10, AMAX = 3.5E+10

 Row scale factors
    2.90E-11   2.89E-11   4.93E-01

 Column scale factors
    7.25E+09   1.00E+00   4.02E+09

 Scaled matrix
                      1                   2                   3
 1  ( -0.2816,  0.5359) (  0.0812,  0.9188) ( -0.7439, -0.2561)
 2  ( -0.3562, -0.2954) (  0.9566, -0.0434) ( -0.0174,  0.1555)
 3  (  0.8607,  0.1393) ( -0.2759,  0.7241) ( -0.1642, -0.1365)


=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::MatrixAlgebraTriplet>))
/
((<Algebra::MatrixAlgebraQuint>))

= Algebra::MatrixAlgebraTriplet

((*(3つ組行列のクラス)*))

行列と行列に対する左右の基本変形を記録した2つの行列を表すクラス。下位クラス
に5つ組みクラス ((<Algebra::MatrixAlgebraQuint>)) がある。

== ファイル名:
* ((|matrix-algebra-triplet.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:
* ((|GaussianElimination|))
* ((|ElementaryDivisor|))

=== クラスメソッド:

--- :new(matrix[, left[, right]])
    ((|matrix|)) を本体、((|left|))左（行）変形の記録、((|right|))
    を右（列）変形の記録とする3つ組みオブジェクトを生成します。

== メソッド:

--- body
    本体を返します。

--- left
    左（行）変形の記録を返します。

--- right
    右（列）変形の記録を返します。

--- to_a
    (({[body, left, right]})) という配列を返します。

--- to_ary
    ((<to_a>)) と同じ。

--- dup
    自身の複製を返します。

--- transpose
    転置行列を返します。

      [type.new(body.transpose, right.transpose, left.transpose]

    と同じです。

--- replace(other)
    自分を ((|other|)) と置き換えます。

--- display
    自分を表示します。

--- [](i, j)
    自分の (({(i, j)})) 成分を返します。

--- rsize
    行サイズを返します。

--- csize
    列サイズを返します。

--- each_i
    すべての行インデックスに対して繰り返すイテレータです。

--- each_j
    すべての列インデックスに対して繰り返すイテレータです。

--- row!(i)
    本体の ((|i|)) 行目そのものを返します。

--- sswap_r!(i, j)

--- swap_r!(i, j)

--- swap_c!(i, j)

--- multiply_r!(i, c)

--- multiply_c!(j, c)

--- divide_r!(i, c)

--- divide_c!(j, c)

--- mix_r!(i, j[, c])

--- mix_c!(i, j[, c])

--- left_eliminate!
    以上、((|Algebra::GauusianElimination|)) の同名メソッドを参照。

= Algebra::MatrixAlgebraQuint

((*(5つ組行列のクラス)*))

行列と行列に対する左右の基本変形、それらの逆行列を記録した計5つの
行列を表すクラス。上位クラスに3つ組みクラス ((<Algebra::MatrixAlgebraTriplet>)) がある。

== スーパークラス:

* ((|Algebra:MatrixAlgebraTriplet|))

== メソッド:

--- lefti
    ((<left>)) の逆行列を返します。

--- righti
    ((<right>)) の逆行列を返します。

--- to_a
    (({[body, left, right, lefti, righti]})) という配列を返します。

=end


beta_calculator <- function(L, T, mu0, sigma0){
    # Calculates the sub-optimal beta for the poisson process.
    #
    # Args:
    #    L (scalar): The Lipschitz/Holder coefficient decribed in Assumption 3.1 of the reference paper
    #    T (scalar): The maturity of the asset
    #    mu0 (array-like): The starting value of mu for each dimension (not sure about this)
    #    sigma0 (array-like): The starting value of sigma for each dimension (not sure about this)
    # Returns:
    #     (scalar): The sub-optimal beta

    # Get the dimension of the process
    d <- length(mu0)

    mu_inf <- sqrt(sum(mu0^2))

    trace <- sum(diag(solve(sigma0 %*% t(sigma0))))

    L_prime <- L^2 * ( 2*(1+mu_inf*sqrt(T))^2 * trace + 2*(3*d+d*(d-1)) )

    return(sqrt(L_prime + 0.25*T^2) + 0.5*T)
}


# 4. faza: Analiza podatkov

# predikcija povprečnega razpoložljivega dohodka (moški)
spol_moski <- spol %>%
  filter(Spol == "Moški")

model <- lm(Dohodek ~ Leto , data = spol_moski)

prihodnost <- data.frame(Leto = seq(2020,2024), Spol = "Moški")

napoved <- prihodnost %>%
  mutate(Dohodek= predict(model, .)) %>%
  select(Spol, Leto, Dohodek)

napoved_spol_moski <- bind_rows( (spol_moski),napoved)

graf_napoved_spol_moski <- ggplot(napoved_spol_moski, aes(x=Leto, y=Dohodek)) +
  geom_point() +
  geom_point(data=napoved, color="red") +
  geom_smooth(method = "lm", formula = y ~ x, col="red") +
  scale_x_continuous(breaks = seq(2008, 2024, 2)) +
  ggtitle("Napoved dohodka - moški")

print(graf_napoved_spol_moski)


euler <- function(f, y0, a, b, h)
{
  t <- a
  y <- y0

  while (t < b)
  {
    cat(sprintf("%6.3f %6.3f\n", t, y))
    t <- t + h
    y <- y + h*f(t, y)
  }
}

newtoncooling <- function(time, temp)
  return(-0.07*(temp-20))

euler(newtoncooling, 100, 0, 100, 10)


#---------------------------------------------------#
# LA variation - 2010/11 model_adjusted funnel plot #
#---------------------------------------------------#

# packages ----
library(dplyr)
library(tidyr)
library(readr)
library(lme4)
library(broom)
library(gridExtra)
library(grid)
library(gtable)
library(ggpubr)
library(ggplot2)
library(ggrepel)

#----------------------#
# begin function ----
#----------------------#
abs_rate_funnel <- function(data, var, pop, pern = 1000, wlbls = FALSE){

  eval(data)

  # derive standard error ----
  dt <- data %>%
    rename(var_unquo = var,
           pop_unquo = pop) %>%
    mutate(rate = var_unquo/pop_unquo ,
           rate_pern = rate*pern,
           rate_se = sqrt(rate*(1-rate)/pop_unquo),
           pop_round = round(pop_unquo, -1))

  # derive common (fixed) effect ----
  rate_fem <- weighted.mean(dt$rate, 1/dt$rate_se^2, na.rm = TRUE)

  if(is.nan(rate_fem)){
    rate_fem <- mean(dt$rate, na.rm = TRUE)
    warning("weighted means could not be calculated. Arithmetic mean used instead.")
  }

  ## lower and upper limits for 95% and 99.9% CI, based on FEM estimator ----
  p_fem <- rate_fem*(1-rate_fem)

	number.seq <- seq(10, max(dt$pop_unquo), 10)

	number.ll95 <- (rate_fem - 1.96 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ul95 <- (rate_fem + 1.96 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ll999 <- (rate_fem - 3.29 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.ul999 <- (rate_fem + 3.29 * (sqrt((p_fem * (1 - p_fem)) / number.seq))) * pern
	number.se <- ((sqrt((p_fem * (1 - p_fem)) / number.seq)) * pern)
	dfCI <- data.frame(number.ll95, number.ul95, number.ll999, number.ul999, number.seq, number.se, rate_fem)

  # create labels for 'outliers' ----
  labels <- left_join(dt, dfCI, by = c("pop_round" = "number.seq")) %>%
    mutate(label_name = ifelse(rate_fem*pern > number.ul999 + 2*number.se | rate_fem*pern < number.ll999 - 2*number.se, la_name, NA),
           label_rate = ifelse(!is.na(label_name), round(rate_fem*pern,1), NA),
           label_comb = ifelse(!is.na(label_name) & !is.na(label_rate), paste(label_name, label_rate, sep = ": "), NA)) %>%
    select(la_code, starts_with("label_"))

  count <- left_join(dt, dfCI, by = c("pop_round" = "number.seq")) %>%
    mutate(high_low = ifelse(rate*pern > number.ul999 | rate*pern < number.ll999, 1, 0)) %>%
    summarise(extreme = sum(high_low ==1, na.rm = TRUE))

	final_dt <- left_join(dt, labels, by = c("la_code"))

if(wlbls == TRUE) {
	# draw funnel plot ----
	p <- ggplot(data = final_dt, aes(x = pop_unquo, y = rate_pern)) +
	  geom_point(alpha = 0.85, size = 2, shape = 21) +
	  geom_line(aes(x = number.seq, y = number.ll95, linetype = "dashed"), data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul95), data = dfCI, linetype = "dashed") +
	  geom_line(aes(x = number.seq, y = number.ll999, linetype = "longdash"),  data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul999), linetype = "longdash", data = dfCI) +
	  geom_hline(aes(yintercept = rate_fem*pern), data = dfCI) +
	  geom_text_repel(aes(label = label_name),size = 3.2, nudge_x = 11000, nudge_y = -0.05) +
	  scale_linetype_manual("",values = c("dashed", "longdash"), labels = c("95% control limit", "99.9% control limit")) +
	  theme(axis.line = element_line(colour = "black"),
	        panel.grid.major = element_blank(),
	        panel.grid.minor = element_blank(),
	        panel.border = element_blank(),
	        panel.background = element_blank(),
	        axis.text = element_text(colour = "black")) #+
	return(list(p, count, labels))
} else{
  # draw funnel plot ----
  p <- ggplot(data = final_dt, aes(x = pop_unquo, y = rate_pern)) +
    geom_point(alpha = 0.85, size = 2, shape = 21) +
    geom_line(aes(x = number.seq, y = number.ll95, linetype = "dashed"), data = dfCI) +
    geom_line(aes(x = number.seq, y = number.ul95), data = dfCI, linetype = "dashed") +
    geom_line(aes(x = number.seq, y = number.ll999, linetype = "longdash"),  data = dfCI) +
	  geom_line(aes(x = number.seq, y = number.ul999), linetype = "longdash", data = dfCI) +
	  geom_hline(aes(yintercept = rate_fem*pern), data = dfCI) +
	  scale_linetype_manual("",values = c("dashed", "longdash"), labels = c("95% control limit", "99.9% control limit")) +
    theme(axis.line = element_line(colour = "black"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          panel.border = element_blank(),
          panel.background = element_blank(),
          axis.text = element_text(colour = "black")) #+
  return(list(p, count))
}

}

#----------------------#
# get analysis data ----
#----------------------#
source("N:/Documents/Data & Programming/R Scripts/la variation/la_variation_analysis_data.r", echo = FALSE)

#----------------------#
# get final model ----
#----------------------#

# linear mixed-effect model:
lmer_final <- lmer(data = filter(model_dat, any_bad_linkrate == 0 & any_bad_bwrate ==0),
                         formula = as.formula(paste("n_child_10000 ~ year_std",
                                                    "any_ara_pct",
                                                    "teenbirth_2010",
                                                    "imd_10pc_2010",
                                                    "lowbw_2010",
                                                    "ca_feud_2010",
                                                    "total_2010",
                                                    "lone_parent_pct",
                                                    "violent_crime",
                                                    #"prop10_idaci_pct",
                                                    "(year_std|la_code)",
                                                    sep = "+")), REML = TRUE)
lmer_final_predict <- predict(lmer_final, re.form = NA)

#-----------------------#
# funnel plots lmer ----
#-----------------------#
final_dat <- bind_cols(filter(model_dat, any_bad_linkrate == 0 & any_bad_bwrate ==0) ,
                       "predict" = lmer_final_predict) %>%
  filter(year == 2010) %>%
  mutate(adjusted_rate = (n_child_10000/predict)*mean(n_child_10000), # crude rate or mean of the rates? SMR
         adj_count = round((adjusted_rate*pop_U1)/10000),
         mean_rate = mean(n_child_10000)) %>%
  rowwise() %>%
  mutate(y_min = min(n_child_10000, adjusted_rate),
         y_max = max(n_child_10000, adjusted_rate),
         extreme = ifelse(abs(n_child_10000 - mean_rate) - abs(adjusted_rate - mean_rate) < 0, 1, 0)) %>%
  dplyr::select(la_code, la_name, region_name, n_child_10000, predict,
                adjusted_rate, mean_rate, n_child, adj_count, y_min, y_max, pop_U1, extreme)

# Funnel plot based only on observed rates:
plot_act <- abs_rate_funnel(data = final_dat, var = "n_child",
                            pop = "pop_U1", pern = 10000)[[1]] +
  scale_y_continuous("Number of infants (per 10000)",
                     limits = c(-5,250)) +
  scale_x_continuous("Local population size (Infants)") +
  labs(title = "Actual")

# Funnel plot with both observed and expected (as per lmer final) rates :
final <- plot_act  +
  geom_linerange(data = final_dat, aes(x = pop_U1, ymin = y_min, ymax = y_max), size = 1, alpha = 0.2, inherit.aes = FALSE, colour = "grey") +
  geom_point(data= final_dat, aes(x = pop_U1, y = n_child_10000, colour = "actual rate", fill = "actual rate", shape = "actual rate"), size = 2) +
  geom_point(data= final_dat, aes(x = pop_U1, y = adjusted_rate, colour = "adjusted rate", shape = "adjusted rate", fill = "adjusted rate"), size = 2) +
  scale_colour_manual("", values = c("grey70", "#1B9E77")) +
  scale_shape_manual("", values = c(19,15)) +
  scale_fill_manual("", values = c("grey70", "#1B9E77")) +
  scale_y_continuous("Number of infants CLA (per 10,000)",
                     limits = c(-5,250)) +
  scale_x_continuous("Local population size (Infants)") +
  theme(axis.text = element_text(size = 14),
        legend.position = "bottom",
        axis.title = element_text(size = 14),
        strip.text = element_text(size = 14),
        legend.title=element_text(size=14),
        legend.text=element_text(size=14),
        title = element_text(size = 16)) +
  labs(subtitle = "model prediction of rates uses fixed-effects only - final model")

ggsave(final, "N:/Documents/Data & Programming/outputs/la variation/modelling/adjusted_lmer_funnel_plot_feonly.png")

#--------------------------------------------------------------------------------#
# add lines between observed and expected and use shapes to depict region of LA ----
#--------------------------------------------------------------------------------#
  final_shapes <- plot_act  +
    geom_linerange(data = final_dat_wlbls, aes(x = pop_U1, ymin = y_min, ymax = y_max), size = 1, alpha = 0.2, inherit.aes = FALSE, colour = "grey") +
    geom_point(data= final_dat_wlbls, aes(x = pop_U1, y = n_child_10000, colour = "actual rate", fill = "actual rate", shape = "actual rate"), size = 2) +
    geom_point(data= final_dat_wlbls, aes(colour = region_name, shape = region_name, fill = region_name,
                                    x = pop_U1, y = adjusted_rate), size = 3.2) +
    #geom_label_repel(data= final_dat_wlbls, aes(x = pop_U1, y = n_child_10000,label = lbl),size = 3.2, nudge_x = 3000, nudge_y = -0.05) +
    scale_colour_manual("Region", values = c("grey80", "#1F78B4",  "#D95F02", "#1B9E77", "#7570B3",  "#66A61E", "#E7298A", "#E6AB02", "#FB9A99", "#666666")) +
    scale_shape_manual("Region", values=c(19,2,0,8,15,21,17,4,23,7)) +
    scale_fill_manual("Region", values = c("grey80", "#1F78B4",  "#D95F02", "#1B9E77", "#7570B3",  "#66A61E", "#E7298A", "#E6AB02", "#FB9A99", "#666666")) +
    scale_y_continuous("Number of infants CLA (per 10,000)",
                       limits = c(-5,250)) +
    scale_x_continuous("Local population size (Infants)") +
    theme(#legend.position = "bottom",
          axis.text = element_text(size = 14),
          axis.title = element_text(size = 14),
          strip.text = element_text(size = 14),
          legend.title=element_text(size=14),
          legend.text=element_text(size=14),
          title = element_text(size = 16)) +
    labs(title = "Local authority variation in Infants CLA - actual vs case-mix adjusted (2010/11 only)",
         subtitle = "linear mixed-effect model prediction of rates uses fixed-effects only"
      #title ="",
      #subtitle = "model prediction of rates uses fixed-effects only - final model"
      )

ggsave(final_shapes,"N:/Documents/Data & Programming/outputs/la variation/modelling/adjusted_lmer_funnel_plot_feonly_shapes.png",
       units = "mm", width = 350,height = 250)


# Internal fucntion of add_pcoord performing pricipal coordinate analysis
# D A list with objects H, P, and HP, returned by prepare_paco_data
#  correction The correction to apply (none, lingoes, or cailliez)
#  rn rownames (optional)
# Internal function coordpcoa is a modified version of ape::pcoa, utilising vegan::eigenvals and zapsmall
coordpcoa <- function (D, correction = "none", rn = NULL)
{
    centre <- function(D, n) {
        One <- matrix(1, n, n)
        mat <- diag(n) - One/n
        mat.cen <- mat %*% D %*% mat
    }
    bstick.def <- function(n, tot.var = 1, ...) {
        res <- rev(cumsum(tot.var/n:1)/n)
        names(res) <- paste("Stick", seq(len = n), sep = "")
        return(res)
    }
    D <- as.matrix(D)
    n <- nrow(D)
    epsilon <- sqrt(.Machine$double.eps)
    if (length(rn) != 0) {
        names <- rn
    }else {
        names <- rownames(D)
    }
    CORRECTIONS <- c("none", "lingoes", "cailliez")
    correct <- pmatch(correction, CORRECTIONS)
    if (is.na(correct))
        stop("Invalid correction method")
    delta1 <- centre((-0.5 * D^2), n)
    trace <- sum(diag(delta1))
    D.eig <- eigen(delta1)
    D.eig$values <- as.numeric(zapsmall(vegan::eigenvals(D.eig)))
    min.eig <- min(D.eig$values)
    zero.eig <- which(abs(D.eig$values) < epsilon)
    D.eig$values[zero.eig] <- 0
    if (min.eig > -epsilon) {
        correct <- 1
        eig <- D.eig$values
        k <- length(which(eig > epsilon))
        rel.eig <- eig[1:k]/trace
        cum.eig <- cumsum(rel.eig)
        vectors <- sweep(D.eig$vectors[, 1:k], 2, sqrt(eig[1:k]),
            FUN = "*")
        bs <- bstick.def(k)
        cum.bs <- cumsum(bs)
        res <- data.frame(eig[1:k], rel.eig, bs, cum.eig, cum.bs)
        colnames(res) <- c("Eigenvalues", "Relative_eig", "Broken_stick",
            "Cumul_eig", "Cumul_br_stick")
        rownames(res) <- 1:nrow(res)
        rownames(vectors) <- names
        colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
            prefix = "Axis.")
        note <- paste("There were no negative eigenvalues. No correction was applied")
        out <- (list(correction = c(correction, correct), note = note,
            values = res, vectors = vectors, trace = trace))
    }
    else {
        k <- n
        eig <- D.eig$values
        rel.eig <- eig/trace
        rel.eig.cor <- (eig - min.eig)/(trace - (n - 1) * min.eig)
        rel.eig.cor = c(rel.eig.cor[1:(zero.eig[1] - 1)], rel.eig.cor[(zero.eig[1] +
            1):n], 0)
        cum.eig.cor <- cumsum(rel.eig.cor)
        k2 <- length(which(eig > epsilon))
        k3 <- length(which(rel.eig.cor > epsilon))
        vectors <- sweep(D.eig$vectors[, 1:k2], 2, sqrt(eig[1:k2]),
            FUN = "*")
        if ((correct == 2) | (correct == 3)) {
            if (correct == 2) {
                c1 <- -min.eig
                note <- paste("Lingoes correction applied to negative eigenvalues: D' = -0.5*D^2 -",
                  c1, ", except diagonal elements")
                D <- -0.5 * (D^2 + 2 * c1)
            }
            else if (correct == 3) {
                delta2 <- centre((-0.5 * D), n)
                upper <- cbind(matrix(0, n, n), 2 * delta1)
                lower <- cbind(-diag(n), -4 * delta2)
                sp.matrix <- rbind(upper, lower)
                c2 <- max(Re(eigen(sp.matrix, symmetric = FALSE,
                  only.values = TRUE)$values))
                note <- paste("Cailliez correction applied to negative eigenvalues: D' = -0.5*(D +",
                  c2, ")^2, except diagonal elements")
                D <- -0.5 * (D + c2)^2
            }
            diag(D) <- 0
            mat.cor <- centre(D, n)
            toto.cor <- eigen(mat.cor)
            toto.cor$values <- as.numeric(zapsmall(vegan::eigenvals(toto.cor)))
            trace.cor <- sum(diag(mat.cor))
            min.eig.cor <- min(toto.cor$values)
            zero.eig.cor <- which((toto.cor$values < epsilon) &
                (toto.cor$values > -epsilon))
            toto.cor$values[zero.eig.cor] <- 0
            if (min.eig.cor > -epsilon) {
                eig.cor <- toto.cor$values
                rel.eig.cor <- eig.cor[1:k]/trace.cor
                cum.eig.cor <- cumsum(rel.eig.cor)
                k2 <- length(which(eig.cor > epsilon))
                vectors.cor <- sweep(toto.cor$vectors[, 1:k2],
                  2, sqrt(eig.cor[1:k2]), FUN = "*")
                rownames(vectors.cor) <- names
                colnames(vectors.cor) <- colnames(vectors.cor,
                  do.NULL = FALSE, prefix = "Axis.")
                bs <- bstick.def(k2)
                bs <- c(bs, rep(0, (k - k2)))
                cum.bs <- cumsum(bs)
            }
            else {
                if (correct == 2)
                  cat("Problem! Negative eigenvalues are still present after Lingoes",
                    "\n")
                if (correct == 3)
                  cat("Problem! Negative eigenvalues are still present after Cailliez",
                    "\n")
                rel.eig.cor <- cum.eig.cor <- bs <- cum.bs <- rep(NA,
                  n)
                vectors.cor <- matrix(NA, n, 2)
                rownames(vectors.cor) <- names
                colnames(vectors.cor) <- colnames(vectors.cor,
                  do.NULL = FALSE, prefix = "Axis.")
            }
            res <- data.frame(eig[1:k], eig.cor[1:k], rel.eig.cor,
                bs, cum.eig.cor, cum.bs)
            colnames(res) <- c("Eigenvalues", "Corr_eig", "Rel_corr_eig",
                "Broken_stick", "Cum_corr_eig", "Cum_br_stick")
            rownames(res) <- 1:nrow(res)
            rownames(vectors) <- names
            colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
                prefix = "Axis.")
            out <- (list(correction = c(correction, correct),
                note = note, values = res, vectors = vectors,
                trace = trace, vectors.cor = vectors.cor, trace.cor = trace.cor))
        }
        else {
            note <- "No correction was applied to the negative eigenvalues"
            bs <- bstick.def(k3)
            bs <- c(bs, rep(0, (k - k3)))
            cum.bs <- cumsum(bs)
            res <- data.frame(eig[1:k], rel.eig, rel.eig.cor,
                bs, cum.eig.cor, cum.bs)
            colnames(res) <- c("Eigenvalues", "Relative_eig",
                "Rel_corr_eig", "Broken_stick", "Cum_corr_eig",
                "Cumul_br_stick")
            rownames(res) <- 1:nrow(res)
            rownames(vectors) <- names
            colnames(vectors) <- colnames(vectors, do.NULL = FALSE,
                prefix = "Axis.")
            out <- (list(correction = c(correction, correct),
                note = note, values = res, vectors = vectors,
                trace = trace))
        }
    }
    class(out) <- "pcoa"
    out
}


#' Time derivative of DO concentration
#'
#' @param t Time step for the ode integration
#' @param y Current state (dissolved oxygen concentration) at both sites
#' @param parms a vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param return_list logical, should a list (suitable for deSolve) be returned?
#' @details `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `P1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `P2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `k600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `ER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `PAR`  a function that takes time as a parameter and returns light intensity $(W/m^2)$
#' * `temp` a function that takes time as a parameter and returns water temperature (degrees C)
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' @references Fuß, T. et al. (2017). Land use controls stream ecosystem metabolism by shifting
#' 		 dissolved organic matter and nutrient regimes. *Freshw Biol* **62**:582–599. \\
#'		 Van de Bogert MC et al. 2007. Assessing pelagic and benthic metabolism using free
#' 		 water measurements. *Limnol. Oceanogr.: Methods* **5**:145–155. \\
#' 		 Uehlinger, U., et al. 2000. Variability of photosynthesis‐irradiance curves and
#' 		 ecosystem respiration in a small river. *Freshw Biol* **44**:493–507.
#'
#' @return Time derivative of dissolved oxygen
#' @export
twoStation_dDOdt <- function(t, y, parms, data, return_list=FALSE)
{
	nms <- c('P1', 'P2', 'k600', 'ER24_20')
	parlist <- list(parms[c(1,3,5,7)], parms[c(2,4,6,8)])
	names(parlist[[1]]) <- names(parlist[[2]]) <- nms

	val <- mapply(function(pa, da) oneStation_dDOdt(t, y, pa, da, return_list = FALSE),
		pa = parlist, da = data, SIMPLIFY = !return_list)
	return(val)
}

#' Predict a time series of dissolved oxygen concentration
#' @param ws A [WatershedTools::Watershed()] object, describing ONLY the two sites
#' @param initial initial dissolved oxygen concentration in each station
#' @param lateral Vector  of length two giving the DO concentration of lateral input
#' 		(useful) if discharge varies significantly between the sites, defaults to 0
#' @param times The times at which to solve the system
#' @param params a named vector of parameters; see details
#' @param data a list of data for the ode; see details
#' @param dt Time step for integration; only used if `method == 'euler'`
#' @param method The integration method to use; default is euler

#' @details Light and temperature time series will be approximated using linear interpolation
#' 		at the desired time steps
#'
#' `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `P1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `P2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `k600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `ER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#' @return Time series of dissolved oxygen concentrations
#' @export
twoStation_DOPredict <- function(ws, initial, times, params, data, dt = 1,
			method=c('euler', 'lsoda')) {
	method <- match.arg(method)
	if(method == "lsoda" && !(requireNamespace("deSolve")))
		stop("Package deSolve is required for method lsoda; please install it and try again")
	if(times[1] != 0)
		stop('first time step must be 0')
	if(method == 'euler' && sum(times %% dt) != 0)
		stop('dt must divide evenly into all values in times')

	dDOData <- lapply(data, function(x) {
		list(PAR = approxfun(x = x$PAR[,2], y = x$PAR[,1], rule = 2),
			temp = approxfun(x = x$temp[,2], y = x$temp[,1], rule = 2),
			P = x$P,
			z = x$z)
	})

	ddodtParams <- list(parms = params, data = dDOData)
	state <- WatershedTools::transport(ws, initial, lateral, times, method = method, dt = dt,
			rxn = twoStation_dDOdt, rxnParams = ddodtParams)

	return(state)
}

#' Log posterior probability for the DO curve given empirical data
#' @param params A named vector of model parameters; see details
#' @param data A list of model data, see details
#' @param prior A list of prior hyperparameters; see details
#' @param ... Additional parameters to be passed to [DO_predict()]
#' @details `params` must be a vector. The indices of the vector must map to model parameters
#'       as follows; (where parameters with length two are fit per site):
#' * [1:2] -- `logP1` $(W min g^{-1} O_2)$ -- inverse of the slope of a photosynthesis–irradiance
#' 			curve at low light intensity
#' * [3:4] -- `logP2` $(m^2 min g^{-1} O_2)$ -- inverse maximum photosynthesis rate; can be zero
#' 			to assume GPP is linear with light intensity instead of saturating
#' * [5:6] -- `logk600` -- coefficient of gas exchange for a gas with a Schmidt number of 600
#' * [7:8] -- `logER24_20` -- daily ecosystem respiration rate, standardized at 20 degrees C
#' * [9] -- `logsd` -- log(Error standard deviation)
#'
#' `data` is a list of length 2 (one per site); each item is a list of (constant) data items,
#' 				including the following:
#' * `DO` 2-column data frame; first column is dissolved oxygen, second is time of observation
#' * `PAR`  2-column data frame; first column is light, second is time of observation
#' * `temp` 2-column data frame; first column is temperature, second is time of observation
#' * `P`    pressure, in atmospheres
#' * `z`    Depth, in meters
#'
#' `prior` is a list of hyperparameters for the priors on parameters listed under `params`.
#' All priors are normal. Thus, each list item should be named (following the names from
#' `params`), and each item should be a vector of length two giving the mean and standard
#' deviation of the prior for that parameter. Note that each parameter is optional
#' (as is the entire list); missing items will get a minimally informative normal(0,10)
#'  distribution.
#' @return The unnormalized log probability of the model given the data
#' @export
twoStation_DOlogprob <- function(params, data, prior = list(), ...) {
	logprob <- sum(mapply(oneStation_DOlogprob, params = params, data = data, prior = prior))
	return(logprob)
}


# 4. faza: Analiza podatkov
library(ggplot2)
library(GGally)
library(mgcv)
library(ggpubr)

#NAPOVED BREZPOSELNOSTI VISJESOLSKA
tabela.preciscena1 <- brezposelnost_izobrazba %>% filter(izobrazba =="Visjesolska, visokosolska")
tabela.preciscena1$izobrazba <- NULL
star <- lm(data=tabela.preciscena1, stevilo ~ leta)

model1 <- ggplot(tabela.preciscena1) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("višješolska ali visokošolska \nizobrazba") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki1 <- data.frame(leta = seq(2018, 2022))
napoved1 <- novi.podatki1 %>% mutate(stevilo=predict(star, .))
model1 <- model1 + geom_point(data=napoved1, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks = seq(2008,2022, 3))

#BREZ IZOBRAZBE
tabela.preciscena2 <- brezposelnost_izobrazba %>% filter(izobrazba =="Brez izobrazbe")
tabela.preciscena2$izobrazba <- NULL
star2 <- lm(data=tabela.preciscena2, stevilo ~ leta)

model2 <- ggplot(tabela.preciscena2) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("brez izobrazbe") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki2 <- data.frame(leta = seq(2018, 2022, 1))
napoved2 <- novi.podatki2 %>% mutate(stevilo=predict(star2, .))
model2 <- model2 + geom_point(data=napoved2, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3)) + scale_y_continuous(breaks = 0:2)

#OSNOVNOSOLSKA
tabela.preciscena3 <- brezposelnost_izobrazba %>% filter(izobrazba =="Osnovnosolska")
tabela.preciscena3$izobrazba <- NULL
star3 <- lm(data=tabela.preciscena3, stevilo ~ leta)

model3 <- ggplot(tabela.preciscena3) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_point() +
  ggtitle("osnovnošolska \nizobrazba") +
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki3 <- data.frame(leta = seq(2018, 2022, 1))
napoved3 <- novi.podatki3 %>% mutate(stevilo=predict(star3, .))
model3 <- model3 + geom_point(data=napoved3, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

#NIZJA ALI SREDNJA POKLICNA
tabela.preciscena4 <- brezposelnost_izobrazba %>% filter(izobrazba =="Nizja ali srednja poklicna")
tabela.preciscena4$izobrazba <- NULL
star4 <- lm(data=tabela.preciscena4, stevilo ~ leta)

model4 <- ggplot(tabela.preciscena4) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("nižja ali srednja \npoklicna izobrazba") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki4 <- data.frame(leta = seq(2018, 2022, 1))
napoved4 <- novi.podatki4 %>% mutate(stevilo=predict(star4, .))
model4 <- model4 + geom_point(data=napoved4, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

#SREDNJA STROKOVNA, SPOLOSNA
tabela.preciscena5 <- brezposelnost_izobrazba %>% filter(izobrazba =="Srednja strokovna, splosna")
tabela.preciscena5$izobrazba <- NULL
star5 <- lm(data=tabela.preciscena5, stevilo ~ leta)

model5 <- ggplot(tabela.preciscena5) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_point() +
  ggtitle("srednja strokovna ali \nsplošna izobrazba") +
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki5 <- data.frame(leta = seq(2018, 2022, 1))
napoved5 <- novi.podatki5 %>% mutate(stevilo=predict(star5, .))
model5 <- model5 + geom_point(data=napoved5, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

skupaj <- ggarrange(model2, model3, model4, model5, model1)


LDx.core = function ( obj, cf=c(1,2), p=0.5, method="default", covars=NULL ) {

   # print( "Expecting: y ~ aX + bT + cU + dXT + eXU ..." )
   # print( "Order of terms is important: main effects first, then first order effects")
   # print( "Where X is the variable of interest ... dose, size, date, etc)" )
   # print( "When there are interaction terms, the first interaction term must be the second main effect" )

    # modified from MASS::dose.p
    # cf = indices of vars of interest (intercept, xvar):
    #   default :: no interaction terms

    eta <- family(obj)$linkfun(p)  #logit at associated Prob
    a <- coef(obj)
    out = NULL

    if (method == "default" ) {
      # identicle to MASS::dose.p
      x.p <- (eta - a[1])/a[2]
      pd <- -cbind(1, x.p)/a[cf[2]]
      SD <- sqrt(((pd %*% vcov(obj)[cf, cf]) * pd) %*% c(1, 1))
    }

    if (method == "2main.0interaction" ) {
      # Solve[ 0  == eta - (a1 + a2*X + a3*T ), X] ;  x = main factor of interest
      T = covars
      x.p = (eta -  a[1] - a[3]* T)/  a[2]
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2]
      dy1 = - 1/Q     # partial derivative wrt a[1] -- the intercept... etc
      dy2 = - ( eta - a[1] - a[3]*T )/Q^2
      dy3 = - T / Q
      diag(dy) = c( dy1^2, dy2^2, dy3^2 ) # partial derivatives associated with variances
      dy[1,2:3] = dy1 * c(dy2, dy3 )
      dy[2,3  ] = dy2 * c(dy3 )
      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T ) )

    }

    if (method == "2main.1interaction" ) {
      # Solve[ 0  == eta - (a1 + a2*X + a3*T + a4*X*T), X] ;  x = main factor of interest
      T = covars
      x.p = (eta - a[1] - a[3]* T)/ ( a[2] + a[4]*T)
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[4] * T
      dy1 = - 1/Q     # partial derivative wrt a[1] -- the intercept... etc
      dy2 = - (-a[1] + eta -a[3]*T) / Q^2
      dy3 = - T / Q
      dy4 = - T * (-a[1] + eta -a[3]*T) / Q^2
      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2 ) # partial derivatives associated with variances
      dy[1,2:4] = dy1 * c(dy2, dy3, dy4 )
      dy[2,3:4] = dy2 * c(dy3, dy4 )
      dy[3,4]   = dy3 * c(dy4 )
      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T ) )

    }

    if (method=="3main.0interaction") {
      # Solve[eta == a1 + a2*X + a3*T + a4*U , X] ; x = main factor of interest

      T = covars[1]
      U = covars[2]
      x.p = ( eta -a[1]- a[3]*T - a[4]*U )/ a[2]
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2]
      dy1 = -1/Q
      dy2 = (-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2 ) # partial derivatives associated with variances
      dy[1,2:4] = dy1 * c(dy2, dy3, dy4 )
      dy[2,3:4] = dy2 * c(     dy3, dy4 )
      dy[3,4  ] = dy3 * c(          dy4 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.1interaction") {
      # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T, X] ; x = main factor of interest

      T = covars[1]
      U = covars[2]
      x.p = ( eta -a[1]- a[3]*T - a[4]*U )/ (a[2] + a[5]*T)
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T
      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2 ) # partial derivatives associated with variances
      dy[1,2:5] = dy1 * c(dy2, dy3, dy4, dy5 )
      dy[2,3:5] = dy2 * c(     dy3, dy4, dy5 )
      dy[3,4:5] = dy3 * c(          dy4, dy5 )
      dy[4,  5] = dy4 * c(               dy5 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.2interaction.12.13") {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*X*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U) / (a[2] + a[5]*T + a[6]*U)

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T + a[6]* U

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2 ) # partial derivatives associated with variances
      dy[1,2:6] = dy1 * c(dy2, dy3, dy4, dy5, dy6 )
      dy[2,3:6] = dy2 * c(     dy3, dy4, dy5, dy6 )
      dy[3,4:6] = dy3 * c(          dy4, dy5, dy6 )
      dy[4,5:6] = dy4 * c(               dy5, dy6 )
      dy[5,  6] = dy5 * c(                    dy6 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.2interaction.12.23") {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*T*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U - a[6]*T * U) / (a[2] + a[5]*T )

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U -a[6]*T*U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U-a[6]*T*U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U-a[6]*T*U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2 ) # partial derivatives associated with variances
      dy[1,2:6] = dy1 * c(dy2, dy3, dy4, dy5, dy6 )
      dy[2,3:6] = dy2 * c(     dy3, dy4, dy5, dy6 )
      dy[3,4:6] = dy3 * c(          dy4, dy5, dy6 )
      dy[4,5:6] = dy4 * c(               dy5, dy6 )
      dy[5,  6] = dy5 * c(                    dy6 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.3interaction"  ) {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*X*U + a7*T*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U -  a[7]*T*U) / (a[2] + a[5]*T + a[6]*U)

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T + a[6]* U

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U - a[7]*T*U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U - a[7]*T*U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U - a[7]*T*U)/Q^2
      dy7 = - T * U  / Q

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2, dy7^2 ) # partial derivatives associated with variances
      dy[1,2:7] = dy1 * c(dy2, dy3, dy4, dy5, dy6, dy7 )
      dy[2,3:7] = dy2 * c(     dy3, dy4, dy5, dy6, dy7  )
      dy[3,4:7] = dy3 * c(          dy4, dy5, dy6, dy7  )
      dy[4,5:7] = dy4 * c(               dy5, dy6, dy7  )
      dy[5,6:7] = dy5 * c(                    dy6, dy7  )
      dy[6,  7] = dy6 * c(                         dy7  )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }
    rownames(out) = NULL
    return(out)
}


[[[[[
   Lemma for
      H(y|x) <= H(x,y) - H(x) + c

   We show that
      H(x) <= -log_2 Sum_y P((x y)) + c

   Proof: From U construct U' such that
      if U(p) = (x y), then U'(p) = x.

   Then apply the previous chapter to get
      H(x) <= -log_2 P'(x) + c
           <= -log_2 Sum_y P((x y)) + c
]]]]]

define U-prime

let (is-pair? x)
   if atom x         false
   if atom cdr x     false
   if atom cdr cdr x true
                     false

[run original program for U]

let v eval read-exp

[and if is a pair, return first element]

if (is-pair? v) car v

[otherwise loop forever]

   let (loop) [be] (loop) [in]
      (loop)

define      U-prime
value       ((' (lambda (is-pair?) ((' (lambda (v) (if (is-pai
            r? v) (car v) ((' (lambda (loop) (loop))) (' (lamb
            da () (loop))))))) (eval (read-exp))))) (' (lambda
             (x) (if (atom x) false (if (atom (cdr x)) false (
            if (atom (cdr (cdr x))) true false))))))

[Test it!]

run-utm-on bits' xyz

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' xyz)))))
value       xyz

run-utm-on bits' cons a nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a nil))))))
value       (a)

run-utm-on bits' cons a cons b nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a (cons b nil)))))))
value       (a b)

run-utm-on bits' cons a cons b cons c nil

expression  (car (cdr (try no-time-limit (' (eval (read-exp)))
             (bits (' (cons a (cons b (cons c nil))))))))
value       (a b c)

cadr try 99 U-prime bits' xyz

expression  (car (cdr (try 99 U-prime (bits (' xyz)))))
value       out-of-time

cadr try 99 U-prime bits' cons a nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a nil))))
            ))
value       out-of-time

cadr try 99 U-prime bits' cons a cons b nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a (cons b
             nil)))))))
value       a

cadr try 99 U-prime bits' cons a cons b cons c nil

expression  (car (cdr (try 99 U-prime (bits (' (cons a (cons b
             (cons c nil))))))))
value       out-of-time


library(tidyverse)

# read in data
msa <- read.csv("msapop.csv")
# create new data to conform with Gabaix (1999)
msa135 <- msa %>%
  filter(rank2010<=135)

# plot -- all MSAs
p <- ggplot(msa)+
  aes(x = log(pop2010), y = log(rank2010))+
  geom_point(alpha = 0.5, size = 2, color = "#E69F00") +
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # Theming
  labs(
    title="Zipf's law",
    subtitle="Log population and log population rank, All U.S. metropolitan areas, 2010",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau & Author's calculations.",
    y="Log of Rank",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the y-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p, "zipf.png", width=8, height=6, units="in", dpi="retina")

summary(lm(data=msa, log(rank2010)~log(pop2010)))

# plot -- 135 largest
p1 <- ggplot(msa135) +
  aes(x = log(pop2010), y = log(rank2010)) +
  # points
  geom_point(alpha = 0.5, size = 2, color = "#E69F00") +
  # point labels for the largest cities -- still deciding
  # geom_text(aes(label=ifelse(rank2010<5,as.character(msa),'')),hjust=0,vjust=0) +
  # trend line
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # theming
  labs(
    title="Zipf's law",
    subtitle="Log population and log population rank, 135 largest U.S. metropolitan areas, 2010",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau & Author's calculations.",
    y="Log of Rank",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the xy-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p1, "zipf135.png", width=8, height=6, units="in", dpi="retina")

summary(lm(data=msa135, log(rank2010)~log(pop2010)))