# 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


#' Plot index input
#'
#' Rescale indices to mean 1 and stdev 1 then plot on regular and lognormal scale.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotIndexInput <- function(asap,save.plots,od,plotf,liz.palette){

  par(mfrow=c(2,1))
  years <- seq(asap$parms$styr,asap$parms$endyr)
  nyears <- length(years)
  indvals <- matrix(NA, nrow=nyears, ncol=asap$parms$nindices)
  for (i in 1:asap$parms$nindices){
    indvals[asap$index.year.counter[[i]],i] <- asap$index.obs[[i]]

  }
  # rescale to mean 1 and stdev 1
  rescaled <- indvals
  my.mean <- apply(indvals,2,mean, na.rm=T)
  my.std <- apply(indvals,2,sd, na.rm=T)
  for (i in 1:asap$parms$nindices){
    rescaled[,i] <- (indvals[,i] - my.mean[i]) / my.std[i]
  }
  my.range <- range(rescaled, na.rm=T)
  plot(years,rescaled[,1],xlab="Year",ylab="Rescaled Indices",ylim=my.range,col=liz.palette[1],type='n')
  for (i in 1:asap$parms$nindices){
    lines(years,rescaled[,i],col=liz.palette[i])
  }
  # now repeat on log scale
  log.indvals <- log(indvals)
  log.rescaled <- log.indvals
  my.log.mean <- apply(log.indvals,2,mean, na.rm=T)
  my.log.std <- apply(log.indvals,2,sd, na.rm=T)
  for (i in 1:asap$parms$nindices){
    log.rescaled[,i] <- (log.indvals[,i] - my.log.mean[i]) / my.log.std[i]
  }
  my.log.range <- range(log.rescaled, na.rm=T)
  plot(years,log.rescaled[,1],xlab="Year",ylab="Rescaled Log(Indices)",ylim=my.log.range,col=liz.palette[1],type='n')
  for (i in 1:asap$parms$nindices){
    lines(years,log.rescaled[,i],col=liz.palette[i])
  }
  if (save.plots) savePlot(paste0(od, "index.input.", plotf), type=plotf)
  par(mfrow=c(1,1))
  return()
}


### Summary Functions
# Contains functions for calculating various dendro fire indices based on defined samples of the simulation output

library(compiler)

# Calculate Grid Real Mean Fire Interval
f_RealMFI=function(x,z){
  fsz=dim(x)[1] * dim(x)[2]
  fc=apply(x,MARGIN=3,FUN=sum)
  fc=fc> (fsz * (z/100))
  bc=sum(fc)/length(fc)
  1/bc
}

f_RealMFI=cmpfun(f_RealMFI)

# With a fixed tree threshold
f_RealMFIf=function(x,z){
  fsz=dim(x)[1] * dim(x)[2]
  fc=apply(x,MARGIN=3,FUN=sum)
  fc=fc>=z
  bc=sum(fc)/length(fc)
  1/bc
}

f_RealMFIf=cmpfun(f_RealMFIf)

# Calculate Grid Real Rotation
f_RealNFR=function(x){
  cells=dim(x)[1] * dim(x)[2]
  years=dim(x)[3]
  smat=sum(x)
  NFR=(smat/(cells*years)) * 100
}

f_RealNFR=cmpfun(f_RealNFR)

# For a
f_tree_MFIhelper=function(x){
  dx=diff(x)
  mean(dx)
}

f_tree_MFIhelper=cmpfun(f_tree_MFIhelper)

#### DendroNFR Calculation
#### Have a frame with column for the present year, number of trees recording, number of scars

f_tree_NFR=function(inp_frame,this_fire){
  NFR_Frame=data.frame(year=seq(1:dim(this_fire)[3]),recording=0,scars=0)
  for(jdx in seq_along(NFR_Frame$year)){
    number_recording=length(subset(inp_frame,inp_frame$YBP<=jdx)$YBP)
    number_scars=length(subset(inp_frame,inp_frame$YBP==jdx)$YBP)
    NFR_Frame$recording[jdx]=number_recording
    NFR_Frame$scars[jdx]=number_scars
  }

  ## Filter years with <5% recording trees
  NFR_Frame=subset(NFR_Frame,NFR_Frame$recording>5)

  length_of_record=dim(NFR_Frame)[1]

  NFR_Frame$perc=(NFR_Frame$scars / NFR_Frame$recording)*100
  sperc=sum(NFR_Frame$perc)
  out_NFR=sperc/length_of_record
  out_NFR
}
f_tree_NFR=cmpfun(f_tree_NFR)

# Return a frame of trees with a given percentage of scarring per year
f_tree_percscar=function(inp_frame,tperc,this_fire){
  NFR_Frame=data.frame(year=seq(1:dim(this_fire)[3]),recording=0,scars=0)
  for(jdx in seq_along(NFR_Frame$year)){
    number_recording=length(subset(inp_frame,inp_frame$YBP<=jdx)$YBP)
    number_scars=length(subset(inp_frame,inp_frame$YBP==jdx)$YBP)
    NFR_Frame$recording[jdx]=number_recording
    NFR_Frame$scars[jdx]=number_scars
  }
  NFR_Frame=subset(NFR_Frame,NFR_Frame$recording>5)
  NFR_Frame$perc=(NFR_Frame$scars / NFR_Frame$recording)*100
  NFR_Frame=subset(NFR_Frame,NFR_Frame$perc > tperc)
  NFR_Frame
}

f_tree_percscar=cmpfun(f_tree_percscar)

# Return a frame of trees with a given percentage of scarring per year
f_tree_percscarf=function(inp_frame,tperc,this_fire){
  NFR_Frame=data.frame(year=seq(1:dim(this_fire)[3]),recording=0,scars=0)
  for(jdx in seq_along(NFR_Frame$year)){
    number_recording=length(subset(inp_frame,inp_frame$YBP<=jdx)$YBP)
    number_scars=length(subset(inp_frame,inp_frame$YBP==jdx)$YBP)
    NFR_Frame$recording[jdx]=number_recording
    NFR_Frame$scars[jdx]=number_scars
  }
  NFR_Frame=subset(NFR_Frame,NFR_Frame$recording>5)
  NFR_Frame=subset(NFR_Frame,NFR_Frame$scars >= tperc)
  NFR_Frame$perc=(NFR_Frame$scars / NFR_Frame$recording)*100
  NFR_Frame=subset(NFR_Frame,NFR_Frame$perc > 0)
  NFR_Frame
}

f_tree_percscarf=cmpfun(f_tree_percscarf)

### Time-series of fire years
# Return a frame of trees with a given percentage of scarring per year
f_tree_tsyear=function(inp_frame,this_fire){
  NFR_Frame=data.frame(year=seq(1:dim(this_fire)[3]),recording=0,scars=0)
  for(jdx in seq_along(NFR_Frame$year)){
    number_recording=length(subset(inp_frame,inp_frame$YBP<=jdx)$YBP)
    number_scars=length(subset(inp_frame,inp_frame$YBP==jdx)$YBP)
    NFR_Frame$recording[jdx]=number_recording
    NFR_Frame$scars[jdx]=number_scars
  }
  NFR_Frame$perc=NFR_Frame$scars / NFR_Frame$recording
  NFR_Frame
}

f_tree_tsyear=cmpfun(f_tree_tsyear)


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


#setwd('~/Msc/Sem 1/DBMS/DBMS-Codes')
source('closure.r')

