# 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---------------------------

# First propagate uncertainties on bins per temperature, keeping data from different machines separate
D47stats_Machinebin <- dat[which(dat$D47_outlier != TRUE),] %>% # Summarize D47 statistics
    group_by(ID, Machine) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_binmean = mean(D47, na.rm = TRUE),  # Calculate means per sample
        SD_bin = sd(D47, na.rm = TRUE), # Calculate stdevs per sample bin
        SD_ext = first(D47_SD), # External standard deviation (reported or based on check STD)
        binsd = if(is.na(SD_bin)){first(SD_ext)}else{max(SD_bin, SD_ext)}, # Find largest standard deviation
        Nbin = n(), # Calculate the number of modelled values, excluding NA's
        binse = binsd / sqrt(Nbin), # Calculate the standard error
        binCL95 = qt(0.95, Nbin) * binse, # Calculate the 95% confidence level
        param49_binmean = mean(param49, na.rm = TRUE), # Propagate param49 mean per sample
        param49_binsd = sd(param49, na.rm = TRUE), # Propagate param49 SD per sample
        Machine = first(Machine)
    ) %>%
    ungroup()

# write.csv(D47stats_Machinebin, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Aragonite_dataset_stats_by_Machine.csv")

# Now combine sample groups from different machines into one bin
D47stats <- D47stats_Machinebin %>%
    group_by(ID) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_mean = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        sd = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        N = sum(Nbin, na.rm = TRUE), # 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 = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        param49_sd = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    )

# write.csv(D47stats, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Aragonite_dataset_stats_grouped.csv")

# Summarize stats for Arctica islandica samples per specimen
# First propagate uncertainties on bins per specimen, keeping data from different machines separate
Aisstats_Machinebin <- dat[which(dat$D47_outlier != TRUE & dat$Analysis == "this study"), ] %>% # Summarize D47 statistics
    group_by(Specimen, Machine) %>%
    summarize(
        sample = first(sample),
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_binmean = mean(D47, na.rm = TRUE),  # Calculate means per sample
        SD_bin = sd(D47, na.rm = TRUE), # Calculate stdevs per sample bin
        SD_ext = first(D47_SD), # External standard deviation (reported or based on check STD)
        binsd = max(SD_bin, SD_ext), # Find largest standard
        Nbin = n(), # Calculate the number of modelled values, excluding NA's
        binse = binsd / sqrt(Nbin), # Calculate the standard error
        binCL95 = qt(0.95, Nbin) * binse, # Calculate the 95% confidence level
        param49_binmean = mean(param49, na.rm = TRUE), # Propagate param49 mean per sample
        param49_binsd = sd(param49, na.rm = TRUE), # Propagate param49 SD per sample
        Machine = first(Machine)
    ) %>%
    ungroup()

# write.csv(Aisstats_Machinebin, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Ais_dataset_stats_by_Machine.csv")

# Now combine sample groups from different machines into one bin
Aisstats <- Aisstats_Machinebin %>%
    group_by(Specimen) %>%
    summarize(
        Temp = mean(Temp, na.rm = TRUE),
        Temp_SD = first(Temp_SD),
        Analysis = first(Analysis),
        type = first(type),
        sample = first(sample),
        D47_mean = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        sd = binmeans(x = D47_binmean, x_sd = binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        N = sum(Nbin, na.rm = TRUE), # 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 = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "mean"),  # Calculate means per sample
        param49_sd = binmeans(x = param49_binmean, x_sd = param49_binsd, n = Nbin, output = "SD"), # Calculate stdevs per sample bin
        param49_se = param49_sd / sqrt(N),
        param49_CL95 = qt(0.95, N) * param49_se
    )

# write.csv(Aisstats, "E:/Dropbox//Research//postdoc//UNBIAS//Clumped Temperature Calibration/Ais_dataset_stats_grouped.csv")

# Update dat with new propagated SDs for regressions
newSDs <- D47stats[which(D47stats$Analysis == "this study"), which(colnames(D47stats) %in% c("ID", "sd"))]
dat$D47_SD[which(!is.na(match(dat$ID, newSDs$ID)))] <- newSDs$sd[match(dat$ID, newSDs$ID)[which(!is.na(match(dat$ID, newSDs$ID)))]]

# 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/is_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/is_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/is_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/is_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/is_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/is_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_York_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
newdat <- data.frame(Temp = seq(0, 1000, 0.1))
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 recalculated to the I-CDES scale
Guo09 <- data.frame(Temp = 10 ^ 6 / (seq(0, 1000, 0.1) + 273.15) ^ 2,
    D47_cc_original = -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), # Original formula published by Guo et al., 2009
    D47_ar_original = -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 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15), # Original formula published by Guo et al., 2009
    D47_cc_CDES25 = -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 + 0.268 - 0.232, # Corrected to CDES reference fram by updating the D47-D63 fractionation factor from 0.232 to 0.268
    D47_ar_CDES25 = -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 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232, # Corrected to CDES reference fram by updating the D47-D63 fractionation factor from 0.232 to 0.268
    D47_cc_CDES90 = -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 + 0.268 - 0.232 - 0.088, # Bring to CDES90 by applying the 25-70 degrees acid fractionation factor by Petersen et al., 2019
    D47_ar_CDES90 = -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 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232 - 0.088, # Bring to CDES90 by applying the 25-70 degrees acid fractionation factor by Petersen et al., 2019
    D47_cc_CDES90_corr = (-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 + 0.268 - 0.232 - 0.088) * 1.035, # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
    D47_ar_CDES90_corr = (-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 ^ 2 / (seq(0, 1000, 0.1) + 273.15) ^ 2 - 6.90300 / (seq(0, 1000, 0.1) + 273.15) + 0.22893 + 0.268 - 0.232 - 0.088) * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
)

# Values used to put Guo et al. 2009 data on the I-CDES scale
# ETH-1 - Iso A (Meckler et al., 2014) = 600 degr with D47 of 0.2052
# ETH-2 - Iso B (Meckler et al., 2014) = 600 degr with D47 of 0.2085
# ETH-3 - Iso C (Meckler et al., 2014) = ~20 degr with D47 of 0.6132

ETH1_GuoCDES <- Guo09$D47_ar_CDES25[which(Guo09$Temp == 10 ^ 6 / (600 + 273.15) ^ 2)]
ETH3_GuoCDES <- Guo09$D47_ar_CDES25[which(Guo09$Temp == 10 ^ 6 / (20 + 273.15) ^ 2)]
ETH1_ICDES <- 0.2052
ETH3_ICDES <- 0.6132

