# install.packages(c("lubridate", "dplyr", "tidyverse", "reshape2", "corrplot", "ggplot2", "ggpmisc", "sf", "rnaturalearth", "fastICA", "FactoMineR", "factoextra"))

library(lubridate)
library(dplyr)
library(tidyverse)
library(reshape2)
library(corrplot)
library(ggplot2)
library(ggpmisc)
library(sf)
library(rnaturalearth)
library(fastICA)
library(FactoMineR)
library(factoextra)

set.seed(360)

theme_plot = theme(title = element_text(),
                  plot.title = element_text(margin = margin(20,20,20,20), size = 18, hjust = 0.5))

if(dir.exists("graphics")){
  unlink("graphics", recursive=TRUE)
}
dir.create("graphics")

id_sondes_list = c(825, 827, 828, 830)

# load sonde coordinates
coordinates_df = as.data.frame(read.csv(file="sensors_coordinates.csv", header=TRUE, sep=",", dec=".", na.strings=NA))
coordinates_df = coordinates_df[coordinates_df$TopoOH == "La Touques", c("id_sonde", "lib_sonde", "lat_wgs84", "lon_wgs84")]
coordinates_df$color = rep("black", nrow(coordinates_df))
coordinates_df$color[coordinates_df$id_sonde %in% id_sondes_list] = "red"

# load map and center of the zoomed map
worldmap <- ne_countries(scale = 'medium', type = 'map_units',
                         returnclass = 'sf')
france = worldmap[worldmap$name == 'France',]
df_caen_coord = data.frame(lon = -0.370679, lat = 49.182863)

zoom_level = 7
lon_span = 360 / 2^zoom_level
lat_span = 180 / 2^zoom_level
lon_bounds <- c(df_caen_coord$lon - lon_span / 2, df_caen_coord$lon + lon_span / 2)
lat_bounds <- c(df_caen_coord$lat - lat_span / 2, df_caen_coord$lat + lat_span / 2)

attach(coordinates_df)
png("graphics/map.png")
ggplot() +
    geom_sf(data = france) +
    geom_point(aes(data = df_caen_coord, x = df_caen_coord$lon, y = df_caen_coord$lat, label = "Caen"), color = "blue", size = 5) +
    geom_text(aes(data = df_caen_coord, x = df_caen_coord$lon, y = df_caen_coord$lat, label = "Caen"), hjust = -0.5, vjust = 0.25) +
    geom_point(data = coordinates_df, aes(x = lon_wgs84, y = lat_wgs84, label = id_sonde), color = color) +
    geom_text(aes(x = lon_wgs84, y = lat_wgs84, label = id_sonde), hjust = -0.5, vjust = 0.25) +
    coord_sf(xlim = lon_bounds, ylim = lat_bounds) +
    theme_bw() +
    labs(x = "Longitude",
        y = "Latitude",
        title = "Sondes de la Touques") +
    theme_plot
dev.off()
detach(coordinates_df)

df = as.data.frame(read.csv(file="base.csv", header=TRUE, sep=";", dec=",", row.names=1, na.strings=NA))

df$date = ymd(df$date)
df$t = ymd_hms(df$t)
df$id_sonde = as.factor(df$id_sonde)

custom_summary = function(df) {
    quantitative_summary = function(column, epsilon=1e-20) {
        col_min = min(column)
        col_max = max(column)
        col_first_quantile = quantile(column, 0.25)
        col_median = median(column)
        col_third_quantile = quantile(column, 0.75)
        col_mean = mean(column)
        col_geometric_mean = exp(mean(log(column - col_min + epsilon))) + col_min - epsilon
        col_etendue = max(column) - min (column)
        col_iqr = col_third_quantile - col_first_quantile
        col_var = var(column)
        col_sd = sd(column)
        col_coeff_vaiation = col_sd / col_mean

        mat = matrix(c(col_min, col_max, col_first_quantile, col_median, col_third_quantile, col_mean, col_geometric_mean, col_etendue, col_iqr, col_var, col_sd, col_coeff_vaiation), byrow=TRUE, nrow=1)
        colnames(mat) = c("Min", "Max", "1st quantile", "Median", "3rd quantile", "Mean", "Geometric mean", "Value range", "IQR", "Variance", "Standard deviation", "Variation coefficient")
        return(mat)
    }

    qualitative_summary = function(column) {
        return(summary(column))
    }

    datetime_summary = function(column) {
        return(list(Min = min(column), Max = max(column)))
    }

    date_summary = function(column) {
        return(list(Min = min(column), Max = max(column)))
    }

    l = list()
    for(n in names(df)) {
        if(class(df[[n]]) == "Date") {
            l[[n]] = date_summary(df[[n]])
        } else if(class(df[[n]]) == "POSIXct" || class(df[[n]]) == "POSIXt") {
            l[[n]] = datetime_summary(df[[n]])
        } else if(class(df[[n]]) == "factor") {
            l[[n]] = qualitative_summary(df[[n]])
        } else if(class(df[[n]]) == "numeric") {
            l[[n]] = quantitative_summary(df[[n]])
        } else {
            l[[n]] = summary(df[[n]])
        }
    }
    return(l)
}

concatenated_summary = custom_summary(df)
concatenated_summary

df$year = year(df$date)
df$month = month(df$date)
df$day = day(df$date)
df$hour = hour(df$t)

sub_df = df[df$id_sonde %in% id_sondes_list,][,c("Teau", "Tair.EOBS", "Rainf.EOBS", "year", "month", "day", "hour", "id_sonde")]

cor_matrix = cor(df[,c("year", "month", "day", "hour", "Tair.EOBS", "Teau", "Rainf.EOBS")])
png("graphics/corr_variables.png")
color = colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
corrplot(cor_matrix, method = "color", diag = FALSE, type = "upper",
         col = color(200), order = "hclust", title = "Corrélations entre variables",
         addCoef.col = "black", sig.level = 0.05, insig = "blank", mar = c(0,0,1,0)) +
  theme_plot
dev.off()

new_df = df[df$year %in% 2014:2017,]
cor_matrix_new_df = cor(new_df[,c("year", "month", "day", "hour", "Tair.EOBS", "Teau", "Rainf.EOBS")])
png("graphics/corr_variables_fixed.png")
color = colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
corrplot(cor_matrix_new_df, method = "color", diag = FALSE, type = "upper",
         col = color(200), order = "hclust", title = "Matrice de corrélations corrigée",
         addCoef.col = "black", sig.level = 0.05, insig = "blank", mar = c(0,0,1,0)) +
  theme_plot
dev.off()

attach(sub_df)
png("graphics/histogram_Rainf.png")
ggplot(sub_df, aes(x = Rainf.EOBS)) +
  geom_histogram(aes(y = ..density..), colour = "black", fill = "white", bins = 20) +
  geom_density(lwd = 1.2, alpha = 0.25, colour = "darkblue", fill = "darkblue") +
  geom_vline(aes(xintercept = mean(Rainf.EOBS)),
            color = "red", size = 1) +
  labs(title = "Histogramme sur les\nvolumes de pluie tombés",
       x = "Volumétrie de pluie (en mm)", y = "Densités") +
  geom_text(aes(x = mean(Rainf.EOBS) + 3.5, label = paste0("Moyenne :\n", format(round(mean(Rainf.EOBS), 3), nsmall = 3), " (mm)"), y = 1)) +
  theme_plot
dev.off()
png("graphics/histogram_Teau.png")
ggplot(sub_df, aes(x = Teau)) +
  geom_histogram(aes(y = ..density..), colour = "black", fill = "white", bins = 30) +
  geom_density(lwd = 1.2, alpha = 0.25, colour = "darkblue", fill = "darkblue") +
  geom_vline(aes(xintercept = mean(Teau)),
            color = "red", size = 1) +
  labs(title = "Histogramme sur les\ntempératures prises par l'eau",
       x = "Température de l'eau (en °C)", y = "Densités") +
  geom_text(aes(x = mean(Teau) + 3.5, label = paste0("Moyenne :\n", format(round(mean(Teau), 3), nsmall = 3), " (°C)"), y = 0.115)) +
  theme_plot
dev.off()
png("graphics/histogram_Tair.png")
ggplot(sub_df, aes(x = Tair.EOBS)) +
  geom_histogram(aes(y = ..density..), colour = "black", fill = "white", bins = 30) +
  geom_density(lwd = 1.2, alpha = 0.25, colour = "darkblue", fill = "darkblue") +
  geom_vline(aes(xintercept = mean(Tair.EOBS)),
            color = "red", size = 1) +
  labs(title = "Histogramme sur les\ntempératures prises par l'air",
       x = "Température de l'air (en °C)", y = "Densités") +
  geom_text(aes(x = mean(Tair.EOBS) + 3.5, label = paste0("Moyenne :\n", format(round(mean(Tair.EOBS), 3), nsmall = 3), " (°C)"), , y = 0.0675)) +
  theme_plot
dev.off()

png("graphics/density_Teau_each_sensors.png")
ggplot(sub_df, aes(x = Teau, fill = id_sonde, colour = id_sonde)) +
  geom_density(aes(y = ..density..), lwd = 1.2, alpha = 0.25) +
  labs(title = "Densités des températures\nprises par l'eau",
       x = "Température de l'eau (en °C)", y = "Nombre de valeurs", colour = "ID sonde", fill = "ID sonde") +
  theme_plot
dev.off()
detach(sub_df)