#Candidate Key
keys <- function(attr,data,type = 'c'){
  all_keys <- c()
  noa <- nchar(attr)
  mkey <- attr
  for(i in 1:nrow(data)){
    mkey <- remove_char(data[i,'V2'],mkey) #In function.r
  }
  if(find_closure(mkey,data)$closure == attr){ #Find Closure of the calculated minimal key
    all_keys <- append(mkey,all_keys)
  }else{
    #print("check")
    i <- 1
    temp <- remove_char(mkey,attr)
    loop_condition <- TRUE
    while(loop_condition){
      pc = combn(strsplit(temp,'')[[1]],i)
      for(j in 1:ncol(pc)){
        permutation <- paste(pc[,j],collapse = '')
        key = paste(mkey,permutation,sep = '')
        if(find_closure(key,data)$closure == attr){
          all_keys <- append(key,all_keys)
          temp <- remove_char(permutation,temp)
        }
      }
      i <- i+1
      if(type == 'c'){
        if(length(all_keys) != 0)
            loop_condition <- FALSE
      }
      #check temp is equal to ==
      if(temp == ''){
        loop_condition <- FALSE
      }
      if(i > noa){
        loop_condition <- FALSE
      }
      if(i > nchar(temp)){
        loop_condition <- FALSE
      }
    }
  }
  if(type == 'c')
    all_keys <- all_keys[1]
  return(all_keys)
}


names = unlist(strsplit("baker cooper fletcher miller smith", " "))

test <- function(floors) {
  f <- function(name) which(name == floors)
  if ((f('baker') != 5) &&
      (f('cooper') != 1) &&
      (any(f('fletcher') == 2:4)) &&
      (f('miller') > f('cooper')) &&
      (abs(f('fletcher') - f('cooper')) > 1) &&
      (abs(f('smith') - f('fletcher')) > 1))
    cat("\nFrom bottom to top: --> ", floors, "\n")
}

do.perms <- function(seq, func, built = c()){
  if (0 == length(seq))  func(built)
  else  for (x in seq) do.perms( seq[!seq==x], func, c(x, built)) }


library(xts)
########################### functions
get.best.arima <- function(x.ts, maxord = c(1,1,1,1,1,1))
  {
  best.aic <- 1e8
  n <- length(x.ts)
  for (p in 0:maxord[1]) for(d in 0:maxord[2]) for(q in 0:maxord[3])
    for (P in 0:maxord[4]) for(D in 0:maxord[5]) for(Q in 0:maxord[6])
      {
      fit <- arima(x.ts, order = c(p,d,q),
                   seas = list(order = c(P,D,Q),
                               frequency(x.ts)), method = "CSS")
      fit.aic <- -2 * fit$loglik + (log(n) + 1) * length(fit$coef)
      if (fit.aic < best.aic)
        {

        best.aic <- fit.aic
        best.fit <- fit
        best.model <- c(p,d,q,P,D,Q)
        }
      }
  list(best.aic, best.fit, best.model)
  }

buildHarmonicModel = function(myts) {
  Time = time(myts)
  terms = c("Time","I(Time^2)","COS[,1]","SIN[,1]",
            "COS[,2]","SIN[,2]","COS[,3]","SIN[,3]",
            "COS[,4]","SIN[,4]","COS[,5]","SIN[,5]", "COS[,6]","SIN[,6]" )
  SIN = COS = matrix(nr = length(myts) , nc = 6)
  for (i in 1:6) {
    COS[,i] = cos(2*pi*i*Time)
    SIN[,i] = sin(2*pi*i*Time)
    }
  Tscal = Time
  mod.all = lm(myts ~ Time + I(Time^2)
               + COS[,1] + SIN[,1] + COS[,2] + SIN[,2]
               + COS[,3] + SIN[,3] + COS[,4] + SIN[,4]
               + COS[,5] + SIN[,5] + COS[,6] + SIN[,6] )
  tscore = coef(mod.all) / sqrt(diag(vcov(mod.all)))
  fmla <- as.formula(paste("myts ~ " , paste(terms[abs(tscore)>2] , collapse= "+")))
  mod = lm(fmla)
  mod.res.ar = ar(resid(mod) , method="mle")
  list(mod.res.ar,mod)
}

predictHarmonicModel = function(valts , boundle){
  mod = boundle[[2]]
  mod.res.ar = boundle[[1]]

  Time.val = time(valts)
  SIN = COS = matrix(nr = length(valts) , nc = 6)
  for (i in 1:6) {
    COS[,i] = cos(2*pi*i*Time.val)
    SIN[,i] = sin(2*pi*i*Time.val)
    }
  new.t.scal = Time.val
  res.ar = predict( mod.res.ar , n.ahead=length(valts) )
  pred = mod$coeff[1] + mod$coeff[2] * new.t.scal +
    mod$coeff[3] * I(new.t.scal^2) + mod$coeff[4] * SIN[, 1] +
    mod$coeff[5] * SIN[, 2] + mod$coeff[6] * SIN[, 3]
  pred.res.ar = as.vector(pred) + as.vector(res.ar$pred)
  list(pred,pred.res.ar)
}

buildLinearRegSeas = function(myts){
  Time = time(myts)
  Seas = cycle(myts)
  lm = lm(myts ~ Time )
  lmSeas = lm(myts ~ 0 + Time + factor(Seas) )
  list(lmSeas,lm)
}
predictLinearRegSeas = function(valts,regBoundle) {
  lm = regBoundle[[2]]
  lmSeas = regBoundle[[1]]

  new.t = as.vector(time(valts))

  pred.lm = lm$coeff[1] + lm$coeff[2] * new.t
  beta = c(rep(coef(lmSeas)[2:13] , floor (length(valts)/12) ) , coef(lmSeas)[2:((length(valts) %% 12)+1)] )
  pred.lmSeas = lmSeas$coeff[1]*new.t + beta

  list(pred.lmSeas,pred.lm)
}