# Place on I-CDES scale
Guo09$D47_cc_ICDES <- (Guo09$D47_cc_CDES25 - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES # Use linear correction through ETH1 and ETH3 values to transform to I-CDES scale
Guo09$D47_ar_ICDES <- (Guo09$D47_ar_CDES25 - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES # Use linear correction through ETH1 and ETH3 values to transform to I-CDES scale
Guo09$D47_cc <- Guo09$D47_cc_ICDES * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)
Guo09$D47_ar <- Guo09$D47_ar_ICDES * 1.035 # Correct for D47-dependent D47-D63 fractionation factor of 35 ppm/per mille found by Guo et al. 2009 (and implemented in Jautzy et al., 2020)

# Arctica islandica plot (Figure 1)
source("05_A_islandica_plot.r")

# Full aragonite dataset plot (Figure 2)
source("06_Full_aragonite_plot.r")

# Summarize regression stats
regstats <- data.frame(regression = c("All data York", "low T York", "A. islandica York", "Mollusk York"),
    slope = c(D47m_York$coefficients[[2]], D47m_lowT_York$coefficients[[2]], Ais_York$coefficients[[2]], Mollusk_York$coefficients[[2]]),
    slope_SE = c(D47m_York$coefficients[[4]], D47m_lowT_York$coefficients[[4]], Ais_York$coefficients[[4]], Mollusk_York$coefficients[[4]]),
    intercept = c(D47m_York$coefficients[[1]], D47m_lowT_York$coefficients[[1]], Ais_York$coefficients[[1]], Mollusk_York$coefficients[[1]]),
    intercept_SE = c(D47m_York$coefficients[[3]], D47m_lowT_York$coefficients[[3]], Ais_York$coefficients[[3]], Mollusk_York$coefficients[[3]]),
    SER = c(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)
dat$D47res_Guo_cc <- dat$D47 - (((-3.33040 * 10 ^ 9 / (dat$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (dat$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (dat$Temp + 273.15) ^ 2 - 5.54042 / (dat$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
dat$D47res_Guo_ar <- dat$D47 - (((-3.43068 * 10 ^ 9 / (dat$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (dat$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (dat$Temp + 273.15) ^ 2 - 6.90300 / (dat$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

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)
D47stats$D47res_Guo_cc <- D47stats$D47_mean - (((-3.33040 * 10 ^ 9 / (D47stats$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (D47stats$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (D47stats$Temp + 273.15) ^ 2 - 5.54042 / (D47stats$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
D47stats$D47res_Guo_ar <- D47stats$D47_mean - (((-3.43068 * 10 ^ 9 / (D47stats$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (D47stats$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (D47stats$Temp + 273.15) ^ 2 - 6.90300 / (D47stats$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

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)
Aisstats$D47res_Guo_cc <- Aisstats$D47_mean - (((-3.33040 * 10 ^ 9 / (Aisstats$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (Aisstats$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (Aisstats$Temp + 273.15) ^ 2 - 5.54042 / (Aisstats$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
Aisstats$D47res_Guo_ar <- Aisstats$D47_mean - (((-3.43068 * 10 ^ 9 / (Aisstats$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (Aisstats$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (Aisstats$Temp + 273.15) ^ 2 - 6.90300 / (Aisstats$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

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)
violin_data$D47res_Guo_cc <- violin_data$D47 - (((-3.33040 * 10 ^ 9 / (violin_data$Temp + 273.15) ^ 4 + 2.32415 * 10 ^ 7 / (violin_data$Temp + 273.15) ^ 3 - 2.91282 * 10 ^ 3 / (violin_data$Temp + 273.15) ^ 2 - 5.54042 / (violin_data$Temp + 273.15) + 0.23252 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035
violin_data$D47res_Guo_ar <- violin_data$D47 - (((-3.43068 * 10 ^ 9 / (violin_data$Temp + 273.15) ^ 4 + 2.35766 * 10 ^ 7 / (violin_data$Temp + 273.15) ^ 3 - 8.06003 * 10 ^ 2 / (violin_data$Temp + 273.15) ^ 2 - 6.90300 / (violin_data$Temp + 273.15) + 0.22893 + 0.268 - 0.232) - ETH1_GuoCDES) * (ETH1_ICDES-ETH3_ICDES)/(ETH1_GuoCDES-ETH3_GuoCDES) + ETH1_ICDES) * 1.035

# Calculate values for calibrations relative to regressions through our dataset
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_York_result_res$Guo_cc <- Guo09$D47_cc - D47m_York_result$fit
D47m_York_result_res$Guo_ar <- Guo09$D47_ar - 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_lowT_York_result_res$Guo_cc <- Guo09$D47_cc[1:1001] - D47m_lowT_York_result$fit
D47m_lowT_York_result_res$Guo_ar <- Guo09$D47_ar[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
D47m_poly_MC_result_res$Guo_cc <- Guo09$D47_cc - D47m_poly_MC_result$fit
D47m_poly_MC_result_res$Guo_ar <- Guo09$D47_ar - 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)
source("07_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"))],
        dat$D47res_Guo_cc[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))],
        dat$D47res_Guo_ar[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"))], 4),
    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"))])),
        rep("Guo et al., 2009 (calcite)", length(dat$D47res_Meinicke[which(dat$type == "bivalve" & (dat$Analysis == "this study" | dat$Analysis == "Bernasconi18"))])),
        rep("Guo et al., 2009 (aragonite)", 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 = binmeans(x = D47_offset, x_sd = D47_SD, output = "mean"),
        D47_offset_SD = binmeans(x = D47_offset, x_sd = D47_SD, 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)
source("08_Calibration_offset_plot.r")


rm(list=ls(all=TRUE))
library(grid)
library(colorspace)
library(lubridate)
library(plyr)
library(ggplot2)
library(zoo)

pathInput <- "./Datasets/BirthRatesOk.txt"
pathDirectoryOutput <-  "./PublicationGraphs"
widthTotal <- 6.5
heightTotal <- 4.5

ds <- read.table(pathInput, header=TRUE, stringsAsFactor=F)
ds$Date <- as.Date(ds$Date)
day(ds$Date) <- 15

dateBombing <- as.Date("1995-04-19")
changePoint <- 74 #The 74th month is Feb 1996
changeMonth <- as.Date("1996-02-15") # as.Date(dateBombing + weeks(40))
fullFebruaryCount <- 9 #The number of Februaries with a full preceeding 12 month period.

monthsPerYear <- 12
monthCount <- nrow(ds)
yearCount <- monthCount / monthsPerYear

offset <- 240
colorBefore <- rainbow_hcl(2, start=0+offset, end=240+offset, c=100, l=65)[1]
colorAfter <- rainbow_hcl(2, start=0+offset, end=240+offset, c=100, l=65)[2] #h=120
smoothedLinear <- hcl(h=40, c=150, l=45)

transparencyFocus <- .5
transparencyBackground <- .3
bandColorBefore <- c(adjustcolor(colorBefore, transparencyFocus), adjustcolor(colorBefore, transparencyBackground))
bandColorAfter <- c(adjustcolor(colorAfter, transparencyBackground), adjustcolor(colorAfter, transparencyFocus))

graphCeiling <- 7
graphFloor <- 5
yAxisTicks <- c(5, 6, 7)

lowerQuantile <- .25
upperQuantile <- .75

ds$MonthIndex <- ds$MonthID %% monthsPerYear
ds$StageID <- ifelse(ds$MonthID<=changePoint, 1, 2)
# ds$Radians <- ds$MonthIndex * (2 * pi / monthsPerYear)
# ds$X <- ds$BirthRate * sin(ds$Radians)
# ds$Y <- ds$BirthRate * cos(ds$Radians)
#maxRate <- max(ds$BirthRate)
# tail(ds)

Summarize <- function( d ) {
  data.frame(
    Lower=quantile(d$BirthRate, probs=lowerQuantile),
    Upper=quantile(d$BirthRate, probs=upperQuantile)
)}
CalculateLowerBand <- function( x ) { return( quantile(x, probs=lowerQuantile) ) }
CalculateUpperBand <- function( x ) { return( quantile(x, probs=upperQuantile) ) }

dsBand <- ddply(ds, .variables=c("MonthIndex", "StageID"), Summarize)
dsBand <- rename(dsBand, replace=c("StageID"="StageIDBand"))
dsBands <- join(x=ds, y=dsBand, by="MonthIndex")
dsBands$InPhase <- (dsBands$StageID == dsBands$StageIDBand)

ds$Rolling <- rollapply(ds$BirthRate, 12, mean, align="right", fill=NA)
ds$RollingLower <- rollapply(ds$BirthRate, 12, CalculateLowerBand, align="right", fill=NA)
ds$RollingUpper <- rollapply(ds$BirthRate, 12, CalculateUpperBand, align="right", fill=NA)

dsFebruary <- ds[ds$MonthIndex==2 & !is.na(ds$Rolling), ]
dsStage1 <- ds[!is.na(ds$Rolling) & ds$MonthID<=changePoint, ]
dsStage2 <- ds[!is.na(ds$Rolling) & ds$MonthID>=changePoint, ]

#################
### This is a quick graph that should be easy to understand & generalize to other datasets.
#################
p <- ggplot(ds, aes(x=Date, y=BirthRate, color=StageID))
p <- p + geom_line(data=dsFebruary, aes(y=Rolling), size=1, color=smoothedLinear)
p <- p + geom_point(data=dsFebruary, aes(y=Rolling), size=4, shape=3, color=smoothedLinear)

p <- p + geom_ribbon(data=dsStage1, aes(ymin=RollingLower, ymax=RollingUpper), fill=bandColorBefore[2], color=NA )
p <- p + geom_ribbon(data=dsStage2, aes(ymin=RollingLower, ymax=RollingUpper), fill=bandColorAfter[2], color=NA )
p <- p + geom_point(shape=1)
p <- p + geom_line(size=1)
p <- p + geom_line(data=ds[!is.na(ds$Rolling), ], aes(y=Rolling), size=2)
p <- p + scale_color_continuous(low=colorBefore, high=colorAfter, guide=FALSE)
p <- p + geom_vline(xintercept=as.integer(changeMonth), color=colorAfter)
p <- p + annotate("text", x=changeMonth, y=max(ds$BirthRate), color=colorAfter, label="Bombing Effect")
p <- p + theme_minimal()
p <- p + labs(x="", y="General Fertility Rate")
p

ggsave(file.path(pathDirectoryOutput, "QuickFig2.png"), plot=p, dpi=600)

#################
### This is a lot fancier and heavily customized for this dataset to produce the publication graph.
#################

dateLocations <- seq.Date(from=as.Date("1990-01-01"), to=as.Date("2000-01-01"), by="year")
dateColors <- c(rep(colorBefore, 6), rep(colorAfter, 5))
dsLabelsX <- data.frame(
  X=seq.Date(from=as.Date("1990-07-01"), to=as.Date("1999-07-01"), by="year"),
  Y=graphFloor,
  Color=c(rep(colorBefore, 6), rep(colorAfter, 4)),
  stringsAsFactors=FALSE
)
dsLabelsX$Label <- lubridate::year(dsLabelsX$X)

dsBreak <- data.frame(X=changeMonth, XEnd=changeMonth, Y=5, YEnd=6.8, Label="Bombing Effect")

LinearPlot <- function( showLine=TRUE, showSmoother=TRUE, showRibbon=TRUE, showYears=TRUE, labelBreak=TRUE ) {
  g <- ggplot(ds, aes(x=Date, y=BirthRate, color=StageID))#
  g <- g + geom_segment(data=dsBreak, aes(x=X, xend=XEnd, y=Y, yend=YEnd), color=colorAfter, size=3, alpha=.3)

  if( labelBreak ) g <- g + geom_text(data=dsBreak, aes(x=X, y=YEnd, label=Label), color=colorAfter, vjust=-.5, alpha=.5, size=4)#6

  g <- g + geom_line(data=dsFebruary, aes(y=Rolling), color=smoothedLinear, alpha=.5)
  g <- g + geom_point(data=dsFebruary, aes(y=Rolling), size=2, shape=3, color=smoothedLinear)

  if( showRibbon ) {
    g <- g + geom_ribbon(data=dsStage1, aes(ymin=RollingLower, ymax=RollingUpper), fill=bandColorBefore[2], color=NA )
    g <- g + geom_ribbon(data=dsStage2, aes(ymin=RollingLower, ymax=RollingUpper), fill=bandColorAfter[2], color=NA )
  }
  g <- g + geom_point(shape=1, alpha=.5)

  if( showLine ) { #g <- g + geom_line() #This produces blocky lines, b/c it's checking for color switches
    g <- g + geom_line(data=dsStage1, color=colorBefore )
    g <- g + geom_line(data=dsStage2, color=colorAfter )
  }
  if( showSmoother) { #g <- g + geom_path(data=ds[!is.na(ds$Rolling), ], aes(y=Rolling)) #This produces blocky lines, b/c it's checking for color switches
    g <- g + geom_line(data=dsStage1, aes(y=Rolling), color=colorBefore )
    g <- g + geom_line(data=dsStage2, aes(y=Rolling), color=colorAfter )
  }

  if( showYears )
    g <- g + annotate("text", x=dsLabelsX$X, y=dsLabelsX$Y, color=dsLabelsX$Color, label=dsLabelsX$Label, vjust=-.5, size=3) #8
  if( !showYears )
    g <- g + annotate("text", x=dsLabelsX$X, y=dsLabelsX$Y, color=dsLabelsX$Color, label=dsLabelsX$Label, vjust=-.5, size=3, alpha=.3) #8

  g <- g + scale_x_date(breaks=dateLocations, labels=scales::date_format("%Y"))
  g <- g + scale_y_continuous(breaks=yAxisTicks)
  g <- g + scale_color_continuous(low=colorBefore, high=colorAfter, guide=FALSE)

  g <- g + theme_minimal()
  g <- g + theme(axis.title=element_text(color="gray60", size=9))
  g <- g + theme(axis.text.x=element_blank())
  g <- g + theme(axis.text.y=element_text(color="gray80"))
  g <- g + theme(axis.ticks.length = unit(0, "cm")) #g <- g + theme(axis.ticks=element_blank())
  g <- g + theme(axis.ticks.margin = unit(.00001, "cm"))
  g <- g + theme(panel.grid.minor.y=element_line(color="gray90", size=.1))
  g <- g + theme(panel.grid.major=element_line(color="gray85", size=.15))
  g <- g + theme(panel.margin = unit(c(0, 0, 0, 0), "cm"))
  g <- g + theme(plot.margin = unit(c(0, 0, 0, 0), "cm"))
  g <- g + labs(x="", y="General Fertility Rate")
  if( showRibbon ) g <- g + labs(x="(Bands Mark the .25 and .75 quantile for the previous 12 months)")
  g
}

LinearPlot()
top <- LinearPlot(showSmoother=FALSE, showRibbon=FALSE, showYears=FALSE) #Top Panel
middle <- LinearPlot(showLine=FALSE, showRibbon=FALSE, showYears=FALSE, labelBreak=FALSE) #Middle Panel
bottom <- LinearPlot(showLine=FALSE, labelBreak=FALSE) #Bottom Panel
vpLayout <- function(x, y) { viewport(layout.pos.row=x, layout.pos.col=y) }

# pdf(file.path(pathDirectoryOutput, "Fig2.pdf"), width=widthTotal, height=heightTotal)
png(file.path(pathDirectoryOutput, "Fig2.png"), width=widthTotal, height=heightTotal, units="in", res=600)
grid.newpage()
pushViewport(viewport(layout=grid.layout(3,1)))
print(top, vp=vpLayout(1,1))
print(middle, vp=vpLayout(2,1))
print(bottom, vp=vpLayout(3,1))
dev.off()


# Implement various helpers to normalise data.
# All these functions expect tidy data.
# TODO: All functions require documentation.

transform_counts = function (counts, fs, ...)
    dplyr::mutate_each_(counts, dplyr::funs_(lazyeval::lazy(fs)),
                        dplyr:::dots(...))

fpkm = function (counts, transcript_lengths)
    exp(log(counts) - log(transcript_lengths) - log(sum(counts)) + log(1e9))

tpm = function (counts, transcript_lengths) {
    rate = log(counts) - log(transcript_lengths)
    exp(rate - log(sum(exp(rate))) + log(1E6))
}

size_factors = function (counts) {
    log_counts = log(counts)
    log_means = rowMeans(log_counts)
    finite = ! is.infinite(log_means)
    dplyr::summarise_each(log_counts,
                          dplyr::funs(exp(median((. - log_means)[finite]))))
}


subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror)

# The Lee-Schacter test for the LOP (all points are real,
# i.e. non-ideal).  If the LOP is ***not*** satisfied (i.e. if
# vertex j is inside the circumcircle of vertices h, i, and k) then the
# diagonals should be swapped, i.e. shdswp ("should-swap") is true.
# Called by qtest.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3), indv(3)
integer h
logical shdswp, collin

# The vertices of the quadrilateral are labelled
# h, i, j, k in the anticlockwise direction, h
# being the point of central interest.

# Make sure the quadrilateral is convex, so that
# it makes sense to swap the diagonal.
# call acchk(i,j,k,shdswp,x,y,ntot,eps)
# if(!shdswp) return
#
# 23 July 2011:
# The foregoing test is a load of dingoes' kidneys.  (1) It is
# unnecessary, and (2) it is wrong!  (1) If the LOP is not satisfied
# (the only circumstance under which there should be a swap) then the
# quadrilateral ***must*** be convex, and so swapping can sensibly
# take place.  (2) The vertices i, j, k in will ***always*** be in
# anticlockwise order, since the vertices h, i, j, k of the quadrilateral
# are in such order and i is connected to k, whence j can't be inside
# the triangle ihk.  So the test does nothing.  But then it didn't need
# to do anything.

# Check for collinearity of points h, i and k.
xt(1) = x(h)
yt(1) = y(h)
xt(2) = x(i)
yt(2) = y(i)
xt(3) = x(k)
yt(3) = y(k)
nid = 0  # nid = number of ideal points.
call cross(xt,yt,nid,cprd)
collin = (abs(cprd) < eps) # Does this work???

# If the points are collinear, make sure that they're in the right
# order --- h between i and k.
if(collin) {
# Form the vector u from h to i, and the vector v from h to k,
# and normalize them.
    a  = xt(2) - xt(1)
    b  = yt(2) - yt(1)
    c  = xt(3) - xt(1)
    d  = yt(3) - yt(1)
    c1 = sqrt(a*a+b*b)
    c2 = sqrt(c*c+d*d)
    a  = a/c1
    b  = b/c1
    c  = c/c2
    d  = d/c2
    alpha = a*c+b*d
# If they're not in the right order, bring things to
# a shuddering halt.
    if(alpha>0) {
        call intpr("error detected in qtest1",-1,1,0)
        indv(1) = i
        indv(2) = j
        indv(3) = k
        call intpr("Point being added, h:",-1,h,1)
        call intpr("now, other vertex, nxt:",-1,indv,3)
        call dblepr("Test value:",-1,alpha,1)
        call rexit("Points are collinear but h not between i and k.")
    }
# Collinear, and in the right order; think of this as meaning
# that the circumcircle in question has infinite radius.
    shdswp = .true.
}

# Get the coordinates of vertices h and j.
xh = x(h)
yh = y(h)
xj = x(j)
yj = y(j)

# Find the centre of the circumcircle of vertices h, i, k.
call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror)
if(nerror>0) return
if(shdswp) return # The points h, i, and k are colinear, so
                  # the circumcircle has `infinite radius', so
                  # (xj,yj) is definitely inside.

# Check whether (xj,yj) is inside the circle of centre
# (x0,y0) and radius r = dist[(x0,y0),(xh,yh)]

a  = x0-xh
b  = y0-yh
r2 = a*a+b*b
a  = x0-xj
b  = y0-yj
ch = a*a + b*b
if(ch<r2) shdswp = .true.
else shdswp = .false.

return
end


#!/usr/bin/env Rscript

data <- read.table("gasslit.txt", head=TRUE)
pts = 0.5*(data$vr+(-data$vl))
if (sum(pts)<0) {
	pts <- -pts
	data$vr <- -data$vr
	data$vl <- -data$vl
}

phi <- read.table("halophi.txt", head=TRUE)
phifunc <- splinefun(phi$r, phi$pot)
realv <- sqrt(phifunc(phi$r, deriv=1)*phi$r)

pole1phi <- read.table("polar1phi.txt", head=TRUE)
phifunc <- splinefun(pole1phi$r, pole1phi$pot)
realv1 <- sqrt(phifunc(phi$r, deriv=1)*phi$r)

pole2phi <- read.table("polar2phi.txt", head=TRUE)
phifunc <- splinefun(pole2phi$r, pole2phi$pot)
realv2 <- sqrt(phifunc(phi$r, deriv=1)*phi$r)

gas <- read.table("gaspoints.txt", head=TRUE)
star <- read.table("starpoints.txt", head=TRUE)

#dv <- numeric(0)
#for(r in data$r) {
#	n <- which(abs(gas$r-r)<data$r[2]-data$r[1])
#	dv <- c(dv, median(sqrt(gas$vzsq[n])))
#}

spherical <- read.table("gmoverr.txt", head=TRUE)
tring <- read.table("trcurve.txt", head=TRUE)
galid <- read.table("galid.txt", head=FALSE)[1,1]

pdf("rc.pdf")
plot(data$r*1e3, pts, ylim=c(0,1.5*max(c(data$vr, -data$vl))), xlim=c(0,max(data$r*1e3)/2), xlab="R[kpc]", ylab=expression(v[c]~"[kpc]"))
segments(data$r*1e3, data$vr, data$r*1e3, -data$vl)
#plot(phi$r*1000, realv, lty=1, col="purple", lwd=2, xlim=c(0,10), type="l", xlab="R[kpc]", ylab=expression(v[c]~"[kpc]"))
lines(phi$r*1000, realv, lty=1, col="purple", lwd=2)
lines(phi$r*1000, realv1, lty=2, col="purple", lwd=2)
lines(phi$r*1000, realv2, lty=3, col="purple", lwd=2)
lines(tring$r*1e3, tring$v,lty=2, col="green", lwd=2)
#points(data$r*1e3, pts+dv, pch=4)
lines(spherical$r*1e3, spherical$v, lty=1, col="red", lwd=2)
#points(gas$r*1e3, sqrt(gas$vzsq), cex=0.1, xlim=c(0,10))
if (galid==4) {
	segments(0, 207.79, 15, 207.79, lty=2)
}
if (galid==1) {
	segments(0, 221.36, 15, 221.36, lty=2)
}

dev.off()


library(ggplot2)
library(reshape2)
library(zoo)
library(igraph)
source("cleandata.r")

bargraph <- function(yourData){

  df = yourData
  df = cleanData(df)
  df = zoo(df)
  barplot(df, main = "Histogram Plot", beside = TRUE)

}

heatgraph <- function(yourData){

  cormat <- round(cor(yourData),2)
  melted_cormat <- melt(cormat)
  ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill=value), title("Heatmap Plot")) +
    geom_tile() + ggtitle("Heatmap") +
    xlab("Features") + ylab("Features")

}

densgraph <- function(yourData){
  df = yourData
  df = cleanData(df)
  df = zoo(df)
  plot(df, main = "Density Plot")

}

net <- function(yourData){
  df = yourData
  df = cleanData(df)
  plot(graph_from_incidence_matrix(yourData))
}


# R

gcd <- function(a, b) {
    if (b > 0) return(gcd(b, a %% b))
    else return(a)
}

cat("test\n")

N <- 1000
A <- list()
for (i in 0:N-1) {
    A[i+1] <- i # R lists are 1-indexed!
}

ans <- 0
for (i in A) {
    for (j in A) {
        ans <- gcd(i, j) + ans
    }
}
cat(ans)


library(rootSolve)

#' Iterative GEE Function
#'
#' Iteratively finds coefficients and overdispersion parameter using
#' estimating equations.
#'
#' @param dat matrix of multinomial clusters
#' @param RHO if FALSE, rho will not be estimated
#' @param max.iter max number of iterations
#' @param thresholds vector of thresholds for betas and rho
#'
#' @return list containing estimates (probabilities and rho) and number of iterations
iterative_function <- function(dat, RHO = FALSE, max.iter = 10, thresholds = NULL) {
  n <- dim(dat)[[2]]
  if (is.null(thresholds)) thresholds <- rep(0.00000001, n)

  m <- n - 1
  betas.prev <- numeric(m) + 1
  rho.prev <- 0
  betas <- betas.prev + 100 * thresholds[1:m]
  rho <- 100 * thresholds[n]

  iter <- 0
  e <- FALSE

  # in this mode, assume rho to be 0
  if (RHO == FALSE) {
    # solve beta equations
    db2 <- multiroot(f = create_beta_equations,
                     start = betas.prev,
                     rho = rho,
                     dat = dat)
    # update betas
    betas <- db2$root
    rho <- 0
    iter <- db2$iter
  } else {
    # alternate between beta and rho equations until parameters are close enough
    # based on the given thresholds or until max number of iterations is reached
    while (abs( c(betas, rho) - c(betas.prev, rho.prev) ) > thresholds &&
           iter < max.iter) {
      betas.prev <- betas
      # solve beta equations
      db2 <- multiroot(f = create_beta_equations,
                       start = betas.prev,
                       rho = rho,
                       dat = dat)
      # update betas
      betas <- db2$root
      rho.prev <- rho
      # solve rho equations
      db3 <- tryCatch(uniroot(f = create_rho_equations,
                              interval = c(0, 1),
                              betas = betas,
                              dat = dat),
                      error = function (err) {
                        warning("rho couldn't be estimated, try using gmo(dat, corstr = \"independence\")",
                                call. = FALSE,
                                immediate. = TRUE)
                        return(NA)
                      })

      # print(db3)
      if (!is.list(db3) && is.na(db3)) {e <- TRUE; break}

      # update rho
      rho <- db3$root
      iter <- iter + 1
    }
  }

  out <- list(betas = betas, rho = rho, num.iter = iter, error = e)
  out
}


dyn.load("tlpreg")

# multiple regression
library(foreach)

mtlpreg0 <- function(Y, X, b.init=NULL, tau=0.5*sqrt(log(p)/n), gamma=NULL, pen.fac=rep(1,ncol(X)),
                    tol=1e-4, dc.maxit=as.integer(max(5,1+log2(n/log(p)))), cd.maxit=1e+4) {

    # Y is n by q mat, q < n
    # X is n by p mat

    n <- as.integer(nrow(X))
    p <- as.integer(ncol(X))
    xtx <- colSums(X*X)

    B <- foreach(k = 1:ncol(Y), .combine="cbind") %do% {
        # initialize gamma sequence
        r <- Y[,k] - mean(Y[,k])
        if(is.null(gamma)) {
            gamma <- exp(seq(from=log(max(abs(crossprod(X, r)))/n),
                              to=log(ifelse(p < n, 0.001, .08)),
                              length.out=100))/tau
        }
        ngamma <- as.integer(length(gamma))

        # initialize working residuals, b matrix, intercept
        if(is.null(b.init)) {
            b <- matrix(0, p, ngamma)
        } else {
            r <- r - X %*% b.init[,k]
            b <- matrix(b.init, p, ngamma)
        }
        b0 <- 0

        pen.fac <- as.integer(pen.fac)

        # call regularized version
        .Call('tlpreg_r', X, b0, b, r, xtx, n, p, tau, gamma, ngamma, pen.fac, tol, as.integer(dc.maxit), as.integer(cd.maxit))

        b
    }

    covar <- crossprod(Y - X %*% B)/n
    list(B = B, covar = covar, gamma = gamma)
}

fit.mtlpreg0 <- function(Y, X, b.init = NULL, pen.fac = rep(1,ncol(X)),
                      tau=0.5*sqrt(log(p)/n), gamma=NULL, nfold=10,
                      tol=1e-4, dc.maxit=as.integer(max(5,1+log2(n/log(p)))), cd.maxit=1e+4) {
    n <- nrow(X)
    p <- ncol(X)
    if (n < nfold) stop("nfold cannot be larger than n.")

    obs.fold <- rep(1:nfold,n)[sample.int(n)]
    foreach(k = 1:ncol(Y)) %do% {
        if(is.null(gamma)) {
            gamma <- exp(seq(from=log(max(abs(crossprod(X, Y[,k] - mean(Y[,k]))))/n),
                             to=log(ifelse(p < n, .001, .08)),
                             length.out=100))/tau
        }
        # nfold-cross-validation

        cv <- foreach(fold = 1:nfold, .combine = "cbind") %do% {
            #source("tlpreg.r")
            b <- tlpreg0(y=Y[obs.fold!=fold,k], X=X[obs.fold!=fold,], b.init = b.init,
                         tau=tau, gamma = gamma, pen.fac = pen.fac,
                         tol = tol, dc.maxit = dc.maxit, cd.maxit = cd.maxit)$b

            apply(b, 2, function(beta) {
                res <- (Y[obs.fold==fold,k] - X[obs.fold==fold,] %*% beta)
                mean((res - mean(res))^2)
            })
        }

        tlpreg0(y = Y[,k], X = X, b.init = b.init, pen.fac = pen.fac,
                tau=tau, gamma=gamma[which.min(rowMeans(cv))], tol=tol, dc.maxit=dc.maxit, cd.maxit=cd.maxit)
    }

}


library(drat)
library(dde)
library(odin)

drat::add("mrc-ide")

# beta matrix: random initialisation -----------------------------------------------------
beta.mat <- function (nr_patches) {
  ## beta: positive, non-symmetric matrix of effective contact rates
  ## values are higher on the diagonal (transmission is higher *within*-patch),
  ## values decrease gradually further away from the diagonal (*between*-patch transmission)
  beta <- matrix(0, nrow=nr_patches, ncol=nr_patches)
  for (i in 0:(nr_patches-1)) {
    ## superdiagonal: scale vector s.t. numbers decrease further away from diagonal
    rand.vec <- rnorm(nr_patches-i, 10 * (nr_patches-i)/nr_patches, 2)
    beta[row(beta) == col(beta) - i] <- rand.vec
    ## subdiagonal
    rand.vec <- rnorm(nr_patches-i, 10 * (nr_patches-i)/nr_patches, 2)
    beta[row(beta) == col(beta) - i] <- rand.vec
  }
  return(beta)
}

# mobility matrix: random initialisation -----------------------------------------------------
mob.mat <- function (nr_patches) {
  ## mobility matrix (origin-destination matrix of proportion of population that travels) #TODO trip counts or relative?
  C <- matrix(0, nrow=nr_patches, ncol=nr_patches)
  if (nr_patches > 1) {
    diag(C) <- -sample(1:25, nr_patches, replace=TRUE)
    for (i in 1:nr_patches) {
      C[i, which(C[i, ] == 0)] <- rmultinom(n = 1, size = -C[i,i], prob = rep(1, nr_patches-1))
    }
    C <- C/100
  }
  return(C)
}

# plotting --------------------------------------------------------------------#
plot.pretty <- function(out, nr_patches, what) {

  # plot total densities by disease status --------------------------------------#
  if (what == "total") {
    ## compute total densities by disease status
    S_tot <- rowSums(out$S) / nr_patches
    E_tot <- rowSums(out$E) / nr_patches
    I_tot <- rowSums(out$I) / nr_patches
    R_tot <- rowSums(out$R) / nr_patches

    ## plot total densities by disease status
    par(mfrow=c(1, 1), las=1, omi=c(1,0,0,0), xpd=NA)
    plot( t, S_tot, col="green",
          type="l", xlab="Days", ylab="Densities",
          main="Total densities by disease status")
    lines(t, E_tot, col="orange")
    lines(t, I_tot, col="red")
    lines(t, R_tot, col="blue")
    legend(-8.5, -0.3, title="Disease statuses", horiz=TRUE,
           legend=c("Susceptible", "Exposed", "Infectious", "Recovered"),
           col=c("green", "orange", "red", "blue"), lty=1)
  }

  # plot densities of some patches by disease status ----------------------------#
  if (what == "panels") {
    ## define the plot panels
    if (nr_patches >= 6) {
      mfrow=c(2, 3)
      panels <- as.integer( seq(1, nr_patches, length.out=6))
    } else if (nr_patches >= 4) {
      mfrow=c(2, 2)
      panels <- as.integer( seq(1, nr_patches, length.out=4))
    } else {
      mfrow=c(1, nr_patches)
      panels <- 1:nr_patches
    }
    par(mfrow=mfrow, las=1, omi=c(1,0,0.3,0), xpd=NA)

    ## plot the disease statuses of some patches
    ymax <- max(out$N[, panels])
    for (i in panels) {
      plot (t, out$S[, i], col="green", ylim=c(0, ymax),
            type="l", xlab="Days", ylab="Densities",
            main=paste("Patch ", i))
      lines(t, out$E[, i], col="orange")
      lines(t, out$I[, i], col="red")
      lines(t, out$R[, i], col="blue")
    }
    title("Densities by disease status", outer=TRUE)
    legend(-130, -1.2, title="Disease statuses", horiz=TRUE,
           legend=c("Susceptible", "Exposed", "Infectious", "Recovered"),
           col=c("green", "orange", "red", "blue"), lty=1)
  }

}

SEIR_cont <- odin::odin({
  nr_patches <- user()
  n <- nr_patches

  ## Params
  lambda_prod[ , ] <- beta[i, j] * I[j]
  lambda[] <- sum(lambda_prod[i, ]) # rowSums

  mob_prod[ , ] <- S[i] * C[i, j]
  mob_S[] <- sum(mob_prod[, i])     # colSums
  mob_prod[ , ] <- E[i] * C[i, j]
  mob_E[] <- sum(mob_prod[, i])
  mob_prod[ , ] <- I[i] * C[i, j]
  mob_I[] <- sum(mob_prod[, i])
  mob_prod[ , ] <- R[i] * C[i, j]
  mob_R[] <- sum(mob_prod[, i])

  N[] <- S[i] + E[i] + I[i] + R[i]
  output(N[]) <- TRUE

  ## Derivatives
  deriv(S[]) <- mu - mu*S[i] - S[i]*lambda[i]         + M[1] * mob_S[i]
  deriv(E[]) <- S[i]*lambda[i] - (mu + sigma) * E[i]  + M[2] * mob_E[i]
  deriv(I[]) <- sigma*E[i] - (mu + gamma)*I[i]        + M[3] * mob_I[i]
  deriv(R[]) <- gamma*I[i] - mu*R[i]                  + M[4] * mob_R[i]

  ## Initial conditions
  initial(S[]) <- 1.0 - 1E-6
  initial(E[]) <- 0.0
  initial(I[]) <- 1E-6
  initial(R[]) <- 0.0

  ## parameters
  beta[,] <- user()   # effective contact rate
  sigma   <- 1/3      # rate of breakdown to active disease
  gamma   <- 1/3      # rate of recovery from active disease
  mu      <- 1/10     # background mortality
  C[,]    <- user()   # origin-destination matrix of proportion of population that travels
  M[]     <- user()   # relative migration propensity by disease status

  ## dimensions
  dim(beta)        <- c(n, n)
  dim(C)           <- c(n, n)
  dim(M)           <- 4
  dim(lambda_prod) <- c(n, n)
  dim(lambda)      <- n
  dim(mob_prod)    <- c(n, n)
  dim(mob_S)       <- n
  dim(mob_E)       <- n
  dim(mob_I)       <- n
  dim(mob_R)       <- n
  dim(S)           <- n
  dim(E)           <- n
  dim(I)           <- n
  dim(R)           <- n
  dim(N)           <- n

})

# set seed
set.seed(1)

# SEIR free parameters --------------------------------------------------------#
## total number of patches in the model
nr_patches = 20
## relative migration propensity by disease status (S, E, I, R)
M <- c(1, 0.5, 1, 1)
## matrix of effective contact rates
beta <- beta.mat(nr_patches)
## mobility matrix
C <- mob.mat(nr_patches)

# run SEIR model --------------------------------------------------------------#
mod <- SEIR_cont(nr_patches=nr_patches, beta=beta, C=C, M=M)
t <- seq(0, 50, length.out=50000)
out <- mod$run(t)
out <- mod$transform_variables(out)
# error check -----------------------------------------------------------------#
if ( ! all( abs(rowSums(out$N) - nr_patches) < 1E-10 ) )
  warning("Something went wrong, density is increasing/decreasing!\n")

# plot total densities by disease status --------------------------------------#
plot.pretty(out, nr_patches, "total")

# plot densities of some patches by disease status ----------------------------#
plot.pretty(out, nr_patches, "panels")


library(pROC)
library(ggplot2)
library(dplyr)
library(tidyr)

# h2l <- h2o * k^2 * (1-k)^2 / (p * (1 - p) * dnorm(threshold)^2)

# Calculating disease risk on observed scale
# Requires some
# Check that gx to go works

d <- expand.grid(
	g = seq(-4,4,by=0.1),
	h2x = c(0.35, 0.5, 1),
	prev = c(0.004, 0.2, 0.5)
)
d$gr <- 1:nrow(d)
d$x_prime <- qnorm(d$prev, 0, 1)
d$e2x <- 1 - d$h2x
d$z <- dnorm(d$x_prime, mean=d$g, sd = sqrt(d$e2x))
d$p <- pnorm(d$x_prime, mean=d$g, sd = sqrt(d$e2x), lower.tail=FALSE)
d$p1 <- gx_to_gp(d$g, d$h2x, d$prev)

d <- group_by(d, h2x, prev) %>%
	mutate(p = range01(p), g = range01(g))

d1 <- gather(d, key, value, g, p)

ggplot(d1, aes(x=value, y=key)) +
geom_point(aes(colour=key)) +
geom_line(aes(group=gr)) +
facet_grid(h2x ~ prev)

# Model 1
# Common variant-common disease

nid <- 1000
nsnp <- 1000
h2x <- 0.3
prev <- 0.5
G_cdcv <- scale(make_geno(nid, nsnp, 0.5))
eff_cdcv <- rnorm(nsnp, sd=sqrt(h2x))
dat_cdcv <- risk_simulation(
	G=G_cdcv,
	eff=eff_cdcv,
	prevalence=prev,
	prop_discovered=0.1
)
plot(roc(disease ~ gx_true, dat_cdcv))

table(dat_cdcv$disease)
var(dat_cdcv$gx_true)
plot(roc(disease ~ gx_true, dat_cdcv))
plot(roc(disease ~ gx_pred, dat_cdcv))
risk_cross_plot(o=dat_cdcv$prob_disease, x=dat_cdcv$gx_true)
risk_cross_plot(o=dat_cdcv$disease, x=dat_cdcv$gx_true, title="Genetic values mapped to disease")
risk_cross_plot(o=dat_cdcv$disease, x=dat_cdcv$gx_pred, title="Genetic predictor of disease")

nid <- 100
nsnp <- 1000
h2x <- 0.8
prev <- 0.5
G_cdcv <- scale(make_geno(nid, nsnp, 0.5))
eff_cdcv <- rnorm(nsnp, sd=sqrt(h2x))
dat_cdcv <- risk_simulation(
	G=G_cdcv,
	eff=eff_cdcv,
	prevalence=prev,
	prop_discovered=0.1
)
pdf(file="roc_0.8_0.5.pdf")
plot(roc(disease ~ gx_true, dat_cdcv))
dev.off()

pdf(file="roc_0.8_0.5_0.1.pdf")
plot(roc(disease ~ gx_pred, dat_cdcv))
dev.off()

risk_cross_plot(o=dat_cdcv$disease, x=dat_cdcv$gx_true, title="Genetic values mapped to disease")
ggsave(file="cp_0.8_0.5.pdf", width=8,height=3)
risk_cross_plot(o=dat_cdcv$disease, x=dat_cdcv$gx_pred, title="Genetic predictor of disease using only 10% of causal variants")
ggsave(file="cp_0.8_0.5_0.1.pdf", width=8,height=3)

nid <- 1000
nsnp <- 1000
h2x <- 0.3
prev <- 0.5
G_cdcv <- scale(make_geno(nid, nsnp, 0.5))
eff_cdcv <- rnorm(nsnp, sd=sqrt(h2x))
dat_cdcv <- risk_simulation(
	G=G_cdcv,
	eff=eff_cdcv,
	prevalence=prev,
	prop_discovered=0.1
)
pdf(file="roc_0.3_0.5.pdf")
plot(roc(disease ~ gx_true, dat_cdcv))
dev.off()

pdf(file="roc_0.3_0.5_0.1.pdf")
plot(roc(disease ~ gx_pred, dat_cdcv))
dev.off()

risk_cross_plot(o=dat_cdcv$disease, x=dat_cdcv$gx_pred, title="Genetic predictor of disease using only 10% of causal variants")

nid <- 10000
nsnp <- 1000
h2x <- 0.3
prev <- 0.01
G_cdcv <- scale(make_geno(nid, nsnp, 0.5))
eff_cdcv <- rnorm(nsnp, sd=sqrt(h2x))
dat_cdcv <- risk_simulation(
	G=G_cdcv,
	eff=eff_cdcv,
	prevalence=prev,
	prop_discovered=0.1
)
pdf(file="roc_0.3_0.01.pdf")
plot(roc(disease ~ gx_true, dat_cdcv))
dev.off()

# Model 2
# Every case has a specific mutation
# Rare variant-common disease

nid <- 1000
nsnp <- 1000
h2x <- 0.3
prev <- 0.5
G_cdrv <- diag(nid)
diag(G_cdrv)[1:(nid/2)] <- 0
eff_cdrv <- scale(rnorm(nid, diag(G_cdrv), 0.001)) * sqrt(h2x)
dat_cdrv <- risk_simulation(
	G=G_cdrv,
	eff=eff_cdrv,
	prevalence=prev,
	prop_discovered=0.1
)

table(dat_cdrv$disease)
var(dat_cdrv$gx_true)

pdf("roc_0.3_0.5_rare.pdf")
plot(roc(disease ~ gx_true, dat_cdrv))
dev.off()

pdf("roc_0.3_0.5_0.1_rare.pdf")
plot(roc(disease ~ gx_pred, dat_cdrv))
dev.off()

risk_cross_plot(o=dat_cdrv$prob_disease, x=dat_cdrv$gx_true)
risk_cross_plot(o=dat_cdrv$disease, x=dat_cdrv$gx_true, title="Genetic values mapped to disease")
risk_cross_plot(o=dat_cdrv$disease, x=dat_cdrv$gx_pred, title="Genetic predictor of disease")


## Test handling of NAs in original data by robcov
require(rms)
set.seed(1)
n <- 100
x1 <- runif(n)
x2 <- runif(n)
y  <- x1 + x2 + 3 * runif(n)
x1[1] <- NA
x1 <- c(x1, x1)
x2 <- c(x2, x2)
y  <- c(y, y)
clus <- c(1 : n, 1 : n)
f <- ols(y ~ x1 + x2, subset = 1 : n)
vcov(f)
g <- ols(y ~ x1 + x2, x=TRUE, y=TRUE)
vcov(g)
h <- robcov(g, clus)
h
sqrt(diag(h$var))
vcov(h)
vcov(h) / vcov(f)


#' Minimum Set Cover for a Binary Matrix
#'
#' @param x binary matrix of features
#' @param y binary vector of predictor
#' @param xe binary vector of example observation
#' @param ye binary value of example predictor
#' @param complement whether to add the complement of x as features
#' @export
#' @importClassesFrom Matrix TsparseMatrix
min_set_cover <- function(x, y, xe, ye, complement = TRUE) {
  # add complement variables
  if (complement) {
    x <- cbind(x, 1L - x)
    xe <- c(xe, 1L - xe)
  }

  # check dimensions
  n <- nrow(x)
  d <- ncol(x)
  stopifnot(length(y) == n)
  stopifnot(length(xe) == d)
  stopifnot(length(ye) == 1)

  # setup logfile
  #logfile <- tempfile(pattern = "gcr-", fileext = ".log")
  #logfile <- normalizePath(logfile, mustWork = FALSE)
  #cat(sprintf("writing solver log to %s\n", logfile))

  # build constraint matrix
  idx <- which(y != ye)
  s <- length(idx)

  # initialize empty contraint matrix
  m <- matrix(0L, nrow = 2 + s, ncol = 1 + d)

  # add "consistent" constraints
  m[1:s,1:d] <- 1L - x[idx,]

  # add "relevance" constraint
  m[1 + s, 1:d] <- xe
  m[1 + s, 1 + d] <- -1L

  # add auxillary variable constraint
  m[2 + s, 1:d] <- 1L
  m[2 + s, 1 + d] <- -1L

  # convert contraint matrix to sparse i,j,v triplet
  m <- methods::as(m, "TsparseMatrix")
  mi <- m@i + 1L
  mj <- m@j + 1L
  mv <- as.integer(m@x)

  # run min_set_cover algorithm
  r <- min_set_cover_cpp(mi, mj, mv, n, d, s)

  # remove complement variables
  if (complement) {
    alpha <- r$alpha
    r$alpha <- ifelse(alpha > d/2, alpha - d/2, alpha)
  }

  r
}


library(ggplot2)
library(grid)
library(gridExtra)

file_perf_perSample = '../Results/ReconstructionAndPredictionMicrobialComposition/performance_per_sample.tsv'

# Read table with one row per sample, and different columns with different performance metrics (pearson_reconstructed,	pearson_predicted,	braycurtis_reconstructed,	braycurtis_predicted)
perf_perSample <- read.table(file_perf_perSample,sep='\t',row.names=1,header=TRUE,check.names=FALSE)

#plot(perf_perSample[2:1], main='Pearson Correlation versus original', xlab='Predicted from environment', ylab='Reconstructed')

#plot(perf_perSample[4:3], main='Bray-Curtis dissimilarity versus original', xlab='Predicted from environment', ylab='Reconstructed')

# Plot
p_pearson <- ggplot(perf_perSample, aes(x = pearson_predicted , y = pearson_reconstructed)) +
  geom_point(size = 0.5) +
  theme_bw() +
  theme(panel.grid.major.y = element_blank()) +
  xlab('') +
  ylab('Reconstructed') +
  ggtitle('Pearson correlation')

p_braycurtis <- ggplot(perf_perSample, aes(x = braycurtis_predicted , y = braycurtis_reconstructed)) +
  geom_point(size = 0.5) +
  theme_bw() +
  theme(panel.grid.major.y = element_blank()) +
  xlab('') +
  ylab('') +
  xlim(0, 1) +
  ylim(0, 1) +
  ggtitle('Bray-Curtis dissimilarity')

grid.newpage()
my_layout<-rbind(c(1,2))
combined<-grid.arrange(arrangeGrob(p_pearson),arrangeGrob(p_braycurtis), layout_matrix=my_layout,bottom = textGrob('Predicted from environment'))

pdf('../Results/ReconstructionAndPredictionMicrobialComposition/performance_per_sample_scatterplot.pdf', height=3, width=5)
grid.draw(combined)
dev.off()


#@reemuru
#data mining
#artificial neural networks

#set the working directory
setwd("./ann/")

#load CreditApproval file with headers in the first row
heart<-read.csv(file = "whas1.csv", header = TRUE, sep = ",")

#initialize neural net library
library(neuralnet)
library(psych)

#preview the dataset
head(heart)

#summary statistics
summary(heart)

#structure of dataset
str(heart)

#remove ID variable, not conducive to analysis
heart$ID<-NULL

#use scatterplot matrix for exploratory data analysis
pairs.panels(heart)

#scale the dataset
heart[1:12]<-scale(heart[1:12])

#set the seed values assures reproducible results
set.seed(12345)
ind <- sample(2, nrow(heart), replace = TRUE, prob = c(0.7, 0.3))
train.data <- heart[ind == 1, ]
test.data <- heart[ind == 2, ]

#use vectors for more than one hidden layer
#set linear output to false for classification
nn<-neuralnet(formula = FSTAT~AGE+SEX+CPK+SHO+CHF+MIORD+MITYPE+YEAR+YRGRP+LENSTAY+DSTAT+LENFOL
                , data = train.data, hidden=2,
              err.fct="ce", linear.output = FALSE)

#display the network properties
names(nn)

#values of input variables used to build the model
nn$covariate

#list of all DV and IV in the model
nn$model.list

#probability of positive test result for each patient
nn$net.result

#predicted probabilities for the first 10 instances
nn$net.result[[1]][1:10]

#weights from input layer to hidden nodes, output nodes intercept etc.
nn$weights

#weights for first interation
nn$startweights

#training steps, errors, weights, etc.
nn$result.matrix

#estimate probabilities for training data with compute()
mypredict<-compute(nn, nn$covariate)$net.result

#round probabilites to zero or one
mypredict<-apply(mypredict, c(1), round)

#display first 10 values for mypredict
mypredict[1:10]

#training set confusion matrix
cm<-table(mypredict, train.data$FSTAT, dnn =c("Predicted", "Actual"))
cm

#estimate probabilities for test data with compute()
testPred <- compute(nn, test.data[, 0:12])$net.result

##round probabilites to zero or one
testPred<-apply(testPred, c(1), round)

#test set confusion matrix
cm2<-table(testPred, test.data$FSTAT, dnn =c("Predicted", "Actual"))
cm2

#classification accuracy
#accuracy = TN + TP / N + P
(cm[1]+cm[4])/sum(cm) #training set
(cm2[1]+cm2[4])/sum(cm2) #test set

#Rebuild model with least amount of IV
#Parameter tuning and model rebuilding
#reload the dataset
heart2<-read.csv(file = "whas1.csv", header = TRUE, sep = ",")

#data reduction
heart2$ID<-NULL
heart2$YEAR<-NULL
heart2$YRGRP<-NULL
heart2$LENSTAY<-NULL
heart2$LENFOL<-NULL

#use scatterplot matrix for exploratory data analysis
pairs.panels(heart2)

#summary statistics
summary(heart2)

#scale the dataset
heart2[1:8]<-scale(heart2[1:8])

#set the seed values assures reproducible results
set.seed(12345)
ind <- sample(2, nrow(heart2), replace = TRUE, prob = c(0.7, 0.3))
train.data <- heart2[ind == 1, ]
test.data <- heart2[ind == 2, ]

#use vectors for more than one hidden layer
#set linear output to false for classification
nn2<-neuralnet(formula = FSTAT~AGE+SEX+CPK+SHO+CHF+MIORD+MITYPE, data = train.data, hidden=3,
              err.fct="ce", linear.output = FALSE)

#display the network properties
names(nn2)

#values of input variables used to build the model
nn2$covariate

#list of all DV and IV in the model
nn2$model.list

#probability of positive test result for each paitient
nn2$net.result

#predicted probabilities for the first 10 instances
nn2$net.result[[1]][1:10]

#weights from input layer to hidden nodes, output nodes intercept etc.
nn2$weights

#weights for first interation
nn2$startweights

#training steps, errors, weights, etc.
nn2$result.matrix

#estimate probabilities for training data with compute()
mypredict<-compute(nn2, nn2$covariate)$net.result

#round probabilites to zero or one
mypredict<-apply(mypredict, c(1), round)

#display first 10 values for mypredict
mypredict[1:10]

#training set confusion matrix
cm<-table(mypredict, train.data$FSTAT, dnn =c("Predicted", "Actual"))
cm

#estimate probabilities for test data with compute()
testPred <- compute(nn2, test.data[, 0:7])$net.result

##round probabilites to zero or one
testPred<-apply(testPred, c(1), round)

#test set confusion matrix
cm2<-table(testPred, test.data$FSTAT, dnn =c("Predicted", "Actual"))
cm2

#classification accuracy
#accuracy = TN + TP / N + P
(cm[1]+cm[4])/sum(cm) #training set
(cm2[1]+cm2[4])/sum(cm2) #test set

#data viz
#network visualization for model 1
plot(nn)

#network visualization for model 2
plot(nn2)


#' @title Center and/or Z-Score Transform a Vector or Array
#' @description If both arguments center and scale are FALSE, function will throw an error to ensure user is aware of this potential mistake.
#' @param x a vector or 2D array of numeric or integer values
#' @param center logical if TRUE will center the resulting object
#' @param scale logical if TRUE data will be returned as z-score transform of x.
#' @export standardize
standardize <-  function (x, center = TRUE, scale = TRUE)
{
  if(!center & !scale) stop("'center' and 'scale' are FALSE. One or both must be TRUE, otherwise this function is unnecessary.")

  if (!is.numeric(x) & !is.integer(x))
    stop("'x' must be a numeric vector or array.", call. = FALSE)

  if (length(center) != 1 | !is.logical(center))
    stop("'center' must be logical or numeric of length 1.",
         call. = FALSE)

  if (length(scale) != 1 | !is.logical(scale))
    stop("'scale' must be logical or numeric of length 1.",
         call. = FALSE)

  if (center) {
    center <- mean(x, na.rm = TRUE)
    x <- x - center
  }

  if (scale) {
      scale <- sd(x, na.rm = TRUE)
      x <- x/scale
  }

    return(x)
}


library(foreach)
library(iterators) #if not installed
library(parallel) #if not installed
library(doMC)
library(modes)

## A set of convenience functions to simplify running multimode in batch

registerDoMC(4) #Change this to match the number of cores on your machine

library(multimode)

# Calling a single specific modality test to be applied on given data (with a particular significance level):
modesearch <- function(dataset,method="HH", p=0.05) {
workingData <- data.frame(dataset)
positive <- foreach(d=workingData,.combine=rbind) %dopar% {
r <- modetest(log2(d), method=method)
s <- if (r$p<p) { 1 } else { 0 }
s
}
result <- sum(positive)/ncol(dataset)
print(sprintf("%f (%d/%d)", result, sum(positive),ncol(dataset)))
return(result)
}

# Calling a single specific modality test to be applied on all data:
searchEverything <- function(method="HH",nmode=1) {
workingData <- data.frame(everything)
result <- foreach(d=names(workingData), .combine=rbind) %dopar% {
r <- modetest(log2(workingData[[d]]), method=method, mod0=nmode)
sprintf("%s with %s = %f", d, method, r$p)
}
result
}

# Calling a given set of modality tests to be applied on given data:
matrixSearch <- function(data,p=0,nmode=1) {
workingData <- data.frame(data)
result <- c()
if (nmode==1) {
methods <- c("HH","SI","CH","HY","FM","ACR")
} else {
methods <- c("SI","FM","ACR")
}
for (m in methods){
	print(m)
	positive <- foreach(d=workingData,.combine=rbind) %dopar% {
		r <- modetest(log2(d), method=m, mod0=nmode) # modality test is called
		s <- if (p) { if (r$p<p) { 1 } else { 0 } } else { r$p }
		#s <- data.frame(s)
		#rownames(s) <- methods
		}
result <- cbind(result,positive)
}
result <- data.frame(result)
colnames(result) <- methods
rownames(result) <- names(workingData)
result
}

# Calling the calculation of bimodality coefficient for given data:
bimCSearch <- function(data,threshold=0) {
workingData <- data.frame(data)
result <- foreach(d=workingData,.combine=rbind) %dopar% {
raw <- bimodality_coefficient(log2(na.exclude(d))) # bimodality coefficient is calculated
r <- if (threshold) {if (raw>threshold) { 1 } else { 0 } } else { raw }
}
rownames(result) <- names(workingData)
result
}


erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1

flashwear <- function(size, writecount, x, speed=6) {
  return(0.5*(1+erf(((x*(speed*1000*1000*1000/10)/(size*1000*1000*1000))-writecount)/sqrt(2*((writecount*0.1)**2)))))
}

xl <- c(0, 60000000)

svg('flash-integrity.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 100000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 100k Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 100000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 100000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 100000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()

svg('flash-integrity-100000.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 100000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 100k Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 100000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 100000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 100000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()

xl <- c(0, 640000000)

svg('flash-integrity-1000000.svg', height=6, width=12)
plot(function(x) { return(flashwear(32, 1000000, x)) }, col="green", xlab="", xaxt="n", ylab="", xlim=xl, ylim=c(0,1))
legend("topright", inset=.05, c("32 GB Drive", "64 GB Drive", "128 GB Drive", "256 GB Drive", "10% Threshold"), fill=c("green", "blue", "red", "purple", "black"))
axis(1,c(2628000,7884000,15770000,31540000,94610000,189200000,378400000,756900000), c("1 month", "3 months", "6 months", "1 year", "3 years", "6 years", "12 years", "24 years"))
title(main="Drive Wear After Continuous Writing to Flash Memory at 6Gb/s (w/ 8b/10b Coding)", sub="Average Lifespan of Flash Cell Approximated at 1M Writes", xlab="time elapsed", ylab="device wear")
par(new=TRUE)
plot(function(x) { return(flashwear(64, 1000000, x)) }, col="blue", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(128, 1000000, x)) }, col="red", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
plot(function(x) { return(flashwear(256, 1000000, x)) }, col="purple", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
par(new=TRUE)
abline(a=0.1, b=0, col="black", xlab="", xaxt="n", ylab="", yaxt="n", xlim=xl, ylim=c(0,1))
dev.off()


#
# HistogramCI.r
#
# This file contains functions for computing confidence intervals for a
# differentially private histogram and the threshold value for a stability
# histogram. It also contains a function that sums up the counts of the bins
# removed by the stability histogram algorithm.
#
# Author: Jessica Bu
# Summer 2015 REU - Harvard University
# 8/1/15
###

### Functions Available #########################################################
# Histogram.getCI(bins, data, eps, del, alpha, count)
# Histogram.getThreshold(eps, del)
# Histogram.stabilityBin(data, count)
###

### Dependencies ################################################################
library("VGAM")
library("foreign")
source("Histogramnew.R")
###

#################################################################################
# Function to compute confidence intervals for a differentially private histogram.
#
# Args:
#   -release - differentially private histogram
#	-params - privacy parameters (epsilon and delta) and paramaters of the data
#	(n - number of elements in data, binspec - if TRUE assumes that bins have
#	been decided by the user)
#	-alpha - statistical significance level
#
# Returns:
# 	List of upper and lower confidence limits for each bin in the histogram.
#################################################################################
Histogram.getCI <- function(release, params, alpha=0.05){

	n <- params$n
    binspec <- params$nlv
    eps <- params$eps
    del <- params$del

	acc <- Histogram.getAccuracy(binspec=binspec, n=n, eps=eps, del=del, beta=alpha)

	nonzero <- acc[1] # accuracy if the count is not zero
	zero <- acc[2] # accuracy if the count is zero

	output <- list()
	for(i in 1:length(release$release)){

		if (release$release[i] == 0){
			ub <- zero * n
			lb <- 0
		} else {
			ub <- nonzero * n + release$release[i]
			lb <- release$release[i] - nonzero * n
			if (lb < 0) { lb=0 }
		}

		output[[i]] <- c(lowerBound=lb, upperBound=ub)
	}
	return(output)
} # Histogram.getCI()

#################################################################################
# Function to get the threshold value for a stability histogram.
#
# Args:
#	-params - privacy parameters (epsilon and delta)
#
# Returns:
# 	Value of the threshold
#################################################################################
Histogram.getThreshold <- function(params) {
	eps <- params$eps
    del <- params$del

	thresh <- -2 / eps * log(2 * del) + 1
	return(thresh)
} # Histogram.getThreshold()

#################################################################################
# Function to get the sum of all of the counts that the stability histogram
# algorithm set  to zero because they were below the threshold value.
#
# Args:
#	-release - differentially private histogram
# 	-params - parameters of the data (length of dataset)
#
# Returns:
# 	The sum of all of the counts that were excluded from the stability histogram.
#################################################################################
Histogram.stabilityBin <- function(release, params) {
	excl <- params$n

	for(i in 1:length(release)) {
		excl = excl - release[i]
	}
	return(excl)
} # Histogram.stabilityBin()


set.seed(15797, kind="Mersenne-Twister")

maxgenerations = 10
cellcount = 20
offendvalue = FALSE

## Cells are alive if TRUE, dead if FALSE
universe <- c(offendvalue,
              sample( c(TRUE, FALSE), cellcount, replace=TRUE),
              offendvalue)

## List of patterns in which the cell stays alive
stayingAlive <- lapply(list(c(1,1,0),
                            c(1,0,1),
                            c(0,1,0)), as.logical)

## x : length 3 logical vector
## map: list of length 3 logical vectors that map to patterns
##      in which x stays alive
deadOrAlive <- function(x, map) list(x) %in% map

cellularAutomata <- function(x, map) {
    c(x[1], apply(embed(x, 3), 1, deadOrAlive, map=map), x[length(x)])
}

deadOrAlive2string <- function(x) {
    paste(ifelse(x, '#', '_'), collapse="")
}

for (i in 1:maxgenerations) {
    universe <- cellularAutomata(universe, stayingAlive)
    cat(format(i, width=3), deadOrAlive2string(universe), "\n")
}


l <- list(a=1, b="qwerty", c=list(d=TRUE, e=1:3))
sl <- as.set(l)
2^sl