# boîtes à moustaches pour la température de l'air
month_by_year = sub_df$year * 100 + sub_df$month
# boites moustache : par sonde
attach(sub_df)
png("graphics/boxplot_Tair_by_sensors.png")
ggplot(sub_df, aes(x = id_sonde, y = Tair.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque sonde",
       x = "Sondes", y = "Température de l'air (en °C)") +
  theme_plot
dev.off()

# boites moustache : par années
png("graphics/boxplot_Tair_by_years.png")
ggplot(sub_df, aes(x = as.factor(year), y = Tair.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque années",
       x = "Années", y = "Température de l'air (en °C)") +
  theme_plot
dev.off()

# boites à moustache par mois
png("graphics/boxplot_Tair_by_months.png")
ggplot(sub_df, aes(x = as.factor(month), y = Tair.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque mois",
       x = "Mois", y = "Température de l'air (en °C)") +
  theme_plot
dev.off()

# boites à moustache par mois et années
png("graphics/boxplot_Tair_by_year_and_months.png", width = 1200, height = 800)
ggplot(sub_df, aes(x = as.factor(month_by_year), y = Tair.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  labs(title = "Boîtes à moustache pour chaque mois et années",
       x = "Année/Mois (AAAAMM)", y = "Température de l'air (en °C)") +
  theme_plot
dev.off()
detach(sub_df)

# boîtes à moustaches pour la volumétrie
# boites moustache : par sonde
attach(sub_df)
png("graphics/boxplot_Rainf_by_sensors.png")
ggplot(sub_df, aes(x = id_sonde, y = Rainf.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque sonde",
       x = "Sondes", y = "Volume de pluie (en mm)") +
  theme_plot
dev.off()

# boites moustache : par années
png("graphics/boxplot_Rainf_by_years.png")
ggplot(sub_df, aes(x = as.factor(year), y = Rainf.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque années",
       x = "Années", y = "Volume de pluie (en mm)") +
  theme_plot
dev.off()

# boites à moustache par mois
png("graphics/boxplot_Rainf_by_months.png")
ggplot(sub_df, aes(x = as.factor(month), y = Rainf.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  labs(title = "Boîtes à moustache pour chaque mois",
       x = "Mois", y = "Volume de pluie (en mm)") +
  theme_plot
dev.off()

# boites à moustache par mois et années
png("graphics/boxplot_Rainf_by_year_and_months.png", width = 1200, height = 800)
ggplot(sub_df, aes(x = as.factor(month_by_year), y = Rainf.EOBS)) +
  geom_boxplot(outlier.colour = "red", outlier.shape = 8, outlier.size = 4) +
  stat_summary(fun = mean, geom = "point", shape = 23, size = 4) +
  theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  labs(title = "Boîtes à moustache pour chaque mois et années",
       x = "Mois", y = "Volume de pluie (en mm)") +
  theme_plot
dev.off()
detach(sub_df)

test_df = sub_df[,c("Rainf.EOBS", "Tair.EOBS")]
attach(test_df)
png("graphics/linear_regression_Tair_Rainf.png")
y = Rainf.EOBS
x = Tair.EOBS
my.formula = y ~ x
ggplot(data = test_df, aes(x = Tair.EOBS, y = Rainf.EOBS)) +
  geom_point() +
  geom_smooth(method = lm, formula = my.formula) +
  stat_poly_eq(formula = my.formula,
               eq.with.lhs = "italic(hat(y))~`=`~",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "*plain(\",\")~")),
               parse = TRUE) +
  labs(title = "Volumétrie de pluie en fonction\nde la température de l'air entre 2013-2018",
       x = "Température de l'air (en °C)", y = "Volumétrie de pluie (en mm)", colour = "Sonde ID") +
  theme_plot
dev.off()
detach(test_df)
test_df = sub_df[,c("Rainf.EOBS", "Teau")]
attach(test_df)
png("graphics/linear_regression_Teau_Rainf.png")
y = Rainf.EOBS
x = Teau
my.formula = y ~ x
ggplot(data = test_df, aes(x = Teau, y = Rainf.EOBS)) +
  geom_point() +
  geom_smooth(method = lm, formula = my.formula) +
  stat_poly_eq(formula = my.formula,
               eq.with.lhs = "italic(hat(y))~`=`~",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "*plain(\",\")~")),
               parse = TRUE) +
  labs(title = "Volumétrie de pluie en fonction\nde la température de l'eau entre 2013-2018",
       x = "Température de l'eau (en °C)", y = "Volumétrie de pluie (en mm)", colour = "Sonde ID") +
  theme_plot
dev.off()
detach(test_df)
test_df = sub_df[,c("Rainf.EOBS", "Tair.EOBS", "id_sonde")]
attach(test_df)
png("graphics/linear_regression_Tair_Rainf_by_sensor.png")
y = Rainf.EOBS
x = Tair.EOBS
my.formula = y ~ x
ggplot(data = test_df, aes(x = Tair.EOBS, y = Rainf.EOBS, color = id_sonde)) +
  geom_point() +
  geom_smooth(method = lm, formula = my.formula) +
  stat_poly_eq(formula = my.formula,
               eq.with.lhs = "italic(hat(y))~`=`~",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "*plain(\",\")~")),
               parse = TRUE) +
  labs(title = "Volumétrie de pluie en fonction de la\ntempérature de l'air entre 2013-2018",
       x = "Température de l'air (en °C)", y = "Volumétrie de pluie (en mm)", colour = "Sonde ID") +
  theme_plot
dev.off()
detach(test_df)

test_df = sub_df[,c("month", "Rainf.EOBS", "id_sonde")]
attach(test_df)
png("graphics/dispersion_by_months_Rainf.png")
ggplot(data = test_df, aes(x = month, y = Rainf.EOBS, colour = id_sonde)) +
  geom_point() +
  labs(title = "Volumétrie de pluie en fonction\ndes mois de l'année entre 2013-2018",
       x = "Mois de l'année", y = "Volumétrie de pluie (en mm)", colour = "Sonde ID") +
  theme_plot
dev.off()
detach(test_df)

# regression pour chaque sonde
attach(sub_df)
png("graphics/linear_regression_Tair_Teau_by_sensors.png")
y = Teau
x = Tair.EOBS
my.formula = y ~ x
ggplot(data = sub_df, aes(x = x, y = y, colour = id_sonde)) +
  geom_point() +
  geom_smooth(method = lm, se = FALSE, formula = my.formula) +
  stat_poly_eq(formula = my.formula,
               eq.with.lhs = "italic(hat(y))~`=`~",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "*plain(\",\")~")),
               parse = TRUE) +
  labs(title = "Température de l'eau en fonction\nde celle de l'air entre 2013-2018",
       x = "Température de l'air (en °C)", y = "Température de l'eau (en °C)", colour = "Sonde ID") +
  theme_plot
dev.off()
detach(sub_df)

# ACI
# preparation données : Teau
base_825 = df %>% filter(df$id_sonde == 825)
base3_825 = aggregate(Teau~date + id_sonde, data = base_825, FUN = mean, na.rm = TRUE)
base3_825 = mutate(base3_825, Teau825 = Teau)

base_827 = df %>% filter(df$id_sonde == 827)
base3_827 = aggregate(Teau~date + id_sonde, data = base_827, FUN = mean, na.rm = TRUE)
base3_827 = mutate(base3_827, Teau827 = Teau)

base_828 = df %>% filter(df$id_sonde == 828)
base3_828 = aggregate(Teau~date + id_sonde, data = base_828, FUN = mean, na.rm = TRUE)
base3_828 = mutate(base3_828, Teau828 = Teau)

base_830 = df %>% filter(df$id_sonde == 830)
base3_830 = aggregate(Teau~date + id_sonde, data = base_830, FUN = mean, na.rm = TRUE)
base3_830 = mutate(base3_830, Teau830 = Teau)

base_f = merge(merge(base3_825, base3_827, by="date"), merge(base3_828, base3_830, by="date"), by="date")
base_f = select(base_f, date, Teau825, Teau827, Teau828, Teau830)

custom_summary(base_f)

# utilisation de fastICA
base_ica = select(base_f, -date)
set.seed(360)
ica = fastICA(base_ica, 2, alg.typ = "parallel", fun = "logcosh",
              alpha = 1, method = "R", row.norm = FALSE, maxit = 200,
              tol = 1e-4, verbose = FALSE)
ica$A # à afficher sur le rapport pour analyse

S = data.frame(ica$S)
B = cbind(base_f, S)

# pour les 4 sondes
png("graphics/ica_2components_for_all_sensors.png")
attach(B)
ggplot(B, aes(date)) +
    geom_line(aes(y = sign(mean(ica$A[1,])) * X1, colour = "1ere")) +
    geom_line(aes(y = sign(mean(ica$A[2,])) * X2 - 6, colour = "2eme (centrée à -6)")) +
    labs(title = "ACI plot",
        y = "Température de l'eau (en °C) normalisées", x = "Date", colour = "Composantes\nindépendantes") +
    theme_plot
detach(B)
dev.off()

# pour la sonde 825
B$comp1_825 = ica$A[1,1] * ica$S[,1]
B$comp2_825 = ica$A[2,1] * ica$S[,2]
png("graphics/ica_2components_for_sensor825.png")
attach(B)
ggplot(B, aes(date)) +
    geom_line(aes(y = comp1_825, colour = "1ere")) +
    geom_line(aes(y = comp2_825 - 10, colour = "2eme (centrée à -10)")) +
    labs(title = "ACI plot (sonde 825)",
        y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
    theme_plot
detach(B)
dev.off()

# pour la sonde 827
B$comp1_827 = ica$A[1,2] * ica$S[,1]
B$comp2_827 = ica$A[2,3] * ica$S[,2]
png("graphics/ica_2components_for_sensor827.png")
attach(B)
ggplot(B, aes(date)) +
    geom_line(aes(y = comp1_827, colour = "1ere")) +
    geom_line(aes(y = comp2_827 - 10, colour = "2eme (centrée à -10)")) +
    labs(title = "ACI plot (sonde 827)",
        y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
    theme_plot
detach(B)
dev.off()

# pour la sonde 828
B$comp1_828 = ica$A[1,3] * ica$S[,1]
B$comp2_828 = ica$A[2,3] * ica$S[,2]
png("graphics/ica_2components_for_sensor828.png")
attach(B)
ggplot(B, aes(date)) +
    geom_line(aes(y = comp1_828, colour = "1ere")) +
    geom_line(aes(y = comp2_828 - 10, colour = "2eme (centrée à -10)")) +
    labs(title = "ACI plot (sonde 828)",
        y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
    theme_plot
detach(B)
dev.off()

# pour la sonde 830
B$comp1_830 = ica$A[1,4] * ica$S[,1]
B$comp2_830 = ica$A[2,4] * ica$S[,2]
png("graphics/ica_2components_for_sensor830.png")
attach(B)
ggplot(B, aes(date)) +
    geom_line(aes(y = comp1_830, colour = "1ere")) +
    geom_line(aes(y = comp2_830 - 10, colour = "2eme (centrée à -10)")) +
    labs(title = "ACI plot (sonde 830)",
        y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
    theme_plot
detach(B)
dev.off()

# set.seed(360)
# ica2 = fastICA(base_ica, 3, alg.typ = "parallel", fun = "logcosh",
#               alpha = 1, method = "R", row.norm = FALSE, maxit = 200,
#               tol = 1e-4, verbose = FALSE)
# ica2$A # à afficher sur le rapport pour analyse

# S = data.frame(ica2$S)
# B2 = cbind(base_f, S)

# # pour les 4 sondes
# png("graphics/ica_3components_for_all_sensors.png")
# attach(B2)
# ggplot(B2, aes(date)) +
#     geom_line(aes(y = sign(mean(ica2$A[1,])) * X1, colour = "1ere")) +
#     geom_line(aes(y = sign(mean(ica2$A[2,])) * X2 - 6, colour = "2eme (centrée à -6)")) +
#     geom_line(aes(y = sign(mean(ica2$A[3,])) * X3 - 12, colour = "3eme (centrée à -12)")) +
#     labs(title = "ACI plot",
#         y = "Température de l'eau (en °C) normalisées", x = "Date", colour = "Composantes\nindépendantes") +
#     theme_plot
# detach(B2)
# dev.off()

# # pour la sonde 825
# B2$comp1_825 = ica2$A[1,1] * ica2$S[,1]
# B2$comp2_825 = ica2$A[2,1] * ica2$S[,2]
# B2$comp3_825 = ica2$A[3,1] * ica2$S[,3]
# png("graphics/ica_3components_for_sensor825.png")
# attach(B2)
# ggplot(B2, aes(date)) +
#     geom_line(aes(y = comp1_825, colour = "1ere")) +
#     geom_line(aes(y = comp2_825 - 10, colour = "2eme (centrée à -10)")) +
#     geom_line(aes(y = comp3_825 - 20, colour = "3eme (centrée à -20)")) +
#     labs(title = "ACI plot (sonde 825)",
#         y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
#     theme_plot
# detach(B2)
# dev.off()

# # pour la sonde 827
# B2$comp1_827 = ica2$A[1,2] * ica2$S[,1]
# B2$comp2_827 = ica2$A[2,3] * ica2$S[,2]
# B2$comp3_827 = ica2$A[3,2] * ica2$S[,3]
# png("graphics/ica_3components_for_sensor827.png")
# attach(B2)
# ggplot(B2, aes(date)) +
#     geom_line(aes(y = comp1_827, colour = "1ere")) +
#     geom_line(aes(y = comp2_827 - 10, colour = "2eme (centrée à -10)")) +
#     geom_line(aes(y = comp3_827 - 20, colour = "3eme (centrée à -20)")) +
#     labs(title = "ACI plot (sonde 827)",
#         y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
#     theme_plot
# detach(B2)
# dev.off()

# # pour la sonde 828
# B2$comp1_828 = ica2$A[1,3] * ica2$S[,1]
# B2$comp2_828 = ica2$A[2,3] * ica2$S[,2]
# B2$comp3_828 = ica2$A[3,3] * ica2$S[,3]
# png("graphics/ica_3components_for_sensor828.png")
# attach(B2)
# ggplot(B2, aes(date)) +
#     geom_line(aes(y = comp1_828, colour = "1ere")) +
#     geom_line(aes(y = comp2_828 - 10, colour = "2eme (centrée à -10)")) +
#     geom_line(aes(y = comp3_828 - 20, colour = "3eme (centrée à -20)")) +
#     labs(title = "ACI plot (sonde 828)",
#         y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
#     theme_plot
# detach(B2)
# dev.off()

# # pour la sonde 830
# B2$comp1_830 = ica2$A[1,4] * ica2$S[,1]
# B2$comp2_830 = ica2$A[2,4] * ica2$S[,2]
# B2$comp3_830 = ica2$A[3,4] * ica2$S[,3]
# png("graphics/ica_3components_for_sensor830.png")
# attach(B2)
# ggplot(B2, aes(date)) +
#     geom_line(aes(y = comp1_830, colour = "1ere")) +
#     geom_line(aes(y = comp2_830 - 10, colour = "2eme (centrée à -10)")) +
#     geom_line(aes(y = comp3_830 - 20, colour = "3eme (centrée à -20)")) +
#     labs(title = "ACI plot (sonde 830)",
#         y = "Température de l'eau (en °C)", x = "Date", colour = "Composantes\nindépendantes") +
#     theme_plot
# detach(B2)
# dev.off()

# ACP
variance_to_save = 80
# pour sonde 825
df_base_pca = df %>% filter(df$id_sonde == 825)
base1 = aggregate(Teau~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base2 = aggregate(Tair.EOBS~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base3 = aggregate(Rainf.EOBS~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base4 = aggregate((Tair.EOBS - Teau)~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
colnames(base4) = c("date", "diff825")
base = merge(base1, base2, by = "date")
base = merge(base, base3, by = "date")
base = merge(base, base4, by = "date")
base_pca = merge(base, B[,c("comp1_825", "comp2_825", "date")], by = "date")
base_pca = mutate(base_pca, C2 = comp2_825, Ta = Tair.EOBS, Tw = Teau,
                  D = diff825, C1 = comp1_825, Rain = Rainf.EOBS)
base_pca$year = year(base_pca$date)
base_pca$month = month(base_pca$date)
base_pca$day = day(base_pca$date)
base_pca$hour = hour(base_pca$date)
base_pca = select(base_pca, -date)
base_pca = select(base_pca, -c(Teau, Tair.EOBS, Rainf.EOBS, diff825, comp1_825, comp2_825))

res.pca = PCA(base_pca, scale.unit = TRUE, ncp = 5, graph = FALSE, quanti.sup = 6:10)
res.pca$var
eig.val = get_eigenvalue(res.pca)
eig.val

# scree plot (explained variance)
df_eig = as.data.frame(eig.val)
attach(df_eig)
max_lim = 80
ratio = 100 / max_lim
var_to_save = variance_to_save / ratio

png("graphics/pca_explained_variance_sensor825.png")
fviz_eig(res.pca, addlabels = TRUE, ylim = c(0, max_lim),
         barcolor = "#E7B800", barfill = "#E7B800", linecolor = "#00AFBB", choice = "variance") +
  geom_point(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), size = 2, color = "#00AFBB") +
  geom_line(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), color = "#00AFBB") +
  scale_y_continuous(sec.axis = sec_axis(~ . * ratio,
                                   name = "Cumulative proportion of explained variance")) +
  geom_hline(yintercept = var_to_save, col = 'red') +
  annotate("text", x = 4.8, y = var_to_save, label = paste(var_to_save * ratio, " %"), vjust = 1.2, col = "red") +
  theme_plot
dev.off()
detach(df_eig)

png("graphics/pca_kaiser_rule_sensor825.png")
res.pca$eig %>%
  as_tibble() %>%
  rownames_to_column("comp") %>%
  ggplot(aes(x = comp, y = eigenvalue, colour = eigenvalue > 1)) +
  geom_hline(yintercept = 1, col = "red") +
  geom_line(size = 1, col = "black") +
  geom_point(size = 3) +
  labs(x = "Composantes principales", y = "Valeurs propres", title = "Application règle de Kaiser") +
  theme_plot
dev.off()

# cercle des corrélations
png("graphics/pca_variables_sensor825.png")
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Évite le chevauchement de texte
             ) +
  theme_plot
dev.off()

png("graphics/pca_components_correlation_to_vars_sensor825.png")
corrplot(res.pca$var$cos2, is.corr = FALSE, title = "Corrélations entre composantes et variables",
         mar = c(0,0,1,0)) +
  theme_plot
dev.off()

# pour sonde 830
df_base_pca = df %>% filter(df$id_sonde == 830)
base1 = aggregate(Teau~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base2 = aggregate(Tair.EOBS~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base3 = aggregate(Rainf.EOBS~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
base4 = aggregate((Tair.EOBS - Teau)~date, data = df_base_pca, FUN = mean, na.rm = TRUE)
colnames(base4) = c("date", "diff830")
base = merge(base1, base2, by = "date")
base = merge(base, base3, by = "date")
base = merge(base, base4, by = "date")
base_pca = merge(base, B[,c("comp1_830", "comp2_830", "date")], by = "date")
base_pca = mutate(base_pca, C2 = comp2_830, Ta = Tair.EOBS, Tw = Teau,
                  D = diff830, C1 = comp1_830, Rain = Rainf.EOBS)
base_pca$year = year(base_pca$date)
base_pca$month = month(base_pca$date)
base_pca$day = day(base_pca$date)
base_pca$hour = hour(base_pca$date)
base_pca = select(base_pca, -date)
base_pca = select(base_pca, -c(Teau, Tair.EOBS, Rainf.EOBS, diff830, comp1_830, comp2_830))

res.pca = PCA(base_pca, scale.unit = TRUE, ncp = 5, graph = FALSE, quanti.sup = 6:10)
res.pca$var
eig.val = get_eigenvalue(res.pca)
eig.val

# scree plot (explained variance)
df_eig = as.data.frame(eig.val)
attach(df_eig)
max_lim = 70
ratio = 100 / max_lim
var_to_save = variance_to_save / ratio

png("graphics/pca_explained_variance_sensor830.png")
fviz_eig(res.pca, addlabels = TRUE, ylim = c(0, max_lim),
         barcolor = "#E7B800", barfill = "#E7B800", linecolor = "#00AFBB", choice = "variance") +
  geom_point(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), size = 2, color = "#00AFBB") +
  geom_line(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), color = "#00AFBB") +
  scale_y_continuous(sec.axis = sec_axis(~ . * ratio,
                                   name = "Cumulative proportion of explained variance")) +
  geom_hline(yintercept = var_to_save, col = 'red') +
  annotate("text", x = 4.8, y = var_to_save, label = paste(var_to_save * ratio, " %"), vjust = 1.2, col = "red") +
  theme_plot
dev.off()
detach(df_eig)

png("graphics/pca_kaiser_rule_sensor830.png")
res.pca$eig %>%
  as_tibble() %>%
  rownames_to_column("comp") %>%
  ggplot(aes(x = comp, y = eigenvalue, colour = eigenvalue > 1)) +
  geom_hline(yintercept = 1, col = "red") +
  geom_line(size = 1, col = "black") +
  geom_point(size = 3) +
  labs(x = "Composantes principales", y = "Valeurs propres", title = "Application règle de Kaiser") +
  theme_plot
dev.off()

# cercle des corrélations
png("graphics/pca_variables_sensor830.png")
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Évite le chevauchement de texte
             ) +
  theme_plot
dev.off()

png("graphics/pca_components_correlation_to_vars_sensor830.png")
corrplot(res.pca$var$cos2, is.corr = FALSE, title = "Corrélations entre composantes et variables",
         mar = c(0,0,1,0)) +
  theme_plot
dev.off()

# ACP pour toutes les sondes
base1 = aggregate(Teau~date, data = df, FUN = mean, na.rm = TRUE)
base2 = aggregate(Tair.EOBS~date, data = df, FUN = mean, na.rm = TRUE)
base3 = aggregate(Rainf.EOBS~date, data = df, FUN = mean, na.rm = TRUE)
base4 = aggregate((Tair.EOBS - Teau)~date, data = df, FUN = mean, na.rm = TRUE)
colnames(base4) = c("date", "D")
base = merge(base1, base2, by = "date")
base = merge(base, base3, by = "date")
base = merge(base, base4, by = "date")
base_pca = merge(base, B[,c("X1", "X2", "date")], by = "date")
base_pca = mutate(base_pca, C2 = sign(mean(ica$A[2,])) * X2, Ta = Tair.EOBS, Tw = Teau,
                  C1 = sign(mean(ica$A[1,])) * X1, Rain = Rainf.EOBS)
base_pca$year = year(base_pca$date)
base_pca$month = month(base_pca$date)
base_pca$day = day(base_pca$date)
base_pca$hour = hour(base_pca$date)
base_pca = select(base_pca, -date)
base_pca = select(base_pca, -c(Teau, Tair.EOBS, Rainf.EOBS, X1, X2))
res.pca = PCA(base_pca, scale.unit = TRUE, ncp = 5, graph = FALSE, quanti.sup = 6:10)
res.pca$var
eig.val = get_eigenvalue(res.pca)
eig.val

# scree plot (explained variance)
df_eig = as.data.frame(res.pca$eig)
attach(df_eig)
max_lim = 75
ratio = 100 / max_lim
var_to_save = variance_to_save / ratio
colnames(df_eig) = c("eigenvalue", "percentage of variance", "cumulative.variance.percent")

png("graphics/pca_explained_variance.png")
fviz_eig(res.pca, addlabels = TRUE, ylim = c(0, max_lim),
         barcolor = "#E7B800", barfill = "#E7B800", linecolor = "#00AFBB", choice = "variance") +
  geom_point(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), size = 2, color = "#00AFBB") +
  geom_line(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), color = "#00AFBB") +
  scale_y_continuous(sec.axis = sec_axis(~ . * ratio,
                                   name = "Cumulative proportion of explained variance")) +
  geom_hline(yintercept = var_to_save, col = 'red') +
  annotate("text", x = 4.8, y = var_to_save, label = paste(var_to_save * ratio, " %"), vjust = 1.2, col = "red") +
  theme_plot
dev.off()
detach(df_eig)

png("graphics/pca_kaiser_rule.png")
res.pca$eig %>%
  as_tibble() %>%
  rownames_to_column("comp") %>%
  ggplot(aes(x = comp, y = eigenvalue, colour = eigenvalue > 1)) +
  geom_hline(yintercept = 1, col = "red") +
  geom_line(size = 1, col = "black") +
  geom_point(size = 3) +
  labs(x = "Composantes principales", y = "Valeurs propres", title = "Application règle de Kaiser") +
  theme_plot
dev.off()

png("graphics/pca_variables.png")
# cercle des corrélations
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Évite le chevauchement de texte
             ) +
  theme_plot
dev.off()

png("graphics/pca_components_correlation_to_vars.png")
corrplot(res.pca$var$cos2, is.corr = FALSE, title = "Corrélations entre composantes et variables",
         mar = c(0,0,1,0)) +
  theme_plot
dev.off()

# ACP pour toutes les sondes (sans ACI et toutes les variables)
res.pca = PCA(sub_df[,-which(names(sub_df) == "id_sonde")], scale.unit = TRUE, ncp = 5, graph = FALSE)
res.pca$var
eig.val = get_eigenvalue(res.pca)
eig.val

# scree plot (explained variance)
df_eig = as.data.frame(eig.val)
attach(df_eig)
max_lim = 40
ratio = 100 / max_lim
var_to_save = variance_to_save / ratio

png("graphics/all_sensors_and_vars_pca_explained_variance.png")
fviz_eig(res.pca, addlabels = TRUE, ylim = c(0, max_lim),
         barcolor = "#E7B800", barfill = "#E7B800", linecolor = "#00AFBB", choice = "variance") +
  geom_point(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), size = 2, color = "#00AFBB") +
  geom_line(data = df_eig, aes(x = 1:nrow(df_eig), y = cumulative.variance.percent/ratio), color = "#00AFBB") +
  scale_y_continuous(sec.axis = sec_axis(~ . * ratio,
                                   name = "Cumulative proportion of explained variance")) +
  geom_hline(yintercept = var_to_save, col = 'red') +
  annotate("text", x = 7, y = var_to_save, label = paste(var_to_save * ratio, " %"), vjust = 1.2, col = "red") +
  theme_plot
dev.off()
detach(df_eig)

png("graphics/all_sensors_and_vars_pca_kaiser_rule.png")
res.pca$eig %>%
  as_tibble() %>%
  rownames_to_column("comp") %>%
  ggplot(aes(x = comp, y = eigenvalue, colour = eigenvalue > 1)) +
  geom_hline(yintercept = 1, col = "red") +
  geom_line(size = 1, col = "black") +
  geom_point(size = 3) +
  labs(x = "Composantes principales", y = "Valeurs propres", title = "Application règle de Kaiser") +
  theme_plot
dev.off()

png("graphics/all_sensors_and_vars_pca_variables.png")
# cercle des corrélations
fviz_pca_var(res.pca, col.var = "cos2",
             gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
             repel = TRUE # Évite le chevauchement de texte
             ) +
  theme_plot
dev.off()

png("graphics/all_sensors_and_vars_pca_individus.png")
fviz_pca_ind(res.pca,
             geom.ind = "point", # Montre les points seulement (mais pas le "text")
             col.ind = sub_df$id_sonde, # colorer by groups
             palette = c("#00AFBB", "#E7B800", "#FC4E07", "#00FCFC"),
             addEllipses = TRUE, # Ellipses de concentration
             legend.title = "Sondes"
             ) +
  theme_plot
dev.off()

png("graphics/all_sensors_and_vars_pca_variables_individus.png")
fviz_pca_biplot(res.pca,
                col.ind = sub_df$id_sonde, palette = "jco",
                addEllipses = TRUE, label = "var",
                col.var = "black", repel = TRUE,
                legend.title = "Sondes") +
  theme_plot
dev.off()

png("graphics/all_sensors_and_vars_pca_biplot_contribs.png")
fviz_pca_biplot(res.pca,
                # Individus
                geom.ind = "point",
                fill.ind = sub_df$id_sonde, col.ind = "black",
                pointshape = 21, pointsize = 2,
                palette = "jco",
                addEllipses = TRUE,
                # Variables
                alpha.var ="contrib", col.var = "contrib",
                gradient.cols = "RdYlBu",
                legend.title = list(fill = "Sondes", color = "Contrib",
                                    alpha = "Contrib")
                ) +
  theme_plot
dev.off()

png("graphics/all_sensors_and_vars_pca_components_correlation_to_vars.png")
corrplot(res.pca$var$cos2, is.corr = FALSE, title = "Corrélations entre composantes et variables",
         mar = c(0,0,1,0)) +
  theme_plot
dev.off()


context("SQL translation")

test_that("Simple maths is correct", {
  expect_equal(translate_sql(1 + 2), sql("1.0 + 2.0"))
  expect_equal(translate_sql(2 * 4), sql("2.0 * 4.0"))
  expect_equal(translate_sql(5 ^ 2), sql("POWER(5.0, 2.0)"))
  expect_equal(translate_sql(100L %% 3L), sql("100 % 3"))
})

test_that("dplyr.strict_sql = TRUE prevents auto conversion", {
  old <- options(dplyr.strict_sql = TRUE)
  on.exit(options(old))

  expect_equal(translate_sql(1 + 2), sql("1.0 + 2.0"))
  expect_error(translate_sql(blah(x)), "could not find function")
})

test_that("Wrong number of arguments raises error", {
  expect_error(translate_sql(mean(1, 2), window = FALSE), "Invalid number of args")
})

test_that("Named arguments generates warning", {
  expect_warning(translate_sql(mean(x = 1), window = FALSE), "Named arguments ignored")
})

test_that("Subsetting always evaluated locally", {
  x <- list(a = 1, b = 1)
  y <- c(2, 1)

  correct <- quote(`_var` == 1)

  expect_equal(partial_eval(quote(`_var` == x$a)), correct)
  expect_equal(partial_eval(quote(`_var` == x[[2]])), correct)
  expect_equal(partial_eval(quote(`_var` == y[2])), correct)
})

test_that("between translated to special form (#503)", {

  out <- translate_sql(between(x, 1, 2))
  expect_equal(out, sql('"x" BETWEEN 1.0 AND 2.0'))
})

test_that("is.na and is.null are equivalent",{
  expect_equal(translate_sql(!is.na(x)), sql('NOT(("x") IS NULL)'))
  expect_equal(translate_sql(!is.null(x)), sql('NOT(("x") IS NULL)'))
})

test_that("if translation adds parens", {
  expect_equal(
    translate_sql(if (x) y),
    sql('CASE WHEN ("x") THEN ("y") END')
  )
  expect_equal(
    translate_sql(if (x) y else z),
    sql('CASE WHEN ("x") THEN ("y") ELSE ("z") END')
  )

})

test_that("pmin and pmax become min and max", {
  expect_equal(translate_sql(pmin(x, y)), sql('MIN("x", "y")'))
  expect_equal(translate_sql(pmax(x, y)), sql('MAX("x", "y")'))
})

# Minus -------------------------------------------------------------------

test_that("unary minus flips sign of number", {
  expect_equal(translate_sql(-10L), sql("-10"))
  expect_equal(translate_sql(x == -10), sql('"x" = -10.0'))
  expect_equal(translate_sql(x %in% c(-1L, 0L)), sql('"x" IN (-1, 0)'))
})

test_that("unary minus wraps non-numeric expressions", {
  expect_equal(translate_sql(-(1L + 2L)), sql("-(1 + 2)"))
  expect_equal(translate_sql(-mean(x), window = FALSE), sql('-AVG("x")'))
})

test_that("binary minus subtracts", {
  expect_equal(translate_sql(1L - 10L), sql("1 - 10"))
})

# Window functions --------------------------------------------------------

test_that("window functions without group have empty over", {
  expect_equal(translate_sql(n()), sql("COUNT(*) OVER ()"))
  expect_equal(translate_sql(sum(x)), sql('sum("x") OVER ()'))
})

test_that("aggregating window functions ignore order_by", {
  expect_equal(
    translate_sql(n(), vars_order = "x"),
    sql("COUNT(*) OVER ()")
  )
  expect_equal(
    translate_sql(sum(x), vars_order = "x"),
    sql('sum("x") OVER ()')
  )
})

test_that("cumulative windows warn if no order", {
  expect_warning(translate_sql(cumsum(x)), "does not have explicit order")
  expect_warning(translate_sql(cumsum(x), vars_order = "x"), NA)
})

test_that("ntile always casts to integer", {
  expect_equal(
    translate_sql(ntile(x, 10.5)),
    sql('NTILE(10) OVER (ORDER BY "x")')
  )
})

test_that("connection affects quoting character", {
  dbiTest <- structure(list(), class = "DBITestConnection")
  dbTest <- src_sql("test", con = dbiTest)
  testTable <- tbl_sql("test", src = dbTest, from = "table1")

  out <- select(testTable, field1)
  expect_match(sql_render(out), "^SELECT `field1` AS `field1`\nFROM `table1`$")
})


#setwd("")
#covfile<-""
#sample_names<-c("","")

library(ggplot2)
library(reshape2)
library(RColorBrewer)

dat<-read.table(covfile, sep="\t", header=F)
chrom<-dat$V1[1]
dat<-dat[,c(2,4:ncol(dat))]
colnames(dat)<-c("start", sample_names)

csum<-apply(dat[,-1], 1, sum)
csumz<-which(csum>0)
mincsumz<-min(csumz)
maxcsumz<-max(csumz)

cdat<-dat[c(mincsumz:maxcsumz),]
mdat<-melt(cdat, id="start")
colnames(mdat)<-c("start", "Sample", "Reads")
mdat$logCount<-log2(mdat$Reads+1)

makeColors<-function(n,colorNames="Set1") {
  maxN<-brewer.pal.info[colorNames,"maxcolors"]
  if (n<=maxN) {
    colors<-brewer.pal(n, colorNames)
  } else {
    colors<-colorRampPalette(brewer.pal(maxN, colorNames))(n)
  }
  return(colors)
}

sampleColors<-makeColors(ncol(dat)-1)

pdf(file=paste0(covfile, ".pdf"), width=10, height=5)

g<-ggplot(mdat, aes(x=start, y=Reads)) +
  geom_point(aes(col=Sample), size=0.5) +
  scale_color_manual(values=sampleColors) +
  xlab(paste("Chromosome", chrom)) +
  ylab("Reads") +
  theme_classic()
print(g)
dev.off()

pdf(file=paste0(covfile, ".log2.pdf"), width=10, height=5)

g<-ggplot(mdat, aes(x=start, y=logCount)) +
  geom_point(aes(col=Sample), size=0.5) +
  scale_color_manual(values=sampleColors) +
  xlab(paste("Chromosome", chrom)) +
  ylab("Reads") +
  theme_classic()
print(g)
dev.off()


stepUpIter <- function() {
    i <- 0
    while ( ! i) {
        i <- i - 1 + (2 * step())
    }
}


#print Fizz for 3 and buzz for 5 and FizzBuzz for both

for (n in 1:100) {
 if (n %% 3 == 0 & n %% 5 == 0) {print("FizzBuzz")}
 else if (n %% 3 == 0) {print("Fizz")}
 else if (n %% 5 == 0) {print("Buzz")}
 else print(n)
}


library("rJava")
.jinit(classpath="MINE.jar")

###########################################
# MINE - runs MINE on a comma-separated
#  values (CSV) file. All parameters are as
#  in the Java version. The parameters
#  var1.id and var2.id are for use when
#  the analysis style specified requires
#  more information. For instance, since
#  style="master.variable" requires an
#  additional variable id (the id of the
#  master variable, you will need to
#  specify var1.id in this case.
#
#  As in the Java version, if you do not
#  specify a value for style, and you
#  specify a value for var1.id and not
#  var2.id, then style="master.variable"
#  will be assumed. If you do not specify a
#  value for style, and you specify values
#  for both var1.id and var2.id, then
#  style="one.pair" will be assumed.
#
# EXAMPLES:
#  MINE("Spellman.csv","all.pairs",0)
#  MINE("Spellman.csv",0)
#   will both run MINE on "Spellman.csv"
#   and have it analyze each variable only
#   against the 0-th variable.
#
#  MINE("Spellman.csv","one.pair",0,5)
#  MINE("Spellman.csv",0,5)
#   will both run MINE on "Spellman.csv"
#   and have it analyze only the 0-th
#   variable against the 5-th variable.
###########################################
MINE <- function (
		input.filename,
		style=c("master.variable", "all.pairs", "adjacent.pairs", "pairs.between", "one.pair"),
		var1.id=NA,
		var2.id=NA,
		required.common.vals.fraction=0,
		max.num.boxes.exponent=0.6,
		notify.wait=100,
		num.clumps.factor=15,
		debug.level=0,
		gc.wait=Inf,
		job.id
		) {

	printHeader()

	params <- getParams(input.filename, style, var1.id, var2.id, required.common.vals.fraction, max.num.boxes.exponent, notify.wait, num.clumps.factor, debug.level, gc.wait, job.id)

	# run the analysis
	cat("reading in dataset...\n")
	flush.console()

	dataset <- .jnew("data/Dataset",
				params$inputfile,
				params$analysisParams$mineParams$debug)

	cat("done.\n")
	flush.console()

	doAnalysis(dataset, params)
}

###########################################
# rMINE - runs MINE on an R matrix.
#  all parameters are as in MINE, except
#  that the name of the results file will
#  begin with output.prefix rather than
#  the name of the input file (since there
#  is no input file).
#
#  MINE assumes that each row of the
#  supplied matrix is a variable, and each
#  column is a record.
#
# EXAMPLE:
#  rMINE(matrix(1:10,2),"matrix",0)
#   will run MINE on matrix(1:10,2),
#   assuming that each of the two rows
#   in the matrix is a variable.
###########################################
rMINE <- function (
		data,
		output.prefix,
		style=c("master.variable", "all.pairs", "adjacent.pairs", "pairs.between", "one.pair"),
		var1.id=NA,
		var2.id=NA,
		required.common.vals.fraction=0,
		max.num.boxes.exponent=0.6,
		notify.wait=100,
		num.clumps.factor=15,
		debug.level=0,
		gc.wait=Inf,
		job.id
		) {
	printHeader()

	if(missing(output.prefix))
		stop("you must specify output.prefix so that I'll know what to name the output file!")

	params <- getParams(output.prefix, style, var1.id, var2.id, required.common.vals.fraction, max.num.boxes.exponent, notify.wait, num.clumps.factor, debug.level, gc.wait, job.id)

	# run the analysis
	cat("reading in dataset...\n")
	flush.console()

	data <- .jarray(data, dispatch=TRUE)

	dataset <- .jnew("data/Dataset",
				data, params$analysisParams$mineParams$debug)
	cat("done.\n")
	flush.console()

	doAnalysis(dataset, params)
}

printHeader <- function () {
	# print header
	cat(J("main/Analyze")$header())
	cat("\n\n")
	flush.console()
}

getParams <- function(
		input.filename,
		style=c("master.variable", "all.pairs", "adjacent.pairs", "pairs.between", "one.pair"),
		var1.id=NA,
		var2.id=NA,
		required.common.vals.fraction=0,
		max.num.boxes.exponent=0.6,
		notify.wait=100,
		num.clumps.factor=15,
		debug.level=0,
		gc.wait=Inf,
		job.id
		) {
	if (gc.wait==Inf) gc.wait <- J("java.lang.Integer")$MAX_VALUE
	else gc.wait <- as.integer(gc.wait)

	# create parameters object
	if(missing(job.id)) {
		args <- c(
				input.filename,
				style,
				var1.id,
				var2.id,
				paste("cv=", required.common.vals.fraction, sep = ""),
				paste("exp=", max.num.boxes.exponent, sep = ""),
				paste("notify=", notify.wait, sep = ""),
				paste("c=", num.clumps.factor, sep = ""),
				paste("d=", debug.level, sep = ""),
				paste("gc=", gc.wait, sep = "")
		)
	} else {
		args <- c(
				input.filename,
				style,
				var1.id,
				var2.id,
				paste("cv=", required.common.vals.fraction, sep = ""),
				paste("exp=", max.num.boxes.exponent, sep = ""),
				paste("notify=", notify.wait, sep = ""),
				paste("c=", num.clumps.factor, sep = ""),
				paste("d=", debug.level, sep = ""),
				paste("gc=", gc.wait, sep = ""),
				paste("id=", job.id, sep = "")
		)
	}

	# this removes NA entries from args, so that if var1.id and var2.id aren't defined
	# then we won't pass the NA's on to Java.
	args <- args[!is.na(args)]

	params <- .jnew("main/JobParameters", .jarray(args))
	flush.console()

	#confirm parameters for user
	cat(params$toString())
	cat("\n")
	flush.console()

	params
}

doAnalysis <- function (dataset, params) {
	toAnalyze <- .jnew("analysis/VarPairQueue", dataset)

	params$analysisStyle$addVarPairsTo(toAnalyze, dataset$numVariables())

	a <- .jnew("analysis/Analysis", dataset, toAnalyze)

	cat("Analyzing...\n")
	flush.console()

	while(! a$varPairQueue()$isEmpty()) {
		# print a status update
		statusUpdate <- paste(a$numResults() + 1, " calculating: ", a$varPairQueue()$peek()$var1$name(), " vs ", a$varPairQueue()$peek()$var2$name(), "...\n", sep="")
		cat(statusUpdate)
		flush.console()

		# create a file containing the status update (for use when running on a cluster)
		write(statusUpdate, file=params$statusFileName())

		# analyze some more pairs
		a$analyzePairs(J("analysis.results/BriefResult")$class,
					params$analysisParams,
					params$notifyWait)
	}

	cat(paste(a$numResults(), " variable pairs analyzed.\n", "Sorting results in descending order...\n", sep=""))
	flush.console()

	results <- a$getSortedResults()

	cat("done. printing results\n")
	flush.console()

	#print the results
	repeat {
		if(J("main/Analyze")$printResults(results, params)) {
			break
		}
		else {
			n <- readline("writing results to output file failed. Perhaps it is locked in some way. Enter 1 to try again, 0 otherwise: ")
			if(n == 0) break
		}
	}

	cat("Analysis finished. See file \"")
	cat(params$resultsFileName())
	cat("\" for output\n")
}


#' is.float
#'
#' Tests if argument is a float matrix.
#'
#' @details
#' \code{is.float()} and \code{is.float()} are different names for the same
#' function.
#'
#' @param x
#' An R object.
#'
#' @return
#' A logical value.
#'
#' @examples
#' library(float)
#'
#' x = matrix(0, 5, 5)
#' s = flrunif(10, 3)
#' is.float(x)
#' is.float(s)
#'
#' @export
is.float = function(x)
{
  is(x, "float32")
}


library(ggplot2)

d <- read.table('steps-from-goal.txt',
                sep=":",
                col.names=c('step', 'count'),
                fill=FALSE,
                strip.white=TRUE)

print(ggplot(d, aes(x=step, y=count)) +
        geom_bar(stat='identity') +
        xlab('Steps From Goal') +
        ylab('Valid Board Configurations') +
        scale_x_continuous(breaks=seq(min(d$step), max(d$step))) +
        ggtitle('Eight Puzzle Board Combinations From Goal Using A*'))


#file containing functions for Covid-19 analysis

#calculate moving average
ma <- function(x,n=5){stats::filter(x,rep(1/n,n), sides=1)}

# Download data file from JHU github url and build filtered dataframe
build_dataframe <- function(cases_file, countries) {
  base_url <- "https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/"
  cases_url <- paste(base_url,cases_file, sep = "")
  download.file(cases_url, "corona_cases.csv")
  df_cases <- read.csv("corona_cases.csv")
  df_cases$Country.Region <- gsub(' ', '_', df_cases$Country.Region)
  df_cases <- subset(df_cases, select=-c(1,3,4,5:57), Country.Region %in% countries & !grepl(".*, .*", Province.State))
  df_cases <- aggregate(df_cases[-1], by=list(Country=df_cases$Country.Region), FUN=sum)
  df_cases$Country <- gsub(' ', '_', df_cases$Country)
  rownames(df_cases) <- df_cases$Country
  df_cases[-1]
}

get_base_plot <- function(d_series, yLabel) {
  p <- d_series %>% gather(countries,key="Country",value="Value", -date) %>%
    ggplot(aes(x=as.Date(date, origin = "2020/1/1"),y=Value,col=Country,group=Country)) +
    labs(y=yLabel, x = "") +
    theme_economist() +
    scale_x_date(date_labels = "%b %y", date_breaks = "1 month")
  p
}


## after removing poor quality samples look within each cell type for additional outliers.
## uses a PCA approach, only if there are at least 5 samples
## do this separately for two studies
## add some intital exclusion criteria

### parameters for sample filtering
thresBS<-80

library(bigmelon)
library(pheatmap)
library(glmnet)

setwd(dataDir)

gfile<-openfn.gds(gdsFile, readonly = FALSE)

## filter samples
load(qcData)
passQC<-QCmetrics$Basename[QCmetrics$intensPASS & QCmetrics$bisulfCon > thresBS & as.character(QCmetrics$predSex) == as.character(QCmetrics$Sex)]

QCmetrics<-QCmetrics[QCmetrics$intensPASS & QCmetrics$bisulfCon > thresBS & as.character(QCmetrics$predSex) == as.character(QCmetrics$Sex),]

studyInd<-QCmetrics$Project
cellTypes<-unique(QCmetrics$Cell.type)
cellCols<-rainbow(length(cellTypes))[as.factor(QCmetrics$Cell.type)]

rawbetas<-betas(gfile)[,]
rawbetas<-rawbetas[,match(QCmetrics$Basename, colnames(rawbetas))]
auto.probes<-which(fData(gfile)$chr != "chrX" & fData(gfile)$chr != "chrY")
rawbetas<-rawbetas[auto.probes,]

## first do heatmap to check how things look intially
sample_anno<-QCmetrics[,c("Cell.type", "Age","Sex")]
sample_anno$Age<-as.numeric(sample_anno$Age)
rownames(sample_anno)<-QCmetrics$Basename
sigma<-list()

cellPCA<-list()

cellOutlier<-rep("FALSE", length = ncol(rawbetas))

for(study in unique(studyInd)){
	for(each in cellTypes){
		sampleInd<-which(QCmetrics$Cell.type == each & QCmetrics$Project == study)
		if(length(sampleInd) > 5){
			## PCA within each cell type
			cellPCA[[study]][[each]]<-prcomp(t(na.omit(rawbetas[,sampleInd])))

			## denote anything more than 3 SD from mean an outlier on 1st PC
			mu<-mean(cellPCA[[study]][[each]]$x[,1], na.rm = TRUE)
			sigma<-sd(cellPCA[[study]][[each]]$x[,1], na.rm = TRUE)
			outlierindex<-which(cellPCA[[study]][[each]]$x[,1] > mu +3*sigma | cellPCA[[study]][[each]]$x[,1] < mu -3*sigma)
			if(length(outlierindex) > 0){
				cellOutlier[sampleInd[outlierindex]]<-"TRUE"
			}
		}
	}
}

save(cellPCA, cellOutlier, file = "QCmetrics/CellTypePCA.rdata")

## need to close gds file in order to open in another R session
closefn.gds(gfile)


source("pattern_count.r")

frequent_words <- function(text, k) {
  frequent_patterns <- {}
  count <- {}
  for (i in 0:(nchar(text) - k)) {
    pattern <- substr(text, i + 1, i + k)
    count[i + 1] <- pattern_count(text, pattern)
  }
  max_count <- max(count)
  for (i in 0:(nchar(text) - k)) {
    if (count[i + 1] == max_count)
      frequent_patterns <- append(frequent_patterns, substr(text, i + 1, i + k))
  }
  return(unique(frequent_patterns))
}

message("Text")
text <- scan("stdin", what="character", nlines=1)
message("K")
k <- scan("stdin", nlines=1)

print(frequent_words(text, k))


#' @export
#' @rdname geom_density_2d
#' @param contour If `TRUE`, contour the results of the 2d density
#'   estimation.
#' @param contour_var Character string identifying the variable to contour
#'   by. Can be one of `"density"`, `"ndensity"`, or `"count"`. See the section
#'   on computed variables for details.
#' @inheritDotParams geom_contour bins binwidth breaks
#' @param n Number of grid points in each direction.
#' @param h Bandwidth (vector of length two). If `NULL`, estimated
#'   using [MASS::bandwidth.nrd()].
#' @param adjust A multiplicative bandwidth adjustment to be used if 'h' is
#'    'NULL'. This makes it possible to adjust the bandwidth while still
#'    using the a bandwidth estimator. For example, `adjust = 1/2` means
#'    use half of the default bandwidth.
#' @section Computed variables:
#' `stat_density_2d()` and `stat_density_2d_filled()` compute different
#' variables depending on whether contouring is turned on or off. With
#' contouring off (`contour = FALSE`), both stats behave the same, and the
#' following variables are provided:
#' \describe{
#'   \item{`density`}{The density estimate.}
#'   \item{`ndensity`}{Density estimate, scaled to a maximum of 1.}
#'   \item{`count`}{Density estimate * number of observations in group.}
#'   \item{`n`}{Number of observations in each group.}
#' }
#'
#' With contouring on (`contour = TRUE`), either [stat_contour()] or
#' [stat_contour_filled()] (for contour lines or contour bands,
#' respectively) is run after the density estimate has been obtained,
#' and the computed variables are determined by these stats.
#' Contours are calculated for one of the three types of density estimates
#' obtained before contouring, `density`, `ndensity`, and `count`. Which
#' of those should be used is determined by the `contour_var` parameter.
stat_density_2d <- function(mapping = NULL, data = NULL,
                            geom = "density_2d", position = "identity",
                            ...,
                            contour = TRUE,
                            contour_var = "density",
                            n = 100,
                            h = NULL,
                            adjust = c(1, 1),
                            na.rm = FALSE,
                            show.legend = NA,
                            inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatDensity2d,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      na.rm = na.rm,
      contour = contour,
      contour_var = contour_var,
      n = n,
      h = h,
      adjust = adjust,
      ...
    )
  )
}