compareModels = function(ts_train,ts_val,doPlot=T){
  ###### models
  mod.ar = ar(ts_train)
  mod.hw.mul = HoltWinters(ts_train , seasonal= "mul")
  mod.hw.add = HoltWinters(ts_train , seasonal= "add")
  regBoundle = buildLinearRegSeas(ts_train)
  mod.reg = regBoundle[[1]]
  mod.reg.2 = regBoundle[[2]]
#   harmonicBoundle = buildHarmonicModel(ts_train)
#   mod.reg.3 = harmonicBoundle[[2]]
#   mod.reg.3.res.ar = harmonicBoundle[[1]]
  mod.arima <- get.best.arima( ts_train, maxord = c(2,2,2,2,2,2))[[2]]
  mod.arima.log <- get.best.arima( log(ts_train), maxord = c(2,2,2,2,2,2))[[2]]

  models = c(mod.ar,mod.hw.mul,mod.hw.add,mod.reg,mod.reg.2,
#              mod.reg.3,mod.reg.3.res.ar,
             mod.arima,mod.arima.log)

  ###### predictions
  pred.ar = predict( mod.ar , n.ahead=length(ts_val) )
  pred.hw.mul = predict( mod.hw.mul , n.ahead=length(ts_val) )
  pred.hw.add = predict( mod.hw.add , n.ahead=length(ts_val) )
  predRegBoundle = predictLinearRegSeas(ts_val,regBoundle)
  pred.reg = predRegBoundle[[2]]
  pred.reg.2 = predRegBoundle[[1]]
#   predHarmonicBoundle = predictHarmonicModel (ts_val , harmonicBoundle)
#   pred.reg.3 = predHarmonicBoundle[[1]]
#   pred.reg.3.res.ar = predHarmonicBoundle[[2]]
  pred.arima <- predict(mod.arima, n.ahead = length(ts_val))$pred
  pred.arima.log <- exp(predict(mod.arima.log, n.ahead = length(ts_val))$pred)

  ####### performance
  perf.ar = cbind( type = c("AR") , getPerformance(as.vector(pred.ar$pred) , as.vector(ts_val)))
  perf.hw.mul = cbind( type = c("HW.mul") , getPerformance(as.vector(pred.hw.mul) , as.vector(ts_val)))
  perf.hw.add = cbind( type = c("HW.add") , getPerformance(as.vector(pred.hw.add) , as.vector(ts_val)))
  perf.reg = cbind( type = c("Reg") , getPerformance(as.vector(pred.reg) , as.vector(ts_val) ))
  perf.reg.2 = cbind( type = c("Reg.seas") , getPerformance(as.vector(pred.reg.2) , as.vector(ts_val) ))
#   perf.reg.3 = cbind( type = c("Reg.harm") , getPerformance(as.vector(pred.reg.3) , as.vector(ts_val) ))
#   perf.reg.3.res.ar = cbind( type = c("Reg.harm.res.ar") , getPerformance(as.vector(pred.reg.3.res.ar) , as.vector(ts_val) ))
  perf.arima = cbind( type = c("SARIMA") ,getPerformance(as.vector(pred.arima) , as.vector(ts_val) ) )
  perf.arima.log = cbind( type = c("SARIMA.log") ,getPerformance(as.vector(pred.arima.log) , as.vector(ts_val) ) )

  perf = rbind(
    perf.ar , perf.hw.mul, perf.hw.add, perf.reg, perf.reg.2,
#     perf.reg.3, perf.reg.3.res.ar,
    perf.arima, perf.arima.log
    )

  if (doPlot) {
    ts_all = ts( c(as.vector(ts_train),as.vector(ts_val)) , start=start(ts_train) , frequency=frequency(ts_train) )
    ts.plot(ts_all,
            pred.ar$pred ,
            pred.hw.mul ,
            pred.hw.add ,
            ts(pred.reg , start=start(ts_val) , frequency=frequency(ts_all)),
            col=1:5 , lty=1:5 )
    legend("topleft", c("TS", "AR" , "HW.mul" , "HW.add" , "Reg" ),
           lty=1:5, col=1:5)

    ts.plot(ts_all ,
            ts(pred.reg.2 , start=start(ts_val) , frequency=frequency(ts_all)) ,
            #ts(pred.reg.3 , start=start(ts_val) , frequency=frequency(ts_all)) ,
            #ts(pred.reg.3.res.ar , start=start(ts_val) , frequency=frequency(ts_all)) ,
            ts(pred.arima , start=start(ts_val) , frequency=frequency(ts_all)) ,
            ts(pred.arima.log , start=start(ts_val) , frequency=frequency(ts_all)) ,
            col=1:4 , lty=1:4 )
    legend("topleft", c("TS","Reg.seas" ,
#                         "Reg.harm" , "Reg.harm.seas.ar" ,
                        "SARIMA" , "SARIMA.log"),
           lty=1:4, col=1:4)
    }

  list(perf[order(perf$MAE) , ] , models[order(perf$MAE)])
}

getPerformance = function(pred , val) {
    res = pred - val
    MAE = sum(abs(res)) / length(val)
  	RSS = sum(res^2)
    #TSS = sum(  (val-mean(val) )^2   )
  	MSE = RSS / length(val)
  	RMSE = sqrt(MSE)
  	#R2 = 1 - ( RSS  /  TSS )

  	perf = data.frame(MAE,RSS,MSE,RMSE)
}

splitTrainXvat = function( tser , perc_train ) {
  ntrain = floor(length(as.vector(tser)) * perc_train)
  nval = length(as.vector(tser)) - ntrain

  ttrain = ts(as.vector(tser[1:ntrain]) , start = start(tser) , frequency=frequency(tser) )
  tval = ts(as.vector(tser[ntrain+1:nval]) , start=end(ttrain) + deltat(tser) , frequency=frequency(tser))

  stopifnot ( length(ttrain) == ntrain)
  stopifnot ( length(tval) == nval)

  list(ttrain , tval)
}
###############################

encodeSaleTrain = function(x) {
	mods = as.numeric(lapply(strsplit(as.character(x$module_category), "M"), function(x) as.numeric(x[2])))
	modMatrix = matrix(rep(0, dim(x)[1] * 9), nrow = dim(x)[1], ncol = 9)
	for (i in 1:length(mods)) {
		modMatrix[i, mods[i]] = 1
	}
	modDF = data.frame(modMatrix)
	colnames(modDF) = paste("M", 1:9, sep = "")

	comps = as.numeric(lapply(strsplit(as.character(x$component_category), "P"), function(x) as.numeric(x[2])))
	comMatrix = matrix(rep(0, dim(x)[1] * 31), nrow = dim(x)[1], ncol = 31)
	for (i in 1:length(comps)) {
		comMatrix[i, comps[i]] = 1
	}
	comDF = data.frame(comMatrix)
	colnames(comDF) = paste("P", 1:31, sep = "")

	ret = x[, -(1:2)]
	ret = data.frame(modDF, comDF, ret)
}

exploreRepTrain = function(x) {
	mods = as.numeric(lapply(strsplit(as.character(x$module_category), "M"), function(x) as.numeric(x[2])))
	comps = as.numeric(lapply(strsplit(as.character(x$component_category), "P"), function(x) as.numeric(x[2])))
	modComp = rep(0,length(comps))
	for (i in 1:length(comps)) {
		modComp[i] = as.numeric(paste(mods[i],comps[i],sep=''))
	}

	year_s = as.numeric(lapply(strsplit(as.character(x$year.month.sale), "/"), function(x) as.numeric(x[1])))
	month_s = as.numeric(lapply(strsplit(as.character(x$year.month.sale), "/"), function(x) as.numeric(x[2])))

	year_r = as.numeric(lapply(strsplit(as.character(x$year.month.repair), "/"), function(x) as.numeric(x[1])))
	month_r = as.numeric(lapply(strsplit(as.character(x$year.month.repair), "/"), function(x) as.numeric(x[2])))

	tt_s = as.yearmon(strptime(   paste(x$year.month.sale,'/15',sep='')  , format = '%Y/%m/%d') )
	tt_r = as.yearmon(strptime(   paste(x$year.month.repair,'/15',sep='')  , format = '%Y/%m/%d') )

	ts = ( as.yearmon(strptime(   paste(x$year.month.sale,'/15',sep='')  , format = '%Y/%m/%d') )  -
	      as.yearmon(strptime(   '2005/2/15'                       , format = '%Y/%m/%d') )
	    ) * 12

	tr = ( as.yearmon(strptime(   paste(x$year.month.repair,'/15',sep='')  , format = '%Y/%m/%d') )  -
	      as.yearmon(strptime(   '2005/2/15'                       , format = '%Y/%m/%d') )
	    ) * 12
    delta = tr-ts
	data = data.frame(x, modComp, year_s, month_s , year_r, month_r, tt_s , tt_r, ts , tr , delta)
}

repMeanAndSd = function(x) {

	data = exploreRepTrain(x)

	umodComp = unique(data$modComp)

	cum = matrix(  1:(length(umodComp)*3) , ncol=3 , nrow=length(umodComp) )
	rrow = 1
	for (mod in umodComp) {
		  cum[rrow , 1] = mod

		  deltas = data[data$modComp==mod , 14]
		  reps = data[data$modComp==mod , 5]
		  wdeltas = deltas * reps
		  mu = sum(wdeltas) / sum(reps)
		  sigma = ifelse( sum(reps) == 1   ,  0,   sqrt( sum((wdeltas-reps*mu)^2)/(sum(reps) -1) ))

		  cum[rrow , 2] = mu
		  cum[rrow , 3] = sigma

		  rrow = rrow + 1
	}

	ret = data.frame(cum)
	colnames(ret) = c('modComp','mu','sigma')
	ret
}

exploreSaleTrain = function(x) {
	mods = as.numeric(lapply(strsplit(as.character(x$module_category), "M"), function(x) as.numeric(x[2])))
	comps = as.numeric(lapply(strsplit(as.character(x$component_category), "P"), function(x) as.numeric(x[2])))
	modComp = rep(0,length(comps))
	for (i in 1:length(comps)) {
		modComp[i] = as.numeric(paste(mods[i],comps[i],sep=''))
	}

	year = as.numeric(lapply(strsplit(as.character(x$year.month), "/"), function(x) as.numeric(x[1])))
	month = as.numeric(lapply(strsplit(as.character(x$year.month), "/"), function(x) as.numeric(x[2])))

	tt = as.yearmon(strptime(   paste(x$year.month,'/15',sep='')  , format = '%Y/%m/%d') )

	t = ( as.yearmon(strptime(   paste(x$year.month,'/15',sep='')  , format = '%Y/%m/%d') )  -
	      as.yearmon(strptime(   '2005/1/15'                       , format = '%Y/%m/%d') )
	    ) * 12

	data = data.frame(x, modComp, year,month , tt , t)
}

makeCumSales = function(x) {

	data = exploreSaleTrain(x)

	umodComp = unique(data$modComp)
	cum = matrix(  1:(38*length(umodComp)*3) , ncol=3 , nrow=38*length(umodComp) )

      ####init
	rrow = 1
	for (mod in umodComp) {
		for (m in 0:37) {
		  cum[rrow , 1] = mod
		  cum[rrow , 2] = m
		  cum[rrow , 3] = 0
		  rrow = rrow + 1
		}
	}

	#### fill matrix
	rrow = 1
	for (mod in umodComp) {
		for (m in 0:37) {
		  cum[rrow , 1] = mod
		  cum[rrow , 2] = m
		  ## NB: consideriamo le vendite cumulate al netto dei ritiri (=sales_log < 0)
		  ##cum[rrow , 3] = ifelse(m>0,cum[ (rrow-1), 3] + sum(data[data$modComp == mod & data$t == m , 4  ]) , sum(data[data$modComp == mod & data$t == m , 4  ]) )
              cum[rrow , 3] = sum(data[data$modComp == mod & data$t <= (m+0.5) & data$t > (m-0.5) , 5  ])
		  rrow = rrow + 1
		}
	}

	ret = data.frame(cum)
	colnames(ret) = c('modComp','t','cum_sales')
	ret
}

makeCumRepairs = function(x) {

	data = exploreRepTrain(x)

	umodComp = unique(data$modComp)
	uperiods = unique(data$year.month.repair)
	cum = matrix(  1:(length(uperiods)*length(umodComp)*3) , ncol=3 , nrow=length(uperiods)*length(umodComp) )

	####init
	rrow = 1
	for (mod in umodComp) {
		for (m in 0:(length(uperiods)-1)) {
		  cum[rrow , 1] = mod
		  cum[rrow , 2] = m
		  cum[rrow , 3] = 0
		  rrow = rrow + 1
		}
	}

	#### fill matrix
	rrow = 1
	for (mod in umodComp) {
		for (m in 0:(length(uperiods)-1)) {
		  cum[rrow , 1] = mod
		  cum[rrow , 2] = m
		  cum[rrow , 3] = sum(data[data$modComp == mod & data$tr <= (m+0.5) & data$tr > (m-0.5) , 5  ])
		  rrow = rrow + 1
		}
	}

	ret = data.frame(cum)
	colnames(ret) = c('modComp','t','cum_repairs')
	ret
}

estimePr = function(er,cs){

	umodComp = unique(er$modComp)

	smax = max(cs$t)
	kmax = max(er$tr)

	dr = array(rep(0,(smax+1)*(kmax+1)*1000) , c(smax+1,kmax+1,1000)        )

	### es mod = 26

	for (mod in umodComp) {
		for (s in 1:smax){
			for (k in 1:kmax) {
				dr[s,k+1,mod] =
				sum( er[er$modComp == mod &
				er$tr <= (k+0.5) & er$tr > (k-0.5)  &
				er$delta <= ((k-s+1)+0.5) & er$tr > ((k-s+1)-0.5) ,5 ] ) /
				sum (cs[cs$modComp == mod & cs$t <= (s+0.5) & cs$t > (s-0.5) , 3] )
			}
		}
	}

	comp.number = length(umodComp)
	mdr = array(rep(0,(kmax+1)*1000) , c(kmax+1,1000) )
	for (mod in umodComp) {
		for (k in 1:kmax) {

		}
	}

}

treatOutTargetIdMap = function(x) {
	mods = as.numeric(lapply(strsplit(as.character(x$module_category), "M"), function(x) as.numeric(x[2])))
	comps = as.numeric(lapply(strsplit(as.character(x$component_category), "P"), function(x) as.numeric(x[2])))
	modComp = rep(0,length(comps))
	for (i in 1:length(comps)) {
		modComp[i] = as.numeric(paste(mods[i],comps[i],sep=''))
	}

	tt_r = as.yearmon(strptime(   paste(x$year,'/',x$month,'/15',sep='')  , format = '%Y/%m/%d') )

	tr = ( as.yearmon(strptime(   paste(x$year,'/',x$month,'/15',sep='')   , format = '%Y/%m/%d') )  -
	      as.yearmon(strptime(   '2005/1/15'                       , format = '%Y/%m/%d') )
	    ) * 12
      id = 1:(dim(x)[1])
	data = data.frame( id , x, modComp, tt_r, tr )
}

## load data set
repTrainFn = "dataset/pakdd-cup-2014/RepairTrain.zat"
saleTrainFn = "dataset/pakdd-cup-2014/SaleTrain.zat"
outTargetIdMapFn = "dataset/pakdd-cup-2014/Output_TargetID_Mapping.zat"
sampleSubFn = "dataset/pakdd-cup-2014/SampleSubmission.zat"

repTrain = read.csv(repTrainFn)
saleTrain = read.csv(saleTrainFn)
outTargetIdMap = read.csv(outTargetIdMapFn)
sampleSub = read.csv(sampleSubFn)

## exploration
es = exploreSaleTrain(saleTrain)
cs = makeCumSales(saleTrain)

er = exploreRepTrain(repTrain)
cr = makeCumRepairs(repTrain)

st = repMeanAndSd(repTrain)
plot(st$modComp,st$mu)
par(mfrow=c(2,1))
plot(st$modComp,st$mu)
plot(st$modComp,st$sigma)

outTargetIdMap  = treatOutTargetIdMap(outTargetIdMap)

write.csv(cr,quote=F,row.names=F,file="dataset/pakdd-cup-2014/cr.csv")
write.csv(cs,quote=F,row.names=F,file="dataset/pakdd-cup-2014/cs.csv")