#' @rdname geom_density_2d
#' @usage NULL
#' @export
stat_density2d <- stat_density_2d

#' @rdname geom_density_2d
#' @export
stat_density_2d_filled <- function(mapping = NULL, data = NULL,
                                   geom = "density_2d_filled", position = "identity",
                                   ...,
                                   contour = TRUE,
                                   contour_var = "density",
                                   n = 100,
                                   h = NULL,
                                   adjust = c(1, 1),
                                   na.rm = FALSE,
                                   show.legend = NA,
                                   inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatDensity2dFilled,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      na.rm = na.rm,
      contour = contour,
      contour_var = contour_var,
      n = n,
      h = h,
      adjust = adjust,
      ...
    )
  )
}

#' @rdname geom_density_2d
#' @usage NULL
#' @export
stat_density2d_filled <- stat_density_2d_filled

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatDensity2d <- ggproto("StatDensity2d", Stat,
  default_aes = aes(colour = "#3366FF", size = 0.5),

  required_aes = c("x", "y"),

  extra_params = c(
    "na.rm", "contour", "contour_var",
    "bins", "binwidth", "breaks"
  ),

  # when contouring is on, are we returning lines or bands?
  contour_type = "lines",

  compute_layer = function(self, data, params, layout) {
    # first run the regular layer calculation to infer densities
    data <- ggproto_parent(Stat, self)$compute_layer(data, params, layout)

    # if we're not contouring we're done
    if (!isTRUE(params$contour)) return(data)

    # set up data and parameters for contouring
    contour_var <- params$contour_var %||% "density"
    if (!isTRUE(contour_var %in% c("density", "ndensity", "count"))) {
      abort(glue(
        'Unsupported value for `contour_var`: {contour_var}\n',
        'Supported values are "density", "ndensity", and "count".'
      ))
    }
    data$z <- data[[contour_var]]
    z.range <- range(data$z, na.rm = TRUE, finite = TRUE)
    params <- params[intersect(names(params), c("bins", "binwidth", "breaks"))]
    params$z.range <- z.range

    if (isTRUE(self$contour_type == "bands")) {
      contour_stat <- StatContourFilled
    } else { # lines is the default
      contour_stat <- StatContour
    }

    args <- c(list(data = quote(data), scales = quote(scales)), params)
    dapply(data, "PANEL", function(data) {
      scales <- layout$get_scales(data$PANEL[1])
      tryCatch(do.call(contour_stat$compute_panel, args), error = function(e) {
        warn(glue("Computation failed in `{snake_class(self)}()`:\n{e$message}"))
        new_data_frame()
      })
    })
  },

  compute_group = function(data, scales, na.rm = FALSE, h = NULL, adjust = c(1, 1),
                           n = 100, ...) {
    if (is.null(h)) {
      h <- c(MASS::bandwidth.nrd(data$x), MASS::bandwidth.nrd(data$y))
      h <- h * adjust
    }

    # calculate density
    dens <- MASS::kde2d(
      data$x, data$y, h = h, n = n,
      lims = c(scales$x$dimension(), scales$y$dimension())
    )

    # prepare final output data frame
    nx <- nrow(data) # number of observations in this group
    df <- expand.grid(x = dens$x, y = dens$y)
    df$density <- as.vector(dens$z)
    df$group <- data$group[1]
    df$ndensity <- df$density / max(df$density, na.rm = TRUE)
    df$count <- nx * df$density
    df$n <- nx
    df$level <- 1
    df$piece <- 1
    df
  }
)

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatDensity2dFilled <- ggproto("StatDensity2dFilled", StatDensity2d,
  default_aes = aes(colour = NA, fill = after_stat(level)),
  contour_type = "bands"
)