##focus on mod = 224
er224 = er[er$modComp == 224,]
cr224 = cr[cr$modComp == 224,]
cs224 = cs[cs$modComp == 224,]
cr224.ts = ts(cr224$cum_repairs, start = c(2005, 2), freq = 12)
data = splitTrainXvat(cr224.ts, 0.7)
ts.train = data[[1]]
ts.val = data[[2]]
comparisons = compareModels(ts.train,ts.val,doPlot=T)
comparisons[1]

##focus on mod = 29
er29 = er[er$modComp == 29,]
cr29 = cr[cr$modComp == 29,]

cr29.ts = ts(cr29$cum_repairs, start = c(2005, 2), freq = 12)
cs29 = cs[cs$modComp == 29,]
cs29.ts = ts(cs29$cum_sales, start = c(2005, 1), freq = 12)
data = splitTrainXvat(cr29.ts, 0.7)
ts.train = data[[1]]
ts.val = data[[2]]
comparisons = compareModels(ts.train,ts.val,doPlot=T)
comparisons[1]


suppressPackageStartupMessages(library(float))

x = matrix(1:30, 10)
y = matrix(1:10, 10, 2)
z = matrix(1:5, 5, 3)

xs = fl(x)
ys = fl(y)
zs = fl(z)

cpxy = crossprod(x, y)
tcpxz = tcrossprod(x, z)

test = dbl(crossprod(xs))
stopifnot(all.equal(test, crossprod(x)))

test = dbl(crossprod(xs, ys))
stopifnot(all.equal(test, cpxy))

test = crossprod(x, ys)
stopifnot(all.equal(test, cpxy))

test = crossprod(xs, y)
stopifnot(all.equal(test, cpxy))

test = dbl(tcrossprod(xs))
stopifnot(all.equal(test, tcrossprod(x)))

test = dbl(tcrossprod(xs, zs))
stopifnot(all.equal(test, tcpxz))

test = tcrossprod(x, zs)
stopifnot(all.equal(test, tcpxz))

test = tcrossprod(xs, z)
stopifnot(all.equal(test, tcpxz))


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


#### EstEpiTOC.R

#### DESCRIPTION
#### An R-function to estimate the pcgtAge-score under the EpiTOC model.
#### Only required input argument is a data matrix of BMIQ (or other type-2 probe correction) normalised DNAm data.
#### Output is the pcgtAge-score for each column (sample) in the input data matrix.

#### INPUT:
#### data.m: DNAm data beta-valued matrix with rownames labeling CpGs and columns labeling samples for which a pcgtAge-score is desired
#### mode: this is an optional parameter, which can take on 2 values: "raw" or "z". If the former, function computes the pcgtAge-score
#### as the average methylation over the represented epiTOC loci. If this option is set to "z", then the score is computed as
#### an average of z-scores, reflecting a deviation relative to a specified reference set of samples (as specified by ref.idx)
#### ref.idx: this needs to be specified if mode="z". It is an index vector of column position of samples in data.m which should be treated as a reference.

#### OUPTUT:
#### score: a vector of pcgtAge-scores, one value for each sample of data.m

EstEpiTOC <- function(data.m,mode="raw",ref.idx=NULL){
    load("epiTOCcpgs.RData");
    common.v <- intersect(rownames(data.m),epiTOCcpgs.v);
    print(paste("Number of represented epiTOC CpGs=",length(common.v),sep=""));
    map.idx <- match(common.v,rownames(data.m));
    if(mode=="raw"){
      score.v <- colMeans(data.m[map.idx,]);
    }
    else if (mode=="z"){
      if(is.null(ref.idx)){
          print("You have selected mode=z, so please specify a reference index vector ref.idx!");
          stop;
          break;
       }
       else {
         sd.v <- apply(data.m[map.idx,ref.idx],1,sd);
         z.m <- (data.m[map.idx,] - rowMeans(data.m[map.idx,ref.idx]))/sd.v;
         score.v <- colMeans(z.m);
       }

     }

    return(score.v);
}


data = read.csv("C:\\Users\\liu.6544\\Documents\\GitHub\\CoronavirusTransit\\data\\actual_ridership\\actual_ridership_t_test.csv")
y = data$Official.ridership.decrease.from.transit.systems
x = data$Demand.decrease.from.Transit.app
t.test(y,x,paired=TRUE)


 ZTPQRT Example Program Results

 solution(s) for n rows
                    1                 2
 1  (-0.5091,-1.2428) ( 0.7569, 1.4384)
 2  (-2.3789, 2.8651) ( 5.1727,-3.6193)
 3  ( 1.4634,-2.2064) (-2.6613, 2.1339)
 4  ( 0.4701, 2.6964) (-2.6933, 0.2724)

 Least squares solution(s) for all rows
                    1                 2
 1  (-0.5044,-1.2179) ( 0.7629, 1.4529)
 2  (-2.4281, 2.8574) ( 5.1570,-3.6089)
 3  ( 1.4872,-2.1955) (-2.6518, 2.1203)
 4  ( 0.4537, 2.6904) (-2.7606, 0.3318)

 Square root(s) of the residual sum(s) of squares
        6.88E-02   1.87E-01


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


cumA <- percentage_percentage_freq(openA$Roslyn)
cumWhoDo <- percentage_percentage_freq(openWhoDo$Roslyn)

s = seq(0, 100, .25)
s
#2
pA = get_cumulative_at_df (cumA, s)
pWhoDo = get_cumulative_at_df (cumA, s)

plot(s, pA, type = 'l', col = 'black', pch = 22, lty = 1, lwd = 3)
lines(s, pWhoDo, type = 'l', col = 'blue', pch = 2,lty = 2, lwd = 3)

plot_percentage_freqency(openA$CoreFX)
plot_line_percentage_freqency(openA$Rust, lty = 2)

pdf("~/Downloads/WorkloadActual.pdf")
plot(seq(1:100), seq(1:100), type = 'l', lwd = 3, lty = 1, ylab = "Cumulative Percentage of Reviews", xlab = "Percentage of Reviewers")
plot_line_percentage_percentage(percentage_percentage_freq(openA$CoreFX), lty = 1)
plot_line_percentage_percentage(percentage_percentage_freq(openA$CoreCLR), lty = 2)
plot_line_percentage_percentage(percentage_percentage_freq(openA$Roslyn), lty = 3)
plot_line_percentage_percentage(percentage_percentage_freq(openA$Rust), lty = 4)
plot_line_percentage_percentage(percentage_percentage_freq(openA$Kubernetes), lty = 5)
abline(v = 20)
abline(h = 80)
abline(h = 20)
legend("bottomright", legend=c("CoreFX", "CoreCLR", "Roslyn", "Rust", "Kubernetes"), lty=c(1:5), lwd = 3, cex=1.2)
dev.off()

get_cumulative_at_df(percentage_percentage_freq(openA$CoreFX), 20);
get_cumulative_at_df(percentage_percentage_freq(openWhoDo$CoreFX), 20);
get_cumulative_at_df(percentage_percentage_freq(openRet$CoreFX), 20);


# Exercise 7: DPLYR practice with NBA data
install.packages("dplyr")
library(dplyr)

# Read in the NBA player data into a variable called `team.data` using `read.csv`
team.data <- read.csv("data/teams.csv")

# The data.frame team.data should now be accessible to you.
# View it, and get some basic information about the number of rows/columns.
# Note the "X" preceding some of the column titles as well as the "*"
# following the names of teams that made it to the playoffs that year.
View(team.data)

# Add a column that gives the turnovers to steals ratio (TOV / STL) for each team
team.data <- mutate(team.data, Ratio = TOV / STL)

# Sort the teams from lowest turnover/steal ratio to highest
# Which team has the lowest ratio?
team.data <- arrange(team.data, Ratio)
Boston Celtics

# Using the pipe operator, create a new column of assists per game (AST / G) AND
# sort the data.frame by this new column in DESCENDING order.
team.data <- mutate(team.data, ASTGM = AST / G) %>% arrange(-ASTGM)

# Create a data.frame called `good.offense` of teams that scored more than 8700 points (PTS)
good.offense <- filter(team.data, PTS > 8700)

# Create a data.frame called `good.defense` of teams that had more than 470 blocks (BLK)
good.defense <- filter(team.data, BLK > 470)

# Create a data.frame called `defense.stats` that only shows defensive rebounds (DRB), steals (STL),
# and blocks (BLK) along with the team name.
defense.stats <- select(team.data, Team, DRB, STL, BLK)

# Create a data.frame called `offense.stats` that only shows offensive rebounds (ORB),
# field-goal % (FG.), and assists (AST) along with the team name.
offense.stats <- select(team.data, Team, ORB, FG., AST)

### Bonus ###
# Create a function called `BetterShooters` that takes in two teams and returns
# a data.frame of the team with the better field-goal percentage. The returned
# data.frame should include the team name, field-goal percentage, and points.
BetterShooters <- function(team1, team2) {
  better.team <- filter(team.data, Team %in% c(team1, team2)) %>%
                filter(FG. == max(FG.)) %>%
                select(Team, FG., PTS)

  return (better.team)
}

better.shooter <- BetterShooters("Golden State Warriors*", "Cleveland Cavaliers*")


=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


ExtractCovariatesFromText <- function(covariates_text) {

  covariates <- sapply(strsplit(covariates_text, split = ",")[[1]], function(x){
    if(grepl("-",x)){
      as.numeric(seq(strsplit(x, split = "-")[[1]][1], strsplit(x, split = "-")[[1]][2]))
    } else {
      as.numeric(x)
    }
  })
  covariates <- as.vector(unlist(covariates))
  if(covariates[1] == 0) covariates <- c()

  covariates
}

# true or false if the covariates is categorical or numerical
ExtractClassCovariates <- function(ncov, fac_covariates, column_covariate){
  classCovariates <- rep(T, ncov)
  classCovariates[match(fac_covariates, column_covariate)] <- F

  classCovariates
}

Extract_IndexesCovariates <- function(X, column_covariate, ncov, classCovariates) {

  indexes_covariates <- c()
  indexes_covariates[1] <- 1
  if(any(column_covariate != 0)){

    indexes_covariates <- c()
    indexes_covariates[1] <- 1
    k <- 2
    for (i in 1:ncov) {
      if(classCovariates[i]){
        indexes_covariates[k] <- i + 1
        k <- k + 1
      } else {
        num_levels <- length(unique(X[,i]))
        indexes_covariates[k + 0:(num_levels-2)] <- i + 1
        k <- k + num_levels - 1
      }
    }

  }

  indexes_covariates
}

logit <- function(x){
  1 / (1 + exp(-x))
}

invLogit <- function(x){
  log(x / (1 - x))
}


library(pheatmap)
library(RColorBrewer)
library(stringr)

compute.lims <- function(mat) {
  maxmat <- mat
  maxmat[is.na(maxmat)] <- -Inf
  maxval <- max(maxmat)

  minmat <- mat
  minmat[is.na(minmat)] <- Inf
  minval <- min(minmat)

  nsteps <- 21.0

  breaklim <- round(abs(max(abs(c(minval, maxval)))), digits=2)

  # Compute a reasonable amount of steps?
  stepsize <- 2*breaklim / nsteps

  breakslist <- seq(-breaklim, +breaklim, by=stepsize)
}

summarized.heatmap <- function(values, filename, title, breakslist, clean.names=T, log=T) {
  bcolor <- "white"

  breakslist <- compute.lims(values)
  palette <- colorRampPalette(brewer.pal(n = 7, name = "Reds"))(length(breakslist))
  if (log == TRUE) {
    palette <- colorRampPalette(rev(brewer.pal(n = 7, name = "RdBu")))(length(breakslist))
  }

  cellsize <- 35

  rowlabels <- rownames(values)
  collabels <- colnames(values)

  if (clean.names == TRUE) {
    rowlabels <- sapply(rowlabels, str_replace_all, '[._]', ' ')
    collabels <- sapply(collabels, str_replace_all, '[._]', ' ')
  }

  pheatmap(values,
           filename=filename,
           main=title, cluster_rows=F, cluster_cols=F,
           cellwidth=cellsize, cellheight=cellsize,
           border_color=bcolor, breaks=breakslist,
           labels_row=rowlabels, labels_col=collabels,
           color=palette,
           display_numbers=T)
}


library(igraph)
library(ggplot2)

#library(network)

g = graph.data.frame(d = Cit.HepPh.WithDates.WellCited[,c(1,3)], directed = T)

dg_in = degree(g,mode="in")
percent_in = degree.distribution(graph=g,mode="in")

nodes<-function(degree){
  attributes(dg_in[dg_in > degree])$names
}
wellcited<-nodes(6)
length(dg_in)
length(wellcited)

graphD<-Cit.HepPh.WithDates.WellCited[Cit.HepPh.WithDates.WellCited$V3==wellcited[1],c(1,3)]
graphD<-rbind(graphD,Cit.HepPh.WithDates.WellCited[Cit.HepPh.WithDates.WellCited$V3==wellcited[2],c(1,3)])
gg <- graph.data.frame(d = graphD, directed = T)
is.simple(gg)
plot(gg, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)
#do by year of edges
year<-1993
pattern <- paste(year,'-*-*', sep = "")
group <- grep(pattern, Cit.HepPh.WithDates.WellCited[,2],
              ignore.case = FALSE, perl = FALSE, value = FALSE,
              fixed = FALSE, useBytes = FALSE, invert = FALSE)
graphDY<-Cit.HepPh.WithDates.WellCited[group,c(1,3)]
#graphDY<-rbind(graphD,Cit.HepPh.WithDates.WellCited[Cit.HepPh.WithDates.WellCited$V3==wellcited[1],c(1,3)])
gg <- graph.data.frame(d = graphDY, directed = T)
is.simple(gg)
gg <- simplify(gg)
par(mar = c(0, 0, 0, 0))
set.seed(23)
# plot(gg, layout = layout.fruchterman.reingold,
#      vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
#      edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)

is.connected(gg, mode=c("weak"))
gc<-clusters(gg, mode=c("weak"))
V(gg)$sg = gc$membership
V(gg)$color = rainbow(max(V(gg)$sg))[V(gg)$sg]
plot(gg, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)

comps <- decompose.graph(gg,max.comps=1,min.vertices=max(gc$csize))
g<-comps[[1]]
plot(g, layout = layout.fruchterman.reingold,
     vertex.size = 3,vertex.label.cex=0.5, vertex.label=NA,
     edge.color = grey(0.5), edge.arrow.mode = "->",edge.arrow.size=0.2)


generator.Bernoulli <- function(p) {
  return (function(n){
    return (rbinom(n, 1, p))
  })
}

generator.njoin <- function(first, second, n){
  generated <- 0
  generator.single <- function(){
    generated <<- generated + 1
    return (ifelse(generated <= n, first(1), second(1)))
  }

  return (function(t){
    return (replicate(t, generator.single()))
  })
}