setwd("P:/2019 0970 151 000/User Data/Faraz-Export IDAVE folders")
library(tidyverse)
library(icd)
df <- read.csv("./datasets/New/NACRASCIHI_2_dupRemoved.csv")

tabna <- function(x){table(x, useNA = "ifany")}

icd <- df %>% select(ID, days_to_lefteddate, dx10code1:dx10code10, alc_status)%>%
mutate(IDm = paste(ID, days_to_lefteddate, sep="_"))

# library(data.table)
# long <- melt(setDT(icd), id.vars = c("ID", "days_to_lefteddate"), variable.name="code")

# long <- long %>% arrange(ID, days_to_lefteddate) %>%
# mutate(IDm = paste(ID, days_to_lefteddate, sep="_"))

ls("package:icd")

# "icd10_comorbid"
# [31] "icd10_comorbid_ahrq"      "icd10_comorbid_ccs"
# [33] "icd10_comorbid_charlson"  "icd10_comorbid_elix"
# [35] "icd10_comorbid_hcc"       "icd10_comorbid_pccc_dx"
# [37] "icd10_comorbid_pccc_pcs"  "icd10_comorbid_quan_deyo"
# [39] "icd10_comorbid_quan_elix" "icd10_filter_invalid"
# [41] "icd10_filter_valid"       "icd10_map_ahrq"
# [43] "icd10_map_ahrq_pcs"       "icd10_map_cc"
# [45] "icd10_map_ccs"            "icd10_map_charlson"
# [47] "icd10_map_elix"           "icd10_map_pccc_dx"
# [49] "icd10_map_pccc_pcs"       "icd10_map_quan_deyo"
# [51] "icd10_map_quan_elix"      "icd10_names_ccs"