generator.sequence <- function(theta, gamma, T){
  return (generator.njoin(
    generator.Bernoulli(theta),
    generator.Bernoulli(gamma),
    2**T))
}


distances.calculate <- function(otus.normalized, otus.tree, distance.type = "unifrac"){

  distance <- NULL
  if (distance.type == "unifrac"){
    unifracs <- GUniFrac(otus.normalized, midpoint(otus.tree), alpha = c(0.0, 0.5, 1.0))$unifracs
    distance <- as.dist(unifracs[, , "d_0.5"])
  }
  else if (distance.type == "euclidian") {
    distance <- dist(otus.normalized,  method = 'euclidian', upper = T)
  }
  else if (distance.type == "manhattan") {
    distance <- dist(otus.normalized,  method = 'manhattan', upper = T)
  }

  if (is.null(distance) || is.na(distance)) {
    stop("time.series.calculate.distances() function called with invalid distance type")
    return(NA)
  }

  return(distance)
}


library(crayon)

fname       <- read.csv(file="../../Precipitable-Water-Model/data/master_data.csv", sep=",")

## Filters out data with overcast condition
overcast_filter <- function(){
# Initializes the lists to store values
	date_clear	<- overcast1 	<- overcast2 	<- overcast3 	<- list()
	overcast4 	<- overcast5 	<- overcast6 	<- overcast7 	<- list()
	overcast8 	<- overcast9 	<- overcast10 	<- list()

	date_over 	<- overcast1o 	<- overcast2o 	<- overcast3o	<- list()
	overcast4o 	<- overcast5o 	<- overcast6o	<- overcast7o	<- list()
	overcast8o	<- overcast9o 	<- overcast10o	<- list()

# Divides the data based on condition (Overcast/Clear Skies)
	for (j in 1:length(t(fname[12]))){
		if (!"overcast" %in% fname[j,12]){
			date_clear  <- append(date_clear, as.Date(fname[j, 1], "%m/%d/%Y"))

			overcast1 	<- append(overcast1, fname[j, 7])
			overcast2 	<- append(overcast2, fname[j, 8])
			overcast3 	<- append(overcast3, fname[j, 9])
			overcast4 	<- append(overcast4, fname[j, 10])
			overcast5 	<- append(overcast5, fname[j, 11])
			overcast6   <- append(overcast6, fname[j, 2])
			overcast7   <- append(overcast7, fname[j, 3])
			overcast8   <- append(overcast8, fname[j, 4])
			overcast9   <- append(overcast9, fname[j, 5])
			overcast10  <- append(overcast10, fname[j, 6])
		}
		else{
			date_over   <- append(date_over, as.Date(fname[j, 1], "%m/%d/%Y"))

			overcast1o 	<- append(overcast1o, fname[j, 7])
			overcast2o 	<- append(overcast2o, fname[j, 8])
			overcast3o 	<- append(overcast3o, fname[j, 9])
			overcast4o 	<- append(overcast4o, fname[j, 10])
			overcast5o 	<- append(overcast5o, fname[j, 11])
			overcast6o 	<- append(overcast6o, fname[j, 2])
			overcast7o 	<- append(overcast7o, fname[j, 3])
			overcast8o 	<- append(overcast8o, fname[j, 4])
			overcast9o 	<- append(overcast9o, fname[j, 5])
			overcast10o <- append(overcast10o, fname[j, 6])
		}
	}
	output <- list("y1"=overcast1,"y2"=overcast2, "y3"=overcast3,"y4"=overcast4,
					"y5"=overcast5, "y6"=overcast6,"y7"=overcast7, "y8"=overcast8,
					"y9"=overcast9, "y10"=overcast10,
					"y1o"=overcast1o, "y2o"=overcast2o, "y3o"=overcast3o,
					"y4o"=overcast3o, "y5o"=overcast5o,
					"y6o"=overcast6o, "y7o"=overcast7o, "y8o"=overcast8o,
					"y9o"=overcast9o, "y10o"=overcast10o,"y0"=date_clear, "y0o"=date_over)
	return (output)
}
## Pushes returned values to the variable overcast
overcast <- overcast_filter()

pw_abq12    <- as.numeric(array(t(overcast$y2)))    	# PW for ABQ @ 12Z
pw_abq00	<- as.numeric(array(t(overcast$y3)))    	# PW for ABQ @ 00Z
pw_epz12    <- as.numeric(array(t(overcast$y4)))    	# PW for EPZ @ 12Z
pw_epz00    <- as.numeric(array(t(overcast$y5)))    	# PW for EPZ @ 00Z

atemp_am    <- as.numeric(array(t(overcast$y1)))    	# Air Temperature from AMES

abq 	<- (as.numeric(pw_abq12) + as.numeric(pw_abq00))/2 # ABQ average
epz 	<- (as.numeric(pw_epz12) + as.numeric(pw_epz00))/2 # EPZ average
avg 	<- (abq + epz)/2 								# Super Average

x <- atemp_am
y <- log(avg, base=exp(1))

xmin <- min(x, na.rm=TRUE)
xmax <- max(x, na.rm=TRUE)
ymax <- max(y, na.rm=TRUE)
ymin <- min(y, na.rm=TRUE)
newx 	<- seq(xmin, xmax, length.out=length(x))

model.0 <- lm(y~x, data=data.frame(x,y))
start 	<- list(a=coef(model.0)[1], b=coef(model.0)[2])
model 	<- nls(y~a+b*x, data=data.frame(x=x, y=y), start=start)

confint <- predict(model.0, newdata=data.frame(x=newx), interval='confidence')
predint <- predict(model.0, newdata=data.frame(x=newx), interval='prediction')

summary(model)

x11(type="cairo")
plot(x,y, col=c("blueviolet"), pch=16, xlim=c(xmin,xmax),
    ylim=c(ymin, ymax))

curve(coef(model)[1]+coef(model)[2]*x, col="Red", add=TRUE)
# Confidence Interval
	lines(newx, confint[ ,3], col="blue", lty="dashed")
	lines(newx, confint[ ,2], col="blue", lty="dashed")
# Prediction Interval
	lines(newx, predint[ ,3], col="magenta", lty="dashed")
	lines(newx, predint[ ,2], col="magenta", lty="dashed")

cat(bold(yellow("Slam Enter to Continue:\n>> "))); w <- readLines(con="stdin", 1)

x11(type="cairo")
plot(x,exp(y), col=c("blueviolet"), pch=16, xlim=c(xmin,xmax),
    ylim=c(exp(ymin), exp(ymax)))

curve(exp(coef(model)[1]+coef(model)[2]*x), col="Red", add=TRUE)
# Confidence Interval
	lines(newx, exp(confint[ ,3]), col="blue", lty="dashed")
	lines(newx, exp(confint[ ,2]), col="blue", lty="dashed")
# Prediction Interval
	lines(newx, exp(predint[ ,3]), col="magenta", lty="dashed")
	lines(newx, exp(predint[ ,2]), col="magenta", lty="dashed")

cat(bold(yellow("Slam Enter to Continue:\n>> "))); w <- readLines(con="stdin", 1)


#getwd()
library(dplyr)

par(mfrow = c(1, 1))