ic <- icd %>% select(IDm, dx10code1:dx10code10)
result = data.frame()
res <- icd10_comorbid_charlson(ic, return_df = TRUE)

#Calculate three different comorbidity index---> charlson, quan, van_walraven
charl_index <- charlson_from_comorbid(res, scoring_system = "charlson")
f <- data.frame("ID" = attributes(charl_index), "charl_index" = as.numeric(charl_index))
names(f)[1] <- "IDm"
f$quan_index <- as.numeric(charlson_from_comorbid(res, scoring_system = "quan"))
f$van_walraven <- as.numeric(van_walraven_from_comorbid(icd10_comorbid_quan_elix(ic, return_df = TRUE)))

ic <- ic %>% left_join(f)
ic <- ic %>% left_join(icd %>% select(IDm, alc_status))

sapply(f[,2:4], tabna)

ic %>% group_by(charl_index) %>%
 summarise (n = n(), tot_perc = n/nrow(ic),
 alc_perc = mean(as.numeric(alc_status))*100)

 ic %>% group_by(quan_index) %>%
 summarise (n = n(), tot_perc = n/nrow(ic),
 alc_perc = mean(as.numeric(alc_status))*100)

 ic %>% group_by(van_walraven) %>%
 summarise (n = n(), tot_perc = n/nrow(ic),
 alc_perc = mean(as.numeric(alc_status))*100) %>% print(n=50)