# Načtení dat z xlsx souboru
data_xlsx = readxl::read_excel("./1S/ukol_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data_xlsx = data_xlsx[,-1] # odstraníme první sloupec s indexy
colnames(data_xlsx)=c("A22","A5","B22","B5","C22","C5","D22","D5")
head(data_xlsx)

svetTok = 0.8 * 1000
data_xlsx$A_min = data_xlsx$A5 >= svetTok
data_xlsx$B_min = data_xlsx$B5 >= svetTok
data_xlsx$C_min = data_xlsx$C5 >= svetTok
data_xlsx$D_min = data_xlsx$D5 >= svetTok

data=reshape(data=as.data.frame(data_xlsx),
                  direction="long",
                  varying=list(c("A5", "B5", "C5", "D5"),
                               c("A22","B22","C22","D22"),
                               c("A_min","B_min","C_min","D_min")),
                  v.names=c("C5","C22","min"),
                  times=c("Amber","Bright","Clear","Dim"),
                  timevar="vyrobce")
row.names(data) = 1:nrow(data)
data = data[-length(data)]
data = na.omit(data)

head(data)
tail(data)

# A) kontingenční tabulka a mozaikový graf
data.tab.abs = table(data$vyrobce, data$min)

colnames(data.tab.abs) = c("pod 80 %","nad 80 %")
data.tab.abs

# Explorační analýza
# prop.table(data.tab.abs)    # sdružené relativní četnosti
data.tab.rel = prop.table(data.tab.abs,1)  # řádkové relativní četnosti
# prop.table(data.tab.abs,2)  # sloupcové relativní četnosti

data.tab.celkem = data %>% group_by(vyrobce) %>% summarise( pocet_abs=sum(!is.na(min)))
data.tab.celkem$pocet_rel = prop.table(data.tab.celkem$pocet_abs)

abs.sum.ano = sum(as.numeric(data.tab.abs[,1]))
abs.sum.ne = sum(as.numeric(data.tab.abs[,2]))
rel.sum.ano = sum(as.numeric(prop.table(data.tab.abs)[,1]))
rel.sum.ne = sum(as.numeric(prop.table(data.tab.abs)[,2]))

data.tab = data.frame(  nad_abs = as.numeric(data.tab.abs[,2]), nad_rel = as.numeric(data.tab.rel[,2]), nad_rel_r = paste0(round(as.numeric(data.tab.rel[,2])*100,2),' %'),
                        pod_abs = as.numeric(data.tab.abs[,1]), pod_rel = as.numeric(data.tab.rel[,1]), pod_rel_r = paste0(round(as.numeric(data.tab.rel[,1])*100,2),' %'),
                        celkem_abs = data.tab.celkem$pocet_abs, celkem_rel = data.tab.celkem$pocet_rel, celkem_rel_r = paste0(round(data.tab.celkem$pocet_rel*100,2),' %'))
rownames(data.tab) = rownames(data.tab.rel)

data.tab.presentation = data.tab
data.tab.presentation[nrow(data.tab)+1,] = c(
                            abs.sum.ne, rel.sum.ne, paste0(round((rel.sum.ne)*100,2),' %'),
                            abs.sum.ano, rel.sum.ano, paste0(round((rel.sum.ano)*100,2),' %'),
                            abs.sum.ano + abs.sum.ne, rel.sum.ano + rel.sum.ne, paste0(round((rel.sum.ano + rel.sum.ne)*100,2),' %'))
rownames(data.tab.presentation) = c(rownames(data.tab),'Celkem')
data.tab.presentation[,c(1,3,4,6,7,9)]
# paste0 osekává nuly, pozor

mosaicplot(data.tab.abs,
           las = 1,
           color = gray.colors(2),
           main = "Světelnost po 30 s při 5°C")

# crammerovo V závislost TODO
# install.packages("lsr")
round(lsr::cramersV(data.tab.rel),3)
# slabá závislost

# B) Bodový a intervalový odhad
# předpoklad pro cloper-pearsnův
bri_ind = match("Bright",rownames(data.tab))
predpoklad = round(9/(as.numeric(data.tab$pod_rel)[bri_ind]*(1-as.numeric(data.tab$pod_rel)[bri_ind])),2)

paste0('$9/(',round(as.numeric(data.tab$pod_rel)[bri_ind],4),'*',round(1-as.numeric(data.tab$pod_rel)[bri_ind],4),')$')

if(predpoklad < as.numeric(data.tab$celkem_abs)[bri_ind]){
    paste0('předpoklad pro cloper-pearsnuv test je splněn s hodnotou ', predpoklad,' < ',as.numeric(data.tab$celkem_abs)[bri_ind])
}else{
    paste0('předpoklad pro cloper-pearsnuv test neni splněn s hodnotou ', predpoklad,' > ',as.numeric(data.tab$celkem_abs)[bri_ind])
}

int.odhad = binom.test(data.tab$pod_abs[bri_ind], n=data.tab$celkem_abs[bri_ind])$conf.int
paste0('bodový odhad: ',data.tab$pod_abs[bri_ind], ' intervalový odhad: (',floor(int.odhad[1]*10000)/100,';',ceiling(int.odhad[2]*10000)/100,'), pomocí binom.test')
# TODO, který test?
int.odhad2 = prop.test(data.tab$pod_abs[bri_ind], n=data.tab$celkem_abs[bri_ind])$conf.int
paste0('bodový odhad: ',data.tab$pod_abs[bri_ind], ' intervalový odhad: (',floor(int.odhad2[1]*10000)/100,';',ceiling(int.odhad2[2]*10000)/100,'), pomocí prop.test')

# C) relativní bodový a intervalový odhad mezi nejlepším a nejhorším
nejlepsi_ind = match(min(data.tab$pod_rel),data.tab$pod_rel)
nejhorsi_ind = match(max(data.tab$pod_rel),data.tab$pod_rel)

# install.packages("epiR")
pom = epiR::epi.2by2(data.tab.abs[c(nejhorsi_ind,nejlepsi_ind),])

paste0('nejlepsi vyrobce: ', rownames(data.tab)[nejlepsi_ind],', nejhorsi vyrobce: ',
    rownames(data.tab)[nejhorsi_ind],', ', round(pom$massoc$RR.strata.wald[1],2) , 'x lepsi') #max(data.tab$pod_rel)/min(data.tab$pod_rel)
paste0('intervalový odhad (',floor(pom$massoc$RR.strata.wald[2]*100)/100,';',ceiling(pom$massoc$RR.strata.wald[3]*100)/100,')')

# D) poměr šancí, bodový a intervalový odhad
nejlepsi_sance = data.tab$pod_abs[nejlepsi_ind]/data.tab$nad_abs[nejlepsi_ind]*1000
nejhorsi_sance = data.tab$pod_abs[nejhorsi_ind]/data.tab$nad_abs[nejhorsi_ind]*1000
paste0('šance, že nejlepší nedosáhne 80 % je ',round(nejlepsi_sance),':1000')
paste0('šance, že nejhorší nedosáhne 80 % je ',round(nejhorsi_sance),':1000')
sance = pom$massoc$OR.strata.wald
paste0('šance na nedosahnutí světelnosti je ',round(sance[1],2),'x vyšší') #nejhorsi_sance/nejlepsi_sance
paste0('95% intervalový odhad je (',floor(sance[2]*100)/100,';',ceiling(sance[3]*100)/100,')')

# E) chikvadrát
# předpoklad
pom = chisq.test(data.tab.abs)
min(as.numeric(pom$expected)>5) == 1
# všechny četnosti jsou větší než 5, splněno
round(pom$p.value,3) # < 0,05, zamítáme H_0 ->
# existuje statisticky významná závislost mezi výrobcem a ...