ic$charl_index <- factor(ic$charl_index)
ic$quan_index <- factor(ic$quan_index)

#the way convert numerical factor to numeric
ic <- ic %>% mutate(charl_index_grp = ifelse(as.numeric(levels(charl_index))[charl_index] > 3,
 "Oth", as.numeric(levels(charl_index))[charl_index]) ) %>%
 mutate(charl_index_grp = factor(charl_index_grp))
ic <- ic %>% mutate(charl_index_bin = ifelse(charl_index %in% c(0,1) , "0and1", "More") ) %>%
mutate(charl_index_bin = factor(charl_index_bin))

ic <- ic %>% mutate(quan_index_grp = ifelse(as.numeric(levels(quan_index))[quan_index] > 3,
 "Oth", as.numeric(levels(quan_index))[quan_index]) ) %>%
 mutate(quan_index_grp = factor(quan_index_grp))
ic <- ic %>% mutate(quan_index_bin = ifelse(quan_index %in% c(0,1) , "0and1", "More") ) %>%
mutate(quan_index_bin = factor(quan_index_bin))

str(ic)

result <- double()
result <- add_result("charl_index" , ic, result)
result <- add_result("quan_index" , ic, result)
result <- add_result("van_walraven" , ic, result) #as numeric, too many levels, maybe join later
result <- add_result("charl_index_grp" , ic, result)
result <- add_result("charl_index_bin" , ic, result)
result <- add_result("quan_index_grp" , ic, result)
result <- add_result("quan_index_bin" , ic, result)
result
write.csv(result, "./ICD10 codes/comorb_index_univ_results.csv")

###############Engineer more Features

## Using 1L code of main ICD10 diagnosis
ic$mcode1L <- substr(ic$dx10code1, 1,1)

# S physical injury
# F mental, bahivoural,etc
# Z factors
# M musculoskeleton

ic <- ic %>% mutate(main_PhysInj_1L = ifelse(mcode1L == "S", 1, 0),
main_MentBehav_1L = ifelse(mcode1L == "F", 1, 0),
main_Zfactors_1L = ifelse(mcode1L == "Z", 1, 0),
main_MusclSkelt_1L = ifelse(mcode1L == "M", 1, 0))
#turn to factor
ic <- ic %>% mutate_at(vars(main_PhysInj_1L:main_MusclSkelt_1L), ~factor(.))

sapply(ic %>% select(main_PhysInj_1L:main_MusclSkelt_1L), tabna)
#Univariate odds
result <- double()
result <- add_result("main_PhysInj_1L" , ic, result)
result <- add_result("main_MentBehav_1L" , ic, result)
result <- add_result("main_Zfactors_1L" , ic, result)
result <- add_result("main_MusclSkelt_1L" , ic, result)
result

## Using 1L code of main ICD10 diagnosis
ic$mcode3L <- substr(ic$dx10code1, 1,3)

#R64 Cachexia
#F05 Delirium-Frailty
#W01-06-10-18-19 FALL-Frailty
# Add more later?
fall_frial <- c("W01", "W06", "W10","W18", "W19")
ic %>% filter(mcode3L == "R64") %>% nrow()

ic <- ic %>% mutate(main_Cachx_3L = ifelse(mcode3L == "R64", 1, 0),
main_Frail_Del_3L = ifelse(mcode3L == "F05", 1, 0),
main_Frail_Fal_3L = ifelse(mcode3L %in% fall_frial, 1, 0))
#turn to factor
ic <- ic %>% mutate_at(vars(main_Cachx_3L:main_Frail_Fal_3L), ~factor(.))

result <- add_result("main_Cachx_3L" , ic, result)
result <- add_result("main_Frail_Del_3L" , ic, result)
result <- add_result("main_Frail_Fal_3L" , ic, result) # No W in data, wierd
result

###Analayzing W code in all other dx10codes

# ic %>% filter_at(vars(dx10code1:dx10code10), any_vars(str_starts(.,"W"))) %>%
# select(IDm , dx10code1:dx10code10) %>% head(50)

#number of people containing at least one W code in all 10 codes
# ic %>% filter_at(vars(dx10code1:dx10code10), any_vars(str_starts(.,"W"))) %>%
# select(IDm , dx10code1:dx10code10) %>% nrow()
#now cheking for frailty codes
# ic %>% filter_at(vars(dx10code1:dx10code10), any_vars(substr(.,1,3) %in% fall_frial)) %>%
# select(IDm , dx10code1:dx10code10) %>% head(50)

# ic %>% filter_at(vars(dx10code1:dx10code10), any_vars(substr(.,1,3) %in% fall_frial)) %>%
# select(IDm , dx10code1:dx10code10) %>% nrow()

#Using frailty codes on all 10 codes to construct the dummy variables
##FALL
fal_ls <- ic %>% filter_at(vars(dx10code1:dx10code10), any_vars(substr(.,1,3) %in% fall_frial)) %>%
select(IDm , dx10code1:dx10code10) %>% .$IDm

ic <- ic %>% mutate(all_Frail_Fal_3L = ifelse(IDm %in% fal_ls, 1, 0))
## Delirium
del_ls <- ic %>% filter_at(vars(dx10code1:dx10code10),
 any_vars(substr(.,1,3) == "F05")) %>%
select(IDm , dx10code1:dx10code10) %>% .$IDm

ic <- ic %>% mutate(all_Frail_Del_3L = ifelse(IDm %in% del_ls, 1, 0))
## Cachexia
cach_ls <- ic %>% filter_at(vars(dx10code1:dx10code10),
 any_vars(substr(.,1,3) == "R64")) %>%
select(IDm , dx10code1:dx10code10) %>% .$IDm

ic <- ic %>% mutate(all_Cachx_3L = ifelse(IDm %in% cach_ls, 1, 0))
#turn to factor
ic <- ic %>%
 mutate_at(vars(all_Frail_Fal_3L, all_Frail_Del_3L, all_Cachx_3L), ~factor(.))

###
result <- add_result("all_Cachx_3L" , ic, result)
result <- add_result("all_Frail_Del_3L" , ic, result)
result <- add_result("all_Frail_Fal_3L" , ic, result)
result

write.csv(result, "./ICD10 codes/icd10_varExtract_univ_results.csv")

###Save created subsets
str(ic)

ic %>% select(IDm, charl_index, quan_index, charl_index_bin, charl_index_grp,
quan_index, quan_index_bin, quan_index_grp, main_PhysInj_1L:main_MusclSkelt_1L,
main_Cachx_3L:all_Cachx_3L) %>% write.csv("./ICD10 codes/icd10_vars.csv", row.names=F)


#########
# Rafael Aparecido Martins Frade - Central European University
# Replication code for paper:
#     Does payroll tax relief increase employment level? Evidence from Brazil - 2020
# This script runs the regressions
#########

setwd('/home/rafael/arquivos/mestrado/2_term/metrics_II/paper/dataset')
set.seed(123456)
require(data.table)
library(stargazer)

# Descriptive table
firmsNS2010 = fread('firms2010.csv')
firmsNS2011 = fread('firms2011.csv')
firmsNS2012 = fread('firms2012.csv')
firmsNS2013 = fread('firms2013.csv')

summary(firmsNS2013[eligible == 1 & Ind.Simples == 0]$Qtd.Vínculos.CLT)
summary(firmsNS2013[eligible == 0 & Ind.Simples == 0]$Qtd.Vínculos.CLT)
summary(firmsNS2013[eligible == 1 & Ind.Simples == 1]$Qtd.Vínculos.CLT)
summary(firmsNS2013[eligible == 0 & Ind.Simples == 1]$Qtd.Vínculos.CLT)

firmsNS2013[eligible == 1 & Ind.Simples == 0, .N]
firmsNS2013[eligible == 0 & Ind.Simples == 0, .N]
firmsNS2013[eligible == 1 & Ind.Simples == 1, .N]
firmsNS2013[eligible == 0 & Ind.Simples == 1, .N]

# Non-SIMPLES
firmsNS2010 = fread('firms2010.csv')[Ind.Simples == 0]
firmsNS2011 = fread('firms2011.csv')[Ind.Simples == 0]
firmsNS2012 = fread('firms2012.csv')[Ind.Simples == 0]
firmsNS2013 = fread('firms2013.csv')[Ind.Simples == 0]

firmsNS2012$year = 1
firmsModel = rbind(firmsNS2010, firmsNS2011, firmsNS2012)
firmsModel$treated = firmsModel$eligible
modelNS12 = lm(log(Qtd.Vínculos.CLT) ~ year*treated, data = firmsModel)

firmsNS2012$year = 0
firmsModel = rbind(firmsNS2010, firmsNS2011, firmsNS2012, firmsNS2013)
firmsModel$treated = firmsModel$eligible
modelNS13 = lm(log(Qtd.Vínculos.CLT) ~ year*treated, data = firmsModel)

summary(firmsModel)

teste[eligible == 1 & Ind.Simples == 1, .N]
teste[eligible == 1 & Ind.Simples == 0, .N]
teste[eligible == 0 & Ind.Simples == 1, .N]
teste[eligible == 0 & Ind.Simples == 0, .N]

#SIMPLES
firmsS2010 = fread('firms2010.csv')[Qtd.Vínculos.CLT <= 100]
firmsS2011 = fread('firms2011.csv')[Qtd.Vínculos.CLT <= 100]
firmsS2012 = fread('firms2012.csv')[Qtd.Vínculos.CLT <= 100]
firmsS2013 = fread('firms2013.csv')[Qtd.Vínculos.CLT <= 100]

firmsS2012$year = 1
firmsModel = rbind(firmsS2010, firmsS2011, firmsS2012)
firmsModel$treated = as.numeric(!firmsModel$Ind.Simples)
modelSNS12 = lm(log(Qtd.Vínculos.CLT) ~ year*treated, data = firmsModel[eligible == 1])

firmsS2012$year = 0
firmsModel = rbind(firmsS2010, firmsS2011, firmsS2012, firmsS2013)
firmsModel$treated = as.numeric(!firmsModel$Ind.Simples)
modelSNS13 = lm(log(Qtd.Vínculos.CLT) ~ year*treated, data = firmsModel[eligible == 1])

stargazer(modelSNS12, modelSNS13,modelNS12, modelNS13,
          title = "Diff in Diff results",
          dep.var.labels = "Formal Jobs",
          column.separate = 1,
          column.labels = c("SIMPLES 12", "SIMPLES 13", "Standard 12", "Standard 13"),
          covariate.labels = c(
            "Year", "Treated", "Year.Treated (ATE)", "Intercept"),
          digits = 2,
          df = FALSE)

data2011 = fread('firms2011.csv')
groups2011NS = data2011[eligible == 1 & Ind.Simples == 0 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]
groups2011Simples = data2011[eligible == 1 & Ind.Simples == 1 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]

data2012 = fread('firms2012.csv')
data2012$year = 1
groups2012NS = data2012[eligible == 1 & Ind.Simples == 0 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]
groups2012Simples = data2012[eligible == 1 & Ind.Simples == 1 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]

data2013 = fread('firms2013.csv')
groups2013NS = data2013[eligible == 1 & Ind.Simples == 0 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]
groups2013Simples = data2013[eligible == 1 & Ind.Simples == 1 ,sum(Qtd.Vínculos.CLT), by = CNAE.2.0.Classe]

differenceFirmsSimples1211 = numeric(0)
differenceFirmsNSimples1211 = numeric(0)

differenceFirmsSimples1312 = numeric(0)
differenceFirmsNSimples1312 = numeric(0)

for (index in 1:154) {

  cnae = groups2012Simples[index]$CNAE.2.0.Classe

  firmsSimples2011 = groups2011Simples[CNAE.2.0.Classe == cnae]$V1
  firmsSimples2012 = groups2012Simples[CNAE.2.0.Classe == cnae]$V1
  firmsSimples2013 = groups2013Simples[CNAE.2.0.Classe == cnae]$V1

  firmsNSimples2011 = groups2011NS[CNAE.2.0.Classe == cnae]$V1
  firmsNSimples2012 = groups2012NS[CNAE.2.0.Classe == cnae]$V1
  firmsNSimples2013 = groups2013NS[CNAE.2.0.Classe == cnae]$V1

  differenceFirmsSimples1211[index] = firmsSimples2012 - firmsSimples2011
  differenceFirmsNSimples1211[index] = firmsNSimples2012 - firmsNSimples2011

  differenceFirmsSimples1312[index] = firmsSimples2013 - firmsSimples2012
  differenceFirmsNSimples1312[index] = firmsNSimples2013 - firmsNSimples2012
  print(paste(cnae, ))
}
$Qtd.Vínculos.CLT
printQtt = function(cnae, diffS1211, diffNS1211, diffS1312, diffNS1312) {

}

sum(differenceFirmsNSimples1211[1:152])
sum(differenceFirmsSimples1211[1:152])
sum(differenceFirmsNSimples1312[1:151])
sum(differenceFirmsSimples1312[1:151])

diffNS1211 = data.frame(jobs = differenceFirmsNSimples1211, year = 0, simples = 0)
diffS1211 =  data.frame(jobs = differenceFirmsSimples1211, year = 0, simples = 1)

diffNS1312 = data.frame(jobs = differenceFirmsNSimples1312, year = 1, simples = 0)
diffS1312 =  data.frame(jobs = differenceFirmsSimples1312, year = 1, simples = 1)

diffData = rbind(diffNS1211, diffS1211, diffNS1312, diffS1312)
diffData$eligible = as.numeric(!diffData$simples)
diffData$year_treated = diffData$treated*diffData$year

modelDiff = lm(log(jobs) ~ eligible*year, data = diffData)
summary(modelDiff)


make.auc.plot.jpg<-function(ma.reduced,pred,plotname,modelname,test.split=FALSE,thresh=NULL,train=NULL,train.pred=NULL,opt.methods=2,weight,out){

      if(is.null(weight)) weight=rep(1,times=dim(ma.reduced)[1])
    auc.data <- data.frame(ID=1:nrow(ma.reduced),pres.abs=ma.reduced[,1],pred=pred)
    p.bar <- sum(auc.data$pres.abs * weight) / sum(weight)
    n.pres <- sum(auc.data$pres.abs)
    n.abs <- nrow(auc.data)-n.pres

    null.dev<-calc.dev(auc.data$pres.abs, rep(p.bar,times=length(auc.data$pres.abs)), weight, family="binomial")$deviance*nrow(ma.reduced)
    dev.fit<-calc.dev(auc.data$pres.abs, pred, weight, family="binomial")$deviance*nrow(ma.reduced)
    dev.exp <- null.dev - dev.fit
    pct.dev.exp <- dev.exp/null.dev*100
   correlation<-cor(auc.data$pres.abs,pred)

    if(is.null(thresh)){
    thresh <- as.numeric(optimal.thresholds(auc.data,opt.methods=opt.methods))[2]}
    auc.fit <- auc(auc.data,st.dev=T)
    if(test.split==TRUE){

      jpeg(file=plotname)
      d<-data.frame(ID=1:nrow(train),pres.abs=train[,1],pred=train.pred)
      thresh<- as.numeric(optimal.thresholds(d,opt.methods=opt.methods))[2]
      TestTrainRocPlot(DATA=d,opt.thresholds=thresh,add.legend=FALSE,lwd=2)
      TestTrainRocPlot(auc.data,model.names=modelname,opt.thresholds=thresh,add.roc=TRUE,line.type=2,color="red",add.legend=FALSE)
      legend(x=.66,y=.2,c("Training Split","Testing Split"),lty=2,col=c("black","red"),lwd=2)
      graphics.off()} else {
      jpeg(file=plotname)
        TestTrainRocPlot(auc.data,model.names=modelname,opt.thresholds=thresh)
        graphics.off()

      }

    cmx <- cmx(auc.data,threshold=thresh)
    PCC <- pcc(cmx,st.dev=F)*100
    SENS <- sensitivity(cmx,st.dev=F)
    SPEC <- specificity(cmx,st.dev=F)
    KAPPA <- Kappa(cmx,st.dev=F)
    TSS <- SENS+SPEC-1
      response<-ma.reduced$response

    capture.output(cat("\n\n============================================================",
                        "\n\nEvaluation Statistics"),file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)
          if(!is.null(out$dat$ma$ma.test))
                        capture.output(cat(" applied to",ifelse(!test.split,"train","test"), "split:\n",sep=" "),
                        file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)
                      capture.output(cat( "\n",
                       "\n\t Correlation Coefficient      : ",cor.test(pred,response)$estimate,
                       "\n\t NULL Deviance                : ",null.dev,
                       "\n\t Fit Deviance                 : ",dev.fit,
                       "\n\t Explained Deviance           : ",dev.exp,
                       "\n\t Percent Deviance Explained   : ",pct.dev.exp,
                       file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE))

                           capture.output(cat(
                             "\n\n  Threshold Methods based on", switch(opt.methods,
                            "1"=".5 threshold",
                            "2"="Sens=Spec",
                            "3"="maximize (sensitivity+specificity)/2",
                            "4"="maximize Kappa",
                            "5"="maximize percent correctly classified",
                            "6"="predicted prevalence=observed prevalence",
                            "7"="threshold=observed prevalence",
                            "8"="mean predicted probability",
                            "9"="minimize distance between ROC plot and (0,1)",
                            ),
                            "\n\t Threshold                    : ",
                            thresh,
                            "\n\n\t Confusion Matrix: \n\n"),
                            print.table(cmx),
                       cat("\n\t AUC                          : ",auc.fit[1,1],
                       "\n\t Percent Correctly Classified : ",PCC,
                       "\n\t Sensitivity                  : ",SENS,
                       "\n\t Specificity                  : ",SPEC,
                       "\n\t Kappa                        : ",KAPPA,
                       "\n\t True Skill Statistic         : ",TSS,"\n"),
                       file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE)

                       last.dir<-strsplit(out$input$output.dir,split="\\\\")
                        parent<-sub(paste("\\\\",last.dir[[1]][length(last.dir[[1]])],sep=""),"",out$input$output.dir)

                         if(!is.null(out$dat$ma$ma.test)) compile.out<-paste(parent,"AppendedOutputTestTrain.csv",sep="/")
                          else compile.out<-paste(parent,"AppendedOutput.csv",sep="/")

                       x=data.frame(cbind(c("Correlation Coefficient","Percent Deviance Explained","Percent Correctly Classified","Sensitivity","Specificity"),
                            c(as.vector(cor.test(pred,response)$estimate),pct.dev.exp,PCC,SENS,SPEC)))

                        Header<-cbind(c("","Original Field Data","Field Data Template","PARC Output Folder","PARC Template","Covariate Selection Name",""),
                            c(last.dir[[1]][length(last.dir[[1]])],
                            out$dat$ma$input$OrigFieldData,out$dat$ma$input$FieldDataTemp,out$dat$ma$input$ParcOutputFolder,
                            out$dat$ma$input$ParcTemplate,ifelse(length(out$dat$ma$input$CovSelectName)==0,"NONE",out$dat$ma$input$CovSelectName),""))
                       Header.Length<-nrow(Header)
                       Parm.Len<-nrow(x)

             #Very first time through
             if(file.access(compile.out,mode=0)==-1){
                  #A more complex than necessary way of writing a csv with several header lines
                  write.table(Header,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,sep=",")
                   if(!is.null(out$dat$ma$ma.test))
                   write.table(cbind("","Train Split"),file=compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=",")
                  write.table(x,file=compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=",")
                      } else {
                      input<-read.table(compile.out,fill=TRUE,sep=",")
                      Orig.Header<-input[1:Header.Length,]

                      if(!is.null(out$dat$ma$ma.test)){
                              Train.x<-input[(Header.Length+2):(Header.Length+Parm.Len+1),]
                              Orig.Train<-input[(Header.Length+1),]

                              if(nrow(input)>15){
                                 Test.x<-input[(Header.Length+Parm.Len+4):nrow(input),]
                                 Orig.Test<-input[(Header.Length+Parm.Len+2):(Header.Length+Parm.Len+3),]
                                  if(test.split){
                                        Test.x[,ncol(Test.x)]<-x[,2]
                                         class(Orig.Test[,ncol(Orig.Test)])="character"
                                        Orig.Test[1,ncol(Orig.Test)]<-""
                                        Orig.Test[2,ncol(Orig.Test)]<-"Test Split"
                                        } else{
                                        Orig.Header<-cbind(Orig.Header,Header[,2])
                                        Train.x<-cbind(Train.x,x[,2])
                                        Orig.Train<-cbind(Orig.Train,"Train Split")
                                        }
                                } else{
                                 Orig.Test=rbind(c("",""),cbind("","Test Split"))
                                 Test.x=x
                                }

                              temp<-try(write.table(Orig.Header,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,sep=","),silent=TRUE)

                              while(class(temp)=="try-error"){
                                  modalDialog("","Please Close the AppendedOutput.exe\ so that R can write to it then press ok to continue ","")
                                  temp<-try(write.table(Orig.Header,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,sep=","),silent=TRUE)
                              }

                              try(write.table(Orig.Train,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=","))
                              try(write.table(Train.x,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=","))
                              try(write.table(Orig.Test,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=","))
                              try(write.table(Test.x,file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=","))
                          }  else{

                      Orig.x<-input[(Header.Length+1):nrow(input),]
                      temp<-try(write.table(cbind(Orig.Header,Header[,2]),file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,sep=","),silent=TRUE)
                       while(class(temp)=="try-error"){
                                  modalDialog("","Please Close the AppendedOutput.exe\ so that R can write to it then press ok to continue ","")
                                  temp<-try(write.table(cbind(Orig.Header,Header[,2]),file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,sep=","),silent=TRUE)
                              }

                      try(write.table(cbind(Orig.x,x[,2]),file =compile.out,row.names=FALSE,col.names=FALSE,quote=FALSE,append=TRUE,sep=","))
                      }}

    return(list(thresh=thresh,cmx=cmx,null.dev=null.dev,dev.fit=dev.fit,dev.exp=dev.exp,pct.dev.exp=pct.dev.exp,auc=auc.fit[1,1],auc.sd=auc.fit[1,2],
        plotname=plotname,pcc=PCC,sens=SENS,spec=SPEC,kappa=KAPPA,tss=TSS,correlation=correlation))
}

make.poisson.jpg<-function(ma.reduced,pred,plotname,modelname,test.split=FALSE,thresh=NULL,train=NULL,train.pred=NULL,weight,train.weight=NULL,out){

    pois.data <- data.frame(ID=1:nrow(ma.reduced),pres.abs=ma.reduced[,1],pred=pred)
    p.bar <- sum(pois.data$pres.abs * weight) / sum(weight)
    n.pres <- sum(pois.data$pres.abs>=1)
    n.abs <- nrow(pois.data)-n.pres

    #takes into account potential weights but not offset

    null.dev<-calc.dev(pois.data$pres.abs, rep(p.bar,times=length(pois.data$pres.abs)), weight, family="poisson")$deviance*nrow(ma.reduced)
    dev.fit<-calc.dev(pois.data$pres.abs, pred, weight, family="poisson")$deviance*nrow(ma.reduced)
    dev.exp <- null.dev - dev.fit
    pct.dev.exp <- dev.exp/null.dev*100 #this is the pseudo R^2 using definition in the course notes
    correlation<-cor(pois.data$pres.abs,pred)
    #calibration(pois.data$pres.abs,pred,family="poisson") gbm hasn't implimented this for poisson though elith and leathwich use it, I can't find much
    prediction.error<-sum((pois.data$pres.abs-pred)^2)

    ## ADD Weights and offset?
    #function (y, mu, wt)
    #2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))

   if(test.split==TRUE){
      if(is.null(train.weight)) train.weight=rep(1,times=nrow(train))
        null.dev.train<-calc.dev(train$response, rep(mean(train$response),times=nrow(train)), train.weight, family="poisson")$deviance*nrow(train)
        dev.fit.train<-calc.dev(train$response, train.pred, train.weight, family="poisson")$deviance*nrow(train)
        dev.exp.train <- null.dev.train - dev.fit.train
        pct.dev.exp.train <- dev.exp.train/null.dev.train*100
        correlation.train<-cor(train$response,train.pred)

              jpeg(file=plotname)
           dev.contrib<-calc.dev(pois.data$pres.abs, pred, weight, family="poisson")$dev.cont
              par(mfrow=c(3,2))
              z<-sign(pred-pois.data$pres.abs)*dev.contrib
              z.range<-max(z)-min(z)
              z.lim<-c((min(z)-.1*z.range),(max(z)+.1*z.range))
              breaks<-quantile(z, probs = seq(0, .95,length=25))
              a<-outer(z,breaks,"<")
              res.mag<-apply(a,1,sum)
              plot(out$dat$ma$test.xy,col=beachcolours(heightrange=c(min(res.mag),max(res.mag)),sealevel=mean(res.mag),ncolours=length(table(res.mag)))[res.mag],cex=4,pch=19)
              x<-out$dat$ma$test.xy[,1]
              y<-out$dat$ma$test.xy[,2]
              a<-loess(z~x*y)
              x.lim<-rep(seq(from=min(out$dat$ma$test.xy[,1]),to=max(out$dat$ma$test.xy[,1]),length=100),each=100)
              y.lim<-rep(seq(from=min(out$dat$ma$test.xy[,2]),to=max(out$dat$ma$test.xy[,2]),length=100),times=100)
              z<-predict(a,newdata=cbind("x"=x.lim,"y"=y.lim))
              z[z>z.lim[2]]<-NA
              z[z<z.lim[1]]<-NA
              breaks<-quantile(na.omit(z), probs = seq(0, .95,length=25))
              a<-outer(z,breaks,"<")
              res.mag<-apply(a,1,sum)
              z<-matrix(data=z,ncol=100,nrow=100,byrow=TRUE)
              res.mag<-matrix(data=res.mag,ncol=100,nrow=100,byrow=TRUE)
                 image(x=seq(from=min(x.lim),to=max(x.lim),length=100),y=seq(from=min(y.lim),to=max(y.lim),length=100),
                  z=res.mag,
                  col=beachcolours(heightrange=c(min(na.omit(res.mag)),max(na.omit(res.mag))),sealevel=mean(na.omit(res.mag)),
                  ncolours=length(table(na.omit(res.mag)))),xlab="Latitude",ylab="Longitude",
                  main="Smoothed deviance residuals over space")

                  points(out$dat$ma$train.xy,pch=19,cex=1)
              #plot(unique(x.lim),apply(z,2,sum))
              #plot(unique(y.lim),apply(z,1,sum))

              mod.resids<-residuals(out$mods$final.mod,type="deviance")
              plot(pred,(pois.data$pres.abs-pred),xlab="Predicted Values",ylab="Residuals",main="Residuals vs Fitted")
              panel.smooth(pred,(pois.data$pres.abs-pred))
              plot(pred,sqrt(2*dev.contrib),ylab="sqrt(Std.deviance residuals)",xlab="Predicted Values",main="Scale Location")
              panel.smooth(pred,sqrt(2*dev.contrib))
              qqnorm((sqrt(2*dev.contrib)-mean(sqrt(2*dev.contrib))),ylab="Std.Deviance residuals")
              abline(0,1)

        graphics.off()
        return(list(null.dev=null.dev,dev.fit=dev.fit,dev.exp=dev.exp,pct.dev.exp=pct.dev.exp,correlation=correlation,
          null.dev.train=null.dev.train,dev.fit.train=dev.fit.train,dev.exp.train=dev.exp.train,pct.dev.exp.train=pct.dev.exp.train,correlation.train=correlation.train))

     }else{
     jpeg(file=plotname)

        dev.contrib<-calc.dev(pois.data$pres.abs, pred, weight, family="poisson")$dev.cont
        par(mfrow=c(3,2))

              dev.contrib<-calc.dev(pois.data$pres.abs, pred, weight, family="poisson")$dev.cont
              z<-sign(pred-pois.data$pres.abs)*dev.contrib
              breaks<-quantile(z, probs = seq(0, .95,length=25))
              a<-outer(z,breaks,"<")
              res.mag<-apply(a,1,sum)
              plot(out$dat$ma$train.xy,col=heat.colors(24)[res.mag],cex=4,pch=19)
              x<-out$dat$ma$train.xy[,1]
              y<-out$dat$ma$train.xy[,2]
              a<-loess(z~x*y)
              x.lim<-rep(seq(from=min(out$dat$ma$train.xy[,1]),to=max(out$dat$ma$train.xy[,1]),length=100),each=100)
              y.lim<-rep(seq(from=min(out$dat$ma$train.xy[,2]),to=max(out$dat$ma$train.xy[,2]),length=100),times=100)
              z<-predict(a,newdata=cbind("x"=x.lim,"y"=y.lim))
              breaks<-quantile(z, probs = seq(0, .95,length=25))
              a<-outer(z,breaks,"<")
              res.mag<-apply(a,1,sum)
              z<-matrix(data=z,ncol=100,nrow=100,byrow=TRUE)
              res.mag<-matrix(data=res.mag,ncol=100,nrow=100,byrow=TRUE)

              image(x=seq(from=min(x.lim),to=max(x.lim),length=100),y=seq(from=min(y.lim),to=max(y.lim),length=100),
                  z=res.mag,
                  col=beachcolours(heightrange=c(min(res.mag),max(res.mag)),sealevel=mean(res.mag),ncolours=length(table(res.mag))),xlab="Latitude",ylab="Longitude",
                  main="Smoothed deviance residuals over space")
              points(out$dat$ma$train.xy,pch=19)
              #plot(unique(x.lim),apply(z,2,sum))
              #plot(unique(y.lim),apply(z,1,sum))

              mod.resids<-residuals(out$mods$final.mod,type="deviance")
              plot(pred,(pois.data$pres.abs-pred),xlab="Predicted Values",ylab="Residuals",main="Residuals vs Fitted")
              panel.smooth(pred,(pois.data$pres.abs-pred))
              plot(pred,sqrt(2*dev.contrib),ylab="sqrt(Std.deviance residuals)",xlab="Predicted Values",main="Scale Location")
              panel.smooth(pred,sqrt(2*dev.contrib))
              qqnorm((sqrt(2*dev.contrib)-mean(sqrt(2*dev.contrib))),ylab="Std.Deviance residuals")
              abline(0,1)

        graphics.off()

         capture.output(cat("\n\nEvaluation Statistics applied to test split:\n",
                       "\n\t Correlation Coefficient      : ",cor.test(pred,response)$estimate,
                       "\n\t NULL Deviance                : ",auc.output$null.dev,
                       "\n\t Fit Deviance                 : ",auc.output$dev.fit,
                       "\n\t Explained Deviance           : ",auc.output$dev.exp,
                       "\n\t Percent Deviance Explained   : ",auc.output$pct.dev.exp,
                       file=paste(out$dat$bname,"_output.txt",sep=""),append=TRUE))

        return(list(null.dev=null.dev,dev.fit=dev.fit,dev.exp=dev.exp,pct.dev.exp=pct.dev.exp,correlation=correlation))
        }
}

##############################################################################
EvaluationStats<-function(out,thresh,train,train.pred,opt.methods=opt.methods){
    response<-out$dat$ma$ma.test[,1]

     if(out$input$model.source.file=="rf.r") {pred<-tweak.p(as.vector(predict(out$mods$final.mod,newdata=out$dat$ma$ma.test[,-1],type="prob")[,2]))
      modelname="Random Forest"
     }

    if(out$input$model.source.file=="mars.r") {pred<-mars.predict(out$mods$final.mod,out$dat$ma$ma.test)$prediction[,1]
         modelname="MARS"
    }

    if(out$input$model.source.file=="glm.r")  {pred=glm.predict(out$mods$final.mod,out$dat$ma$ma.test)
        modelname="GLM"
    }

    if(out$input$model.source.file=="brt.r") {pred=predict.gbm(out$mods$final.mod,out$dat$ma$ma.test,out$mods$final.mod$target.trees,type="response")
       modelname="BRT"
      }

  ifelse(out$input$model.family!="poisson",
                  auc.output<-make.auc.plot.jpg(out$dat$ma$ma.test,pred=pred,plotname=paste(out$dat$bname,"_auc_plot.jpg",sep=""),
                      modelname=modelname,test.split=TRUE,thresh=thresh,train=train,train.pred,opt.methods=opt.methods,weight=out$dat$ma$test.weights,out=out),
                  auc.output<-make.poisson.jpg(out$dat$ma$ma.test,pred=pred,plotname=paste(out$dat$bname,"_auc_plot.jpg",sep=""),
                      modelname=modelname,test.split=TRUE,thresh=thresh,train=train,train.pred,weight=out$dat$ma$test.weights,out=out))

                out$mods$auc.output<-auc.output

}

"calibration" <-
      function(obs, preds, family = "binomial")
      {
      #
      # j elith/j leathwick 17th March 2005
      # calculates calibration statistics for either binomial or count data
      # but the family argument must be specified for the latter
      # a conditional test for the latter will catch most failures to specify
      # the family
      #

      if (family == "bernoulli") family <- "binomial"
      pred.range <- max(preds) - min(preds)
      if(pred.range > 1.2 & family == "binomial") {
      print(paste("range of response variable is ", round(pred.range, 2)), sep = "", quote = F)
      print("check family specification", quote = F)
      return()
      }
      if(family == "binomial") {
      pred <- preds + 1e-005
      pred[pred >= 1] <- 0.99999
      mod <- glm(obs ~ log((pred)/(1 - (pred))), family = binomial)
      lp <- log((pred)/(1 - (pred)))
      a0b1 <- glm(obs ~ offset(lp) - 1, family = binomial)
      miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
      ab1 <- glm(obs ~ offset(lp), family = binomial)
      miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
      miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
      }
      if(family == "poisson") {
      mod <- glm(obs ~ log(preds), family = poisson)
      lp <- log(preds)
      a0b1 <- glm(obs ~ offset(lp) - 1, family = poisson)
      miller1 <- 1 - pchisq(a0b1$deviance - mod$deviance, 2)
      ab1 <- glm(obs ~ offset(lp), family = poisson)
      miller2 <- 1 - pchisq(a0b1$deviance - ab1$deviance, 1)
      miller3 <- 1 - pchisq(ab1$deviance - mod$deviance, 1)
      }
      calibration.result <- c(mod$coef, miller1, miller2, miller3)
      names(calibration.result) <- c("intercept", "slope", "testa0b1", "testa0|b1", "testb1|a")
      return(calibration.result)
}

"calc.dev" <-
        function(obs.values, fitted.values, weights = rep(1,length(obs.values)), family="binomial", calc.mean = TRUE)
        {
        # j. leathwick/j. elith
        #
        # version 2.1 - 5th Sept 2005
        #
        # function to calculate deviance given two vectors of raw and fitted values
        # requires a family argument which is set to binomial by default
        #
        #

        if (length(obs.values) != length(fitted.values))
           stop("observations and predictions must be of equal length")

        y_i <- obs.values

        u_i <- fitted.values

        if (family == "binomial" | family == "bernoulli") {

           deviance.contribs <- (y_i * log(u_i)) + ((1-y_i) * log(1 - u_i))
           deviance <- -2 * sum(deviance.contribs * weights)

        }

        if (family == "poisson" | family == "Poisson") {

            deviance.contribs <- ifelse(y_i == 0, 0, (y_i * log(y_i/u_i))) - (y_i - u_i)
            deviance <- 2 * sum(deviance.contribs * weights)

        }

        if (family == "laplace") {
            deviance <- sum(abs(y_i - u_i))
            }

        if (family == "gaussian") {
            deviance <- sum((y_i - u_i) * (y_i - u_i))
            }

        if (calc.mean) deviance <- deviance/length(obs.values)
        dev=list(deviance=deviance,dev.cont=deviance.contribs)
        return(dev)

}

beachcolours<-function (heightrange, sealevel = 0, monochrome = FALSE, ncolours = if (monochrome) 16 else 64)
{
#this function was robbed from the spatstat library internals
    if (monochrome)
        return(grey(seq(0, 1, length = ncolours)))
    stopifnot(is.numeric(heightrange) && length(heightrange) ==
        2)
    stopifnot(all(is.finite(heightrange)))
    depths <- heightrange[1]
    peaks <- heightrange[2]
    dv <- diff(heightrange)/(ncolours - 1)
    epsilon <- dv/2
    lowtide <- max(sealevel - epsilon, depths)
    hightide <- min(sealevel + epsilon, peaks)
    countbetween <- function(a, b, delta) {
        max(0, round((b - a)/delta))
    }
    nsea <- countbetween(depths, lowtide, dv)
    nbeach <- countbetween(lowtide, hightide, dv)
    nland <- countbetween(hightide, peaks, dv)
    colours <- character(0)
    if (nsea > 0)
        colours <- rev(rainbow(nsea, start = 3/6, end = 4/6))
    if (nbeach > 0)
        colours <- c(colours, rev(rainbow(nbeach, start = 3/12,
            end = 5/12)))
    if (nland > 0)
        colours <- c(colours, rev(rainbow(nland, start = 0, end = 1/6)))
    return(colours)
}


library(gplots)
library(RSvgDevice)

matrix.axes <- function(data) {
    a <- ((1:48)-1) / 48
    x <- (1:48) - 1
    axis(side=1, at=a, labels=x, las=1)
    axis(side=2, at=a, labels=x, las=3);
}

plot_grid <- function (arch, test) {
  inp <- as.matrix(read.table(sprintf("%s.%s.lat.csv", arch, test)))
  ncols <- 11
  col <- colorpanel(ncols, "white", "grey10")
  r <- range(inp) # autoscale
  t <- sprintf("%s %s (range %f)", arch, test, max(inp) - min(inp))
  filled.contour(inp, zlim=r, plot.axes=matrix.axes(inp), nlevels=ncols, title=title(t))
}

for (arch in c("48native", "48xenpin", "48xennopin")) {
  for (test in c("mempipe_lat", "pipe_lat", "unix_lat", "tcp_lat")) {
    f <- sprintf("latency-%s-%s.pdf", arch, test)
    pdf(file=f)
    plot_grid(arch, test)
  }
}