# -----------------------------------------------------------------------------
# PROJECT:
#    Evaluating the structure of the communities of the estuary
#    and gulf of St.Lawrence
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# STEP:
#   2. Analysis iteratively removing information from the catalog
# -----------------------------------------------------------------------------

# Evaluating algorithm accuracy ~ # of taxa in the catalog
# -----------------------------------------------------------------------------
# FILES:
#   RData <- file = "RData/Tanimoto_analysis.RData" XXX adjust name with type of analysis
#   Script  <- file = "Script/2-1-Tanomoto_analysis.r"
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# PARAMETERS:

# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# SCRIPT
# -----------------------------------------------------------------------------
load("./RData/interactions_source.RData")
filename1 = 'catalog_predictions2'
filename2 = 'catalog_predictions3'
filename3 = 'catalog_predictions4'

catalog_predictions0 <- catalog_predictions(comm_id = TRUE,
                                            community = "Kortsch2015_arctic",
                                            percent_remove = 0,
                                            nb_iter = 1,
                                            K.values = 8,
                                            MW = 1,
                                            WT =  c(0.5,1),
                                            minimum_threshold = 0.3,
                                            filename = 'catalog_predictions0')

catalog_predictions1 <- catalog_predictions(comm_id = TRUE,
                                            community = "Kortsch2015_arctic",
                                            percent_remove = 100,
                                            nb_iter = 1,
                                            K.values = 8,
                                            MW = 1,
                                            WT =  c(0.5,1),
                                            minimum_threshold = 0.3,
                                            filename = 'catalog_predictions1')

catalog_predictions2 <- catalog_predictions(comm_id = TRUE,
                                            community = "Kortsch2015_arctic",
                                            percent_remove = c(10,20,40),
                                            nb_iter = 50,
                                            K.values = 8,
                                            MW = 1,
                                            WT =  c(0.5,1),
                                            minimum_threshold = 0.3,
                                            filename = filename1)

catalog_predictions3 <- catalog_predictions(comm_id = TRUE,
                                            community = "Kortsch2015_arctic",
                                            percent_remove = c(30,50,70),
                                            nb_iter = 50,
                                            K.values = 8,
                                            MW = 1,
                                            WT =  c(0.5,1),
                                            minimum_threshold = 0.3,
                                            filename = filename2)

catalog_predictions4 <- catalog_predictions(comm_id = TRUE,
                                            community = "Kortsch2015_arctic",
                                            percent_remove = c(60,80,90),
                                            nb_iter = 50,
                                            K.values = 8,
                                            MW = 1,
                                            WT =  c(0.5,1),
                                            minimum_threshold = 0.3,
                                            filename = filename3)

# Catalog vs predictions
load("./Analyses/catalog_predictions0.RData")
catalog_predictions0 <- Tanimoto_analysis
load("./Analyses/catalog_predictions1.RData")
catalog_predictions1 <- Tanimoto_analysis
load("./Analyses/catalog_predictions2.RData")
catalog_predictions2 <- Tanimoto_analysis
load("./Analyses/catalog_predictions3.RData")
catalog_predictions3 <- Tanimoto_analysis
load("./Analyses/catalog_predictions4.RData")
catalog_predictions4 <- Tanimoto_analysis

accuracy <- accuracy0 <- accuracy1 <- accuracy2 <- accuracy3 <- vector('list', 3)
names(accuracy) <- names(accuracy0) <- names(accuracy1) <- names(accuracy2) <- c('Catalog', 'Predict', 'Algorithm')
accuracy[[1]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions2, empirical.only = TRUE)
accuracy[[2]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions2, predict.only = TRUE)
accuracy[[3]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions2)

accuracy0[[1]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions0, empirical.only = TRUE)
accuracy0[[2]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions0, predict.only = TRUE)
accuracy0[[3]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions0)

accuracy1[[1]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions1, empirical.only = TRUE)
accuracy1[[2]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions1, predict.only = TRUE)
accuracy1[[3]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions1)

accuracy2[[1]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions3, empirical.only = TRUE)
accuracy2[[2]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions3, predict.only = TRUE)
accuracy2[[3]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions3)

accuracy3[[1]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions4, empirical.only = TRUE)
accuracy3[[2]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions4, predict.only = TRUE)
accuracy3[[3]] <- catalog_predictions_accuracy(Tanimoto_analysis = catalog_predictions4)

accuracy[[1]] <- rbind(accuracy[[1]], accuracy0[[1]], accuracy1[[1]], accuracy2[[1]], accuracy3[[1]])
accuracy[[2]] <- rbind(accuracy[[2]], accuracy0[[2]], accuracy1[[2]], accuracy2[[2]], accuracy3[[2]])
accuracy[[3]] <- rbind(accuracy[[3]], accuracy0[[3]], accuracy1[[3]], accuracy2[[3]], accuracy3[[3]])

percent_remove = c(0,10,20,30,40,50,60,70,80,90,100)
nb_iter = 50
K.values = 8
MW = 1
WT =  c(0.5,1)
minimum_threshold = 0.3

nb.pts <- length(percent_remove)

#Figure version 1
pdf(paste('./Article/','catalog_predictions','.pdf',sep=''),width=6,height=8)
j = 14 #'Score'[y]
        eplot(xmin = -1, xmax = 100 + 1, ymax = 3.6)
        par(pch = 21,  xaxs = "i", yaxs = "i", family = "serif")
        col <- c("#FF8822",'#5ED275','#9CCBFF')
        col2 <- c("#FF8822",'#275A31','#0077FF')
        col3 <- c("#FF8822","#449955","#2288FF")

        # Axes
            axis(side = 1, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = -0.05)
            axis(side = 2, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = -1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = -1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = -1)
            axis(side = 3, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = 1.05 + 2.5)
            axis(side = 4, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1)

            abline(h = c(1.125,2.375), col = "black", lty = 2)
            mtext(text = expression('Score'[y]), side = 2, line = 2, at = 1.75, font = 1.5, cex = 1)
            mtext(text = expression(paste("Percent of taxa removed from ", italic(S0), ' (%)')), side = 1, line = 2, at = 50, font = 2, cex = 1)
            mtext(text = seq(0, 100, by = 10), side = 1, line = 0, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            mtext(text = seq(0, 100, by = 10), side = 3, line = -0.5, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            text(x = 5, y = 0.15, labels = 'Catalog', font = 2, cex = 1, col = col3[1], adj = 0)
            text(x = 5, y = 1.40, labels = 'Predictions', font = 2, cex = 1, col = col3[2], adj = 0)
            text(x = 5, y = 2.65, labels = 'Algorithm', font = 2, cex = 1, col = col3[3], adj = 0)

        it <- 0
        for(i in 1:length(accuracy)) {
        # for(i in 2) {
            points(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), j]) + it, cex = 0.5, pch = 1, col = col[i])
            points(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), j]) + it, cex = 0.5, pch = 1, col = col2[i])

            lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), j]) + it), col = col[i])
            lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), j]) + it), col = col2[i])

            if(i == 2 || i == 3) {
                text(x = 90, y = 0.9 + it, labels = expression(paste(italic('w'[t]), ' = 0.5')), col = col[i], font = 1, cex = 0.75)
                text(x = 90, y = 0.8 + it, labels = expression(paste(italic('w'[t]), ' = 1')), col = col2[i], font = 1, cex = 0.75)
            }

            it <- it + 1.25
        } #i
dev.off()

#Figure version 2
pdf(paste('./Article/','catalog_predictions2','.pdf',sep=''),width=6,height=8)
j = 14 #'Score'[y]
        eplot(xmin = -1, xmax = 100 + 1, ymax = 3.6)
        par(pch = 21,  xaxs = "i", yaxs = "i", family = "serif")
        col <- c("#FF8822",'#5ED275','#9CCBFF')
        col2 <- c("#FF8822",'#275A31','#0077FF')
        col3 <- c("#FF8822","#449955","#2288FF")

        # Axes
            axis(side = 1, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = -0.05)
            axis(side = 2, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 3, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = 1.05 + 2.5)
            axis(side = 4, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)

            abline(h = c(1.125,2.375), col = "black", lty = 2)
            mtext(text = expression('Score'[y]), side = 2, line = 2, at = 1.75, font = 1.5, cex = 1)
            mtext(text = expression(paste("Percent of taxa removed from ", italic(N[0]), ' (%)')), side = 1, line = 2, at = 50, font = 2, cex = 1)
            mtext(text = expression(paste("Percent of ",italic(N[1])," taxa in ", italic(N[0]), ' (%)')), side = 3, line = 1, at = 50, font = 2, cex = 1)
            mtext(text = seq(0, 100, by = 10), side = 1, line = 0, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            mtext(text = seq(100, 0, by = -10), side = 3, line = -0.5, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            text(x = 5, y = 0.15, labels = 'Catalog', font = 2, cex = 1, col = col3[1], adj = 0)
            text(x = 5, y = 1.40, labels = 'Predictions', font = 2, cex = 1, col = col3[2], adj = 0)
            text(x = 5, y = 2.65, labels = 'Algorithm', font = 2, cex = 1, col = col3[3], adj = 0)

        it <- 0
        for(i in 1:length(accuracy)) {
            if(i == 2 || i == 3) {
                accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']) + as.numeric(accuracy[[i]][, 'wt']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                accuracy_mean <- accuracy_mean[order(accuracy_mean[,2]), ]
                # hack: we draw arrows but with very special "arrowheads" for error bars

                arrows(seq(0,100,by=10), accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it, seq(0,100,by=10), accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it, length=0.025, angle=90, code=3, col = col[i])
                points(x = seq(0,100,by=10), y = accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1]+it, cex = 0.75, pch = 22, col = col[i])

                arrows(seq(0,100,by=10), accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it, seq(0,100,by=10), accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it, length=0.025, angle=90, code=3, col = col2[i])
                points(x = seq(0,100,by=10), y = accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1]+it, cex = 0.75, pch = 22, col = col2[i])

                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), j]) + it), col = col[i])
                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), 'pc_rm']), y = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), j]) + it), col = col2[i])

                text(x = 90, y = 0.9 + it, labels = expression(paste(italic('w'[t]), ' = 0.5')), col = col[i], font = 1, cex = 0.75)
                text(x = 90, y = 0.8 + it, labels = expression(paste(italic('w'[t]), ' = 1')), col = col2[i], font = 1, cex = 0.75)
                } else {
                    accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                    accuracy_mean <- accuracy_mean[order(accuracy_mean[,1]), ]
                    # hack: we draw arrows but with very special "arrowheads" for error bars

                    arrows(seq(0,100,by=10), accuracy_mean[, 2][,1] - accuracy_mean[, 2][, 2]+it, seq(0,100,by=10), accuracy_mean[, 2][, 1] + accuracy_mean[, 2][, 2]+it, length=0.025, angle=90, code=3, col = col3[i])
                    points(x = seq(0,100,by=10), y = accuracy_mean[, 2][, 1]+it, cex = 0.75, pch = 22, col = col3[i])

                    lines(lowess(x = as.numeric(accuracy[[i]][, 'pc_rm']), y = as.numeric(accuracy[[i]][, j]) + it), col = col3[i])
                }

            it <- it + 1.25
        } #i
dev.off()

# -------------------------------
#Figure version 3 - article couleur
# pdf(paste('./Article/Revisions/','catalog_predictions3','.pdf',sep=''),width=6,height=8)
jpeg(paste('./Article/Revisions/','Figure3','.jpeg',sep=''),width=6,height=8, res = 300, units = 'in')
j = 14 #'Score'[y]
        eplot(xmin = -1, xmax = 100 + 1, ymax = 3.6)
        par(pch = 21,  xaxs = "i", yaxs = "i", family = "serif")
        col <- c("#FF8822",'#5ED275','#9CCBFF')
        col2 <- c("#FF8822",'#275A31','#0077FF')
        col3 <- c("#FF8822","#449955","#2288FF")

        # Axes
            axis(side = 1, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = -0.05)
            axis(side = 2, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 3, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = 1.05 + 2.5)
            axis(side = 4, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)

            abline(h = c(1.125,2.375), col = "black", lty = 2)
            mtext(text = expression('Score'[y]), side = 2, line = 2, at = 1.75, font = 1.5, cex = 1)
            mtext(text = expression(paste("Percent of ",italic(N[1])," taxa in ", italic(N[0]), ' (%)')), side = 1, line = 2, at = 50, font = 2, cex = 1)
            mtext(text = expression(paste("Percent of taxa removed from ", italic(N[0]), ' (%)')), side = 3, line = 1, at = 50, font = 2, cex = 1)
            mtext(text = seq(100, 0, by = -10), side = 1, line = 0, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            mtext(text = seq(0, 100, by = 10), side = 3, line = -0.5, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            text(x = 5, y = 0.85, labels = 'Catalogue', font = 2, cex = 1, col = col3[1], adj = 0)
            text(x = 5, y = 2.10, labels = 'Predictions', font = 2, cex = 1, col = col3[2], adj = 0)
            text(x = 5, y = 3.35, labels = 'Algorithm', font = 2, cex = 1, col = col3[3], adj = 0)

        it <- 0
        for(i in 1:length(accuracy)) {
            if(i == 2 || i == 3) {
                accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']) + as.numeric(accuracy[[i]][, 'wt']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                accuracy_mean <- accuracy_mean[order(accuracy_mean[,2]), ]
                # hack: we draw arrows but with very special "arrowheads" for error bars

                arrows(seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it), length=0.025, angle=90, code=3, col = col[i])
                points(x = seq(0,100,by=10), y = rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1]+it), cex = 0.75, pch = 22, col = col[i])

                arrows(seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it), length=0.025, angle=90, code=3, col = col2[i])
                points(x = seq(0,100,by=10), y = rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1]+it), cex = 0.75, pch = 22, col = col2[i])

                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), 'pc_rm']), y = rev(as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), j]) + it)), col = col[i])
                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), 'pc_rm']), y = rev(as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), j]) + it)), col = col2[i])

                text(x = 90, y = 0.25 + it, labels = expression(paste(italic('w'[t]), ' = 0.5')), col = col[i], font = 1, cex = 0.75)
                text(x = 90, y = 0.15 + it, labels = expression(paste(italic('w'[t]), ' = 1')), col = col2[i], font = 1, cex = 0.75)
                } else {
                    accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                    accuracy_mean <- accuracy_mean[order(accuracy_mean[,1]), ]
                    # hack: we draw arrows but with very special "arrowheads" for error bars

                    arrows(seq(0,100,by=10), rev(accuracy_mean[, 2][,1] - accuracy_mean[, 2][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[, 2][, 1] + accuracy_mean[, 2][, 2]+it), length=0.025, angle=90, code=3, col = col3[i])
                    points(x = seq(0,100,by=10), y = rev(accuracy_mean[, 2][, 1]+it), cex = 0.75, pch = 22, col = col3[i])

                    lines(lowess(x = as.numeric(accuracy[[i]][, 'pc_rm']), y = rev(as.numeric(accuracy[[i]][, j]) + it)), col = col3[i])
                }

            it <- it + 1.25
        } #i
dev.off()

# -------------------------------
#Figure version 4 - article B&W
# pdf(paste('./Article/Revisions/','catalog_predictions3','.pdf',sep=''),width=6,height=8)
jpeg(paste('./Article/Revisions/','Figure3_BW','.jpeg',sep=''),width=6,height=8, res = 300, units = 'in')
j = 14 #'Score'[y]
        eplot(xmin = -1, xmax = 100 + 1, ymax = 3.6)
        par(pch = 21,  xaxs = "i", yaxs = "i", family = "serif")
        col <- c("dark gray",'dark gray','dark gray')
        col2 <- c("black",'black','black')
        col3 <- c("black","black","black")

        # Axes
            axis(side = 1, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = -0.05)
            axis(side = 2, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 2, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = -1, cex.axis = 0.75, font.axis = 1)
            axis(side = 3, at = seq(0, 100, by = 10), labels = FALSE, las = 1, pos = 1.05 + 2.5)
            axis(side = 4, at = seq(0, 1, by = 0.25), labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+1.25, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)
            axis(side = 4, at = seq(0, 1, by = 0.25)+2.5, labels = seq(0, 1, by = 0.25), las = 1, pos = 100 + 1, cex.axis = 0.75, font.axis = 1)

            abline(h = c(1.125,2.375), col = "gray", lty = 2)
            mtext(text = expression('Score'[y]), side = 2, line = 2, at = 1.75, font = 1.5, cex = 1)
            mtext(text = expression(paste("Percent of ",italic(N[1])," taxa in ", italic(N[0]), ' (%)')), side = 1, line = 2, at = 50, font = 2, cex = 1)
            mtext(text = expression(paste("Percent of taxa removed from ", italic(N[0]), ' (%)')), side = 3, line = 1, at = 50, font = 2, cex = 1)
            mtext(text = seq(100, 0, by = -10), side = 1, line = 0, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            mtext(text = seq(0, 100, by = 10), side = 3, line = -0.5, at = seq(0, 100, by = 10), font = 1, cex = 0.75)
            text(x = 5, y = 0.85, labels = 'Catalogue', font = 2, cex = 1, col = col3[1], adj = 0)
            text(x = 5, y = 2.10, labels = 'Predictions', font = 2, cex = 1, col = col3[2], adj = 0)
            text(x = 5, y = 3.35, labels = 'Algorithm', font = 2, cex = 1, col = col3[3], adj = 0)

        it <- 0
        for(i in 1:length(accuracy)) {
            if(i == 2 || i == 3) {
                accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']) + as.numeric(accuracy[[i]][, 'wt']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                accuracy_mean <- accuracy_mean[order(accuracy_mean[,2]), ]
                # hack: we draw arrows but with very special "arrowheads" for error bars

                arrows(seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 2]+it), length=0.025, angle=90, code=3, col = col[i])
                points(x = seq(0,100,by=10), y = rev(accuracy_mean[which(accuracy_mean[, 2] == '0.5'), 3][, 1]+it), cex = 0.75, pch = 22, col = col[i])

                arrows(seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][,1] - accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1] + accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 2]+it), length=0.025, angle=90, code=3, col = col2[i])
                points(x = seq(0,100,by=10), y = rev(accuracy_mean[which(accuracy_mean[, 2] == '1'), 3][, 1]+it), cex = 0.75, pch = 22, col = col2[i])

                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), 'pc_rm']), y = rev(as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '0.5'), j]) + it)), col = col[i], lty = 4)
                lines(lowess(x = as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), 'pc_rm']), y = rev(as.numeric(accuracy[[i]][which(accuracy[[i]][, 'wt'] == '1'), j]) + it)), col = col2[i])

                text(x = 90, y = 0.25 + it, labels = expression(paste(italic('w'[t]), ' = 0.5')), col = col[i], font = 1, cex = 0.75)
                text(x = 90, y = 0.15 + it, labels = expression(paste(italic('w'[t]), ' = 1')), col = col2[i], font = 1, cex = 0.75)
                } else {
                    accuracy_mean <- aggregate(as.numeric(accuracy[[i]][,j]) ~ as.numeric(accuracy[[i]][, 'pc_rm']), data=accuracy[[i]], FUN=function(x) c(mean=mean(x), sd=sd(x)))
                    accuracy_mean <- accuracy_mean[order(accuracy_mean[,1]), ]
                    # hack: we draw arrows but with very special "arrowheads" for error bars

                    arrows(seq(0,100,by=10), rev(accuracy_mean[, 2][,1] - accuracy_mean[, 2][, 2]+it), seq(0,100,by=10), rev(accuracy_mean[, 2][, 1] + accuracy_mean[, 2][, 2]+it), length=0.025, angle=90, code=3, col = col3[i])
                    points(x = seq(0,100,by=10), y = rev(accuracy_mean[, 2][, 1]+it), cex = 0.75, pch = 22, col = col3[i])

                    lines(lowess(x = as.numeric(accuracy[[i]][, 'pc_rm']), y = rev(as.numeric(accuracy[[i]][, j]) + it)), col = col3[i])
                }

            it <- it + 1.25
        } #i
dev.off()


#Similarity matrix as a single functions
similarity_full_algorithm <- function(S0, S1, wt, taxa) {
    # Note: the similarity on the diagonal has to be set to 1 since it's all the same species.
    # taxa is either resource or consumer

    similarity.matrix <- matrix(nrow = nrow(S0), ncol = 1, dimnames = list(S0[, 'taxon'], S1))

    taxonomy <- vector("list",nrow(S0))
    taxon <- vector("list",nrow(S0))

    for(i in 1:nrow(S0)) {
      taxonomy[[i]] <- unlist(strsplit(S0[i, 'taxonomy'], " \\|\\ "))
      if(length(which(taxonomy[[i]] == "NA")) > 0) {
          taxonomy[[i]] <- taxonomy[[i]][-which(taxonomy[[i]] == "NA")]
      }

      if(taxa == 'consumer') {
          taxon[[i]] <- unlist(strsplit(S0[i, 'resource'], " \\|\\ "))
      } else if(taxa == 'resource') {
          taxon[[i]] <- unlist(strsplit(S0[i, 'consumer'], " \\|\\ "))
      }
    }

    # pb <- txtProgressBar(min = 0,max = nrow(S0), style = 3)

    for(i in 1:nrow(S0)){
        similarity.matrix[i,1] <- tanimoto_traits(resource_x = taxon[[which(S0[, 'taxon'] == S1)]],
                                                    resource_y = taxon[[i]],
                                                    trait_x = taxonomy[[which(S0[, 'taxon'] == S1)]],
                                                    trait_y = taxonomy[[i]],
                                                    trait_weight = wt
                                                    )
    # setTxtProgressBar(pb, i)
    }#i
    # close(pb)

  return(similarity.matrix)
}#similarity_taxon function


#' svd
#'
#' Singular value decomposition.
#'
#' @details
#' The factorization works by first forming the crossproduct \eqn{X^T X} for
#' shaqs (\eqn{XX^T} for tshaqs) and then taking its eigenvalue decomposition.
#' In this case, the square root of the eigenvalues are the singular values.
#'
#' For shaqs, if the left/right singular vectors \eqn{U} or \eqn{V} are desired,
#' then in either case, \eqn{V} is computed (the eigenvectors).  From these,
#' \eqn{U} can be reconstructed, since if \eqn{X = U\Sigma V^T}, then \eqn{U =
#' XV\Sigma^{-1}}. For tshaqs, a similar game can be played, noting that the
#' left singular vectors \eqn{U} map to the eigenvectors of \eqn{XX^T}.
#'
#' @section Communication:
#' The operation is completely local except for forming the crossproduct, which
#' is an \code{allreduce()} call, quadratic on the number of columns.
#'
#' @param x
#' A shaq.
#' @param nu
#' number of left singular vectors to return.
#' @param nv
#' number of right singular vectors to return.
#' @param LINPACK
#' Ignored.
#'
#' @return
#' A list of elements \code{d}, \code{u}, and \code{v}, as with R's own
#' \code{svd()}.  The elements are, respectively, a regular vector, a shaq, and
#' a regular matrix.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' svd = svd(x)
#' comm.print(svd$d) # a globally owned vector
#' svd$u # a shaq
#' comm.print(svd$v) # a globally owned matrix
#'
#' finalize()
#' }
#'
#' @name svd
#' @rdname svd
NULL

utils::globalVariables(c("n", "p"))

svd.shaq = function(x, retu=FALSE, retv=FALSE)
{
  only.values = !retu && !retv

  cp = cp.shaq(x)

  ev = eigen(cp, only.values=only.values, symmetric=TRUE)

  d = sqrt(ev$values)

  if (retu)
  {
    # u.local = ev$vectors %*% diag(1/d)
    u.local = sweep(ev$vectors, STATS=1/d, MARGIN=2, FUN="*")
    u.local = DATA(x) %*% u.local
    u = shaq(u.local, nrow(x), ncol(x), checks=FALSE)
  }
  else
    u = NULL

  if (retv)
    v = ev$vectors
  else
    v = NULL

  list(d=d, u=u, v=v)
}

#' @rdname svd
#' @export
setMethod("svd", signature(x="shaq"),
  function(x, nu = min(n, p), nv = min(n, p), LINPACK = FALSE)
  {
    n = nrow(x)
    p = ncol(x)

    check.is.natnum(nu)
    check.is.natnum(nv)

    retu = nu > 0
    retv = nv > 0

    ret = svd.shaq(x, retu, retv)

    if (nu && ncol(ret$u) > nu)
      ret$u = ret$u[, 1:nu]

    if (nv && NCOL(ret$v) > nv)
      ret$v = ret$v[, 1:nv]

    ret
  }
)

svd.tshaq = function(x, retu=FALSE, retv=FALSE)
{
  only.values = !retu && !retv

  cp = tcp.shaq(x)

  ev = eigen(cp, only.values=only.values, symmetric=TRUE)

  d = sqrt(ev$values)

  if (retu)
    u = ev$vectors
  else
    u = NULL

  if (retv)
  {
    v.local = sweep(ev$vectors, STATS=1/d, MARGIN=2, FUN="*")
    v.local = crossprod(DATA(x), v.local)
    v = shaq(v.local, ncol(x), nrow(x), checks=FALSE)
  }
  else
    v = NULL

  list(d=d, u=u, v=v)
}

#' @rdname svd
#' @export
setMethod("svd", signature(x="tshaq"),
  function(x, nu = min(n, p), nv = min(n, p), LINPACK = FALSE)
  {
    n = nrow(x)
    p = ncol(x)

    check.is.natnum(nu)
    check.is.natnum(nv)

    retu = nu > 0
    retv = nv > 0

    ret = svd.tshaq(x, retu, retv)

    if (nu && NCOL(ret$u) > nu)
      ret$u = ret$u[, 1:nu]

    if (nv && NCOL(ret$v) > nv)
      ret$v = ret$v[, 1:nv]

    ret
  }
)

#' @rdname svd
#' @export
setMethod("La.svd", signature(x="shaq"),
  function(x, nu = min(n, p), nv = min(n, p))
  {
    n = nrow(x)
    p = ncol(x)

    ret = svd(x, nu, nv)
    if (nv)
    {
      ret$vt = t(ret$v)
      ret$v = NULL
    }

    ret
  }
)

La.svd.tshaq = function(x, retu=FALSE, retv=FALSE)
{
  only.values = !retu && !retv

  cp = tcp.shaq(x)

  ev = eigen(cp, only.values=only.values, symmetric=TRUE)

  d = sqrt(ev$values)

  if (retu)
    u = ev$vectors
  else
    u = NULL

  if (retv)
  {
    vt.local = sweep(ev$vectors, STATS=1/d, MARGIN=2, FUN="*")
    vt.local = crossprod(vt.local, DATA(x))
    vt = tshaq(vt.local, nrow(x), ncol(x), checks=FALSE)
  }
  else
    vt = NULL

  list(d=d, u=u, vt=vt)
}

#' @rdname svd
#' @export
setMethod("La.svd", signature(x="tshaq"),
  function(x, nu = min(n, p), nv = min(n, p))
  {
    n = nrow(x)
    p = ncol(x)

    check.is.natnum(nu)
    check.is.natnum(nv)

    retu = nu > 0
    retv = nv > 0

    ret = La.svd.tshaq(x, retu, retv)

    if (nu && NCOL(ret$u) > nu)
      ret$u = ret$u[, 1:nu]

    if (nv && NROW(ret$vt) > nv)
      DATA(ret$vt) = DATA(ret$vt)[1:nv, ]

    ret
  }
)


n=100
s=rep(NA,n)

s[1] = x[1]
s[2] = x[2]
b[2] = x[2] - x[1]
alpha = .1
for (t in 3:n) {
    s[t] = alpha*x[t] + (1-alpha)*(s[t-1] + b[t-1])
}

n=100
s=rep(NA,n)

s[1] = xx[1]
alpha = .1
for (t in 2:n) {
    s[t] = alpha*xx[t] + (1-alpha)*(s[t-1])
}

plot(xx,type="l",col="blue")
lines(s, col="red",type="l")

delta = 1.0 / 8.0
mu = 1.0
phi = 4.0
est = 0
dev = 0

getest <- function() {
 mu*est + phi*dev
}

y=rep(NA,n)
for (i in 1:n) {
    newSample = x[i]
    if (est == 0 ) {
        est = newSample
    }
	di = newSample - est
	est = est + delta * di
        di = abs(di)
        dev = dev + delta * (di - dev)
        y[i]=mu*est + phi*dev
}

r=rep(NA,n)
for (i in 1:n) { r[i]=addsam(a[i]);}

cat(addsam(a[i])); cat(", "); }
summary(a)

b= 300 + a


#' Sinuosity and Slope
#'
#' Calculates sinuosity and slope for each reach within a NHDPlusV2 network
#'
#' Can \code{aggregate(...)} reach values to network-scale using group by
#' \code{$net.id}
#'
#' \code{$MaxElevSM, $MinElevSM $SlopeNHDPlus} are values at the outlet of
#' group.comid. \code{tot.len, str.len, sinuosity} are scaled by M value
#'
#' warning message: In st_cast.sf(netdelin_Prj, "LINESTRING") : repeating
#' attributes for all sub-geometries for which they may not be constant is from
#' changing MULTILINE to LINESTRING geometry
#'
#' @param netdelin output from \code{net_delin}
#' @param vpu NHDPlusV2 vector processing unit
#' @param nhdplus_path Directory containing NHDPlusV2 \code{\link{net_nhdplus}}
#'
#' @return \code{data.frame}: \code{$net.comid} upstream reaches from
#'   group.comid; \code{$group.comid} network root COMID; \code{$tot.len} length
#'   of reach; \code{$str.len} is straight line length of reach;
#'   \code{$sinuosity} \code{tot.len} / \code{str.len}; \code{$MaxElevSM}
#'   maximum elevation of reach; \code{$MinElevSM} minimum elevtion of reach;
#'   \code{SlopeNHDPlus} slope of reach
#'
#' @examples
#' # identify NHDPlusV2 COMID
#' a <- net_sample(nhdplus_path = getwd(), vpu = "01", ws_order = 6, n = 5)
#' # delineate stream network
#' b <- net_delin(group_comid = as.character(a[,"COMID"]), nhdplus_path = getwd(), vpu = "01")
#' # calculate sinuosity and slope
#' c <- net_sinu(netdelin = b, vpu = "01", nhdplus_path = getwd())
#' @export

net_sinu <- function (netdelin, nhdplus_path, vpu){
  directory <- grep(paste(vpu, "/NHDPlusAttributes", sep = ""),
                    list.dirs(nhdplus_path, full.names = T),
                    value = T)
  slope <- grep("elevslope.dbf", list.files(directory, full.names = T), value = T)
  slope <- foreign::read.dbf(slope)
  names(slope) <- toupper(names(slope))

  netdelin_Prj <- sf::st_transform(netdelin$SF_Obj, crs = 5070)
  mimaslope <- slope[slope[,"COMID"] %in% netdelin_Prj$COMID,
                     c("COMID", "MAXELEVSMO", "MINELEVSMO", "SLOPE")]
  names(mimaslope) <- c("COMID", "MaxElevSM", "MinElevSM", "SlopeNHDPlus")

  tot.len <- sf::st_length(sf::st_geometry(netdelin_Prj))
  # to ensure the input is linestring geometry -
  # vpu 17 read in a multiline and caused error
  netdelin_Prj <- sf::st_cast(netdelin_Prj,"LINESTRING")
  xy <- sf::st_coordinates(sf::st_geometry(netdelin_Prj))
  xy <- dplyr::group_by(data.frame(xy),L1)
  xy.min <- dplyr::slice(xy, which.min(M))
  xy.max <- dplyr::slice(xy, which.max(M))
  xy <- rbind(xy.min, xy.max)
  xy <- data.frame(xy)
  xy <- xy[order(xy[,"L1"]),]
  xy <- sf::st_as_sf(xy, coords = c(1, 2))
  xy <- dplyr::group_by(xy, L1)
  xy <- dplyr::summarize(xy, dplyr::first(L1))
  xy <- sf::st_cast(xy, "LINESTRING")
  xy <- sf::st_set_crs(xy, 5070)
  str.len <- sf::st_length(xy)

  xy.out <- data.frame(net.id = netdelin_Prj$net.id,
                       group.comid = netdelin_Prj$group.comid,
                       net.comid = netdelin_Prj$COMID,
                       tot.len, str.len, sinuosity = as.numeric(tot.len / str.len))
  xy.out <- merge(xy.out, mimaslope, by.x = "net.comid", by.y = "COMID", all.x = T)
  return(xy.out)
}


# get_compensation_error.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Returns a list of matrices discribing compensation error, with intercepts,
# coefficients, slopes, and skewness.

get.compensation.error <- function( expr.data.unco, expr.data.comp,
    marker.spillover.unco, scale.untransformed, plot.figure, figure.label,
    flow.gate, flow.control, asp )
{
    marker.spillover.zero <- rep( 0, flow.control$marker.n )
    names( marker.spillover.zero ) <- flow.control$marker

    marker.spillover.comp <- mclapply( flow.control$sample, function( samp )
    {
        marker.proper <- samp

        # get expression data for primary marker

        marker.proper.expr.unco <- expr.data.unco[
            which( flow.control$event.sample == samp )[ flow.gate[[ samp ]] ],
            marker.proper ]

        marker.proper.expr.comp <- expr.data.comp[
            which( flow.control$event.sample == samp )[ flow.gate[[ samp ]] ],
            marker.proper ]

        marker.expr.n <- length( marker.proper.expr.unco )

        # identify extreme expression values

        expr.trim.n <- round( marker.expr.n * asp$rlm.trim.factor )

        marker.proper.expr.low.unco <- sort( marker.proper.expr.unco )[
            expr.trim.n ]
        marker.proper.expr.high.unco <- sort( marker.proper.expr.unco,
            decreasing = TRUE )[ expr.trim.n ]

        marker.proper.expr.low.comp <- sort( marker.proper.expr.comp )[
            expr.trim.n ]
        marker.proper.expr.high.comp <- sort( marker.proper.expr.comp,
            decreasing = TRUE )[ expr.trim.n ]

        marker.spillover.comp.inte <- marker.spillover.zero
        marker.spillover.comp.coef <- marker.spillover.zero
        marker.spillover.comp.slop <- marker.spillover.zero
        marker.spillover.comp.skew <- marker.spillover.zero

        for ( marker in flow.control$marker )
        {
            # get expression data for secondary marker

            marker.expr.unco <- expr.data.unco[
                which( flow.control$event.sample == samp )[
                    flow.gate[[ samp ]] ],
                marker ]

            marker.expr.comp <- expr.data.comp[
                which( flow.control$event.sample == samp )[
                    flow.gate[[ samp ]] ],
                marker ]

            marker.expr.low.unco <- sort( marker.expr.unco )[ expr.trim.n ]
            marker.expr.high.unco <- sort( marker.expr.unco,
                decreasing = TRUE )[ expr.trim.n ]

            marker.expr.low.comp <- sort( marker.expr.comp )[ expr.trim.n ]
            marker.expr.high.comp <- sort( marker.expr.comp,
                decreasing = TRUE )[ expr.trim.n ]

            # trim expression values for both markers

            expr.trim.idx.unco <- which (
                marker.proper.expr.unco > marker.proper.expr.low.unco &
                    marker.proper.expr.unco < marker.proper.expr.high.unco &
                    marker.expr.unco > marker.expr.low.unco &
                    marker.expr.unco < marker.expr.high.unco
            )

            expr.trim.idx.comp <- which (
                marker.proper.expr.comp > marker.proper.expr.low.comp &
                    marker.proper.expr.comp < marker.proper.expr.high.comp &
                    marker.expr.comp > marker.expr.low.comp &
                    marker.expr.comp < marker.expr.high.comp
            )

            marker.proper.expr.trim.unco <- marker.proper.expr.unco[
                expr.trim.idx.unco ]
            marker.expr.trim.unco <- marker.expr.unco[ expr.trim.idx.unco ]

            marker.proper.expr.trim.comp <- marker.proper.expr.comp[
                expr.trim.idx.comp ]
            marker.expr.trim.comp <- marker.expr.comp[ expr.trim.idx.comp ]

            # fit robust linear model with compensated data

            if ( marker == marker.proper )
            {
                marker.spillover.comp.coef[ marker ] <- 1.0
                marker.spillover.comp.slop[ marker ] <- 1.0
            }
            else
            {
                spillover.model.result <- fit.robust.linear.model(
                    marker.proper.expr.trim.comp, marker.expr.trim.comp,
                    marker.proper, marker, asp )

                marker.spillover.comp.inte[ marker ] <-
                    spillover.model.result[ 1, 1 ]

                marker.spillover.comp.coef[ marker ] <-
                    spillover.model.result[ 2, 1 ]

                # get slope and skewness in untransformed scale

                if ( scale.untransformed )
                {
                    marker.spillover.comp.slop[ marker ] <-
                        marker.spillover.comp.coef[ marker ]
                    marker.spillover.comp.skew[ marker ] <-
                        skewness( marker.expr.trim.comp )
                }
                else
                {
                    x.transform.inv <- flow.control$transform.inv[[
                        flow.control$marker.original[
                            match( marker, flow.control$marker ) ] ]]
                    y.transform.inv <- flow.control$transform.inv[[
                        flow.control$marker.original[
                            match( marker.proper, flow.control$marker ) ] ]]

                    y1p <- min( marker.proper.expr.trim.comp )
                    y2p <- max( marker.proper.expr.trim.comp )

                    x1p <- marker.spillover.comp.inte[ marker ] +
                        marker.spillover.comp.coef[ marker ] * y1p
                    x2p <- marker.spillover.comp.inte[ marker ] +
                        marker.spillover.comp.coef[ marker ] * y2p

                    if ( y1p == y2p || x1p == x2p )
                        marker.spillover.comp.slop[ marker ] <- 0
                    else
                    {
                        y1 <- y.transform.inv( y1p )
                        y2 <- y.transform.inv( y2p )

                        x1 <- x.transform.inv( x1p )
                        x2 <- x.transform.inv( x2p )

                        marker.spillover.comp.slop[ marker ] <-
                            marker.spillover.comp.coef[ marker ] *
                            ( x2 - x1 ) * ( y2p - y1p ) /
                            ( ( x2p - x1p ) * ( y2 - y1 ) )
                    }

                    marker.spillover.comp.skew[ marker ] <-
                        skewness( x.transform.inv( marker.expr.trim.comp ) )
                }
            }

            if ( plot.figure && ! is.null( flow.control$figure.scatter.dir ) )
                plot.scatter(
                    expr.data.unco[
                        flow.control$event.sample == samp, marker ],
                    expr.data.unco[
                        flow.control$event.sample == samp, marker.proper ],
                    expr.data.comp[
                        flow.control$event.sample == samp, marker ],
                    expr.data.comp[
                        flow.control$event.sample == samp,marker.proper ],
                    marker.spillover.unco$inte[ marker.proper, marker ],
                    marker.spillover.unco$coef[ marker.proper, marker ],
                    marker.spillover.comp.inte[ marker ],
                    marker.spillover.comp.coef[ marker ],
                    marker.spillover.comp.slop[ marker ],
                    range( c( marker.expr.trim.unco, marker.expr.trim.comp ) ),
                    range( c( marker.proper.expr.trim.unco,
                        marker.proper.expr.trim.comp ) ),
                    samp, marker, marker.proper,
                    scale.untransformed, figure.label,
                    flow.gate, flow.control, asp
                )
        } # marker

        c( marker.spillover.comp.inte, marker.spillover.comp.coef,
            marker.spillover.comp.slop, marker.spillover.comp.skew )
    },
    mc.cores = get.worker.process( asp$worker.process.n ) ) # samp

    marker.spillover.comp <- do.call( rbind, marker.spillover.comp )
    rownames( marker.spillover.comp ) <- flow.control$marker

    list(
        inte = marker.spillover.comp[ , 1 : flow.control$marker.n ],
        coef = marker.spillover.comp[ , 1 : flow.control$marker.n +
                flow.control$marker.n ],
        slop = marker.spillover.comp[ , 1 : flow.control$marker.n +
                2 * flow.control$marker.n ],
        skew = marker.spillover.comp[ , 1 : flow.control$marker.n +
                3 * flow.control$marker.n ]
    )
}


.precision_map <- c(`0`=100000, `1`=10000, `2`=1000, `3`=100, `4`=10, `5`=1)

#' Return MGRS grid reference precision (in meters)
#'
#' MGRS coordinates represent a "square" with a certain level of precision. See Details for more info.
#'
#' An MGRS grid reference is a point reference system. When the term 'grid square' is used,
#' it can refer to a square with a side length of 10 km (6 mi), 1 km, 100 m (328 ft), 10 m
#' or 1 m, depending on the precision of the coordinates provided. (In some cases, squares
#' adjacent to a Grid Zone Junction (GZJ) are clipped, so polygon is a better descriptor of
#' these areas.) The number of digits in the numerical location must be even: 0, 2, 4, 6, 8
#' or 10, depending on the desired precision. When changing precision levels, it is important
#' to truncate rather than round the easting and northing values to ensure the more precise
#' polygon will remain within the boundaries of the less precise polygon. Related to this is
#' the primacy of the southwest corner of the polygon being the labeling point for an entire
#' polygon. In instances where the polygon is not a square and has been clipped by a grid
#' zone junction, the polygon keeps the label of the southwest corner as if it had not been
#' clipped.
#'
#' For example (spaces used for clarity):
#'
#' \describe{
#' \item{4Q}{precision level 6x8 degrees (in most cases) - function returns \code{NA} for this}
#' \item{4QFJ}{precision level 100 km}
#' \item{4QFJ 1 6}{precision level 10 km}
#' \item{4QFJ 12 67}{precision level 1 km}
#' \item{4QFJ 123 678}{precision level 100 m}
#' \item{4QFJ 1234 6789}{precision level 10 m}
#' \item{4QFJ 12345 67890}{precision level 1 m}
#' }
#'
#' @md
#' @param x character vector of MGRS grid references
#' @return data frame with `grid_ref` and `precision` columns. `precision` is in meters.
#' @references <https://en.wikipedia.org/wiki/Military_Grid_Reference_System#Grid_zone_designation>
#' @export
#' @examples
#' grefs <- c("4Q", "4QFJ", "4QFJ16", "4QFJ1267", "4QFJ123678",
#'            "4QFJ12346789", "4QFJ1234567890")
#' mgrs_precision(grefs)
mgrs_precision <- function(x) {

  x <- gsub("[[:space:]]", "", x)
  xchars <- sapply(x, nchar)

  y <- sub("^[[:digit:]]{1,2}.{1,3}", "", x)
  y <- sapply(y, nchar)
  y <- as.integer(y / 2)
  y <- as.character(y)
  y <- ifelse(xchars==2, NA_integer_, .precision_map[y])

  y <- data.frame(grid_ref = x, precision = unname(y), stringsAsFactors=FALSE)
  class(y) <- c("tbl_df", "tbl", "data.frame")

  y

}


f <- file("stdin")
open(f)
result1 <- 0
result2 <- 0
while(length(line <- readLines(f,n=1)) > 0) {
  parts <- strsplit(line, ' [|] ')[[1]]
  part1 <- strsplit(parts[1], ' ')[[1]]
  part2 <- strsplit(parts[2], ' ')[[1]]
  # process line
  for (w in part2) {
      if (nchar(w) == 2 || nchar(w) == 3 || nchar(w) == 7 || nchar(w) == 4) {
          result1 <- result1 + 1
      }
  }

  m <- list()
  for (i in (1:10)) {
      m[[i]] = strsplit("abcdefgh", '')[[1]]
  }
  for (w in part1) {
      o = strsplit(w, '')[[1]]
      if (nchar(w) == 2) {
          m[[1]] = o
      }
      if (nchar(w) == 3) {
          m[[7]] = o
      }
      if (nchar(w) == 4) {
          m[[4]] = o
      }
      if (nchar(w) == 7) {
          m[[8]] = o
      }
  }
  for (w in part1) {
      o = strsplit(w, '')[[1]]
      if (nchar(w) == 5) {
          L = setdiff(m[[4]], m[[1]])
          if (length(intersect(o, L)) == 2) {
              m[[5]] = o
          } else if (length(intersect(o, m[[1]])) == 2) {
              m[[3]] = o
          } else {
              m[[2]] = o
          }
      } else if (nchar(w) == 6) {
          if (length(intersect(o, m[[1]])) == 1) {
              m[[6]] = o
          } else if (length(intersect(o, m[[4]])) == 4) {
              m[[9]] = o
          } else {
              m[[10]] = o
          }
      }
  }
  n = 0
  for (w in part2) {
      n = n * 10
      for (i in (1:10)) {
          if (setequal(strsplit(w, '')[[1]], m[[i]])) {
              n = n + i %% 10
          }
      }
  }
  result2 = result2 + n

}
print(result1)
print(result2)


#' Mymean function
#'
#' @param x numeric value
#' @param na.rm logical value - should missing values be ignored?
#' @importFrom stats na.omit
#' @export
mymean <- function(x, na.rm=FALSE){
  if (!is.numeric(x)) {
    warning("Vector x is not numeric")
    return(NA)
  }

  if (na.rm == TRUE) x <- na.omit(x)

  sum(x)/length(x)
}


num <- scan("stdin", what = integer(), quiet = TRUE)
write(sum(num), file = "")


library(ggplot2)

select_covariate_effects <- function(){
  args <- commandArgs(trailingOnly = TRUE)
  filename <- args[1]
  VERSION = "v2" # Last version with no VERSION variable definition (overwritten by load)
  load(paste0("results/", filename))
  filename = gsub("(.*)stanfit.Rdata$", "\\1", filename)
  out <- rstan::extract(fit)
  if (VERSION == "v3" || VERSION == "v2"){
    prepped_data = prepare_intervention_effects(out)
  } else {
    prepped_data = prepare_mobility_effects(out, formula_pooling, formula_partialpooling, region_to_country_map)
  }
  plot_covariate_effects(prepped_data[["data"]], prepped_data[["plot_labels"]], filename)
}

prepare_intervention_effects <- function (out){

  alpha <- data.frame(as.matrix(out$alpha))
  plot_labels <- c("School Closure",
                   "Self Isolation",
                   "Public Events",
                   "First Intervention",
                   "Lockdown", 'Social distancing \n encouraged')

  colnames(alpha) <- plot_labels
  first.intervention <- alpha[,c(1,2,3,5,6)] + alpha[,4]
  data1 <- bayesplot::mcmc_intervals_data(first.intervention,prob=.95,transformation=function(x) 1-exp(-x),point_est="mean")
  data1$type <- "First Intervention"

  data2 <- bayesplot::mcmc_intervals_data(alpha[,c(1,2,3,5,6)],  prob=.95,transformation=function(x) 1-exp(-x),point_est="mean")
  data2$type <- "Later Intervention"
  data <- rbind(data1,data2[1:5,])
  return(list(data=data, plot_labels=plot_labels))
}

prepare_mobility_effects <- function (out, formula_pooling, formula_partialpooling, region_to_country_map) {

  # stop("covariate effect plot not supported for mobility")

  plot_labels <- regmatches(formula_pooling, gregexpr("[a-zA-Z]+", formula_pooling))[[1]]
  name_labels_partial <- regmatches(formula_partialpooling, gregexpr("[a-zA-Z]+", formula_partialpooling))[[1]]

  alpha <- data.frame(as.matrix(out$alpha))
  plot_labels <- paste("global: ",plot_labels,sep="")
  colnames(alpha) <- plot_labels
  data_global <- bayesplot::mcmc_intervals_data(alpha,prob=.95,transformation=function(x) 1-exp(-x),point_est="mean")
  data_global$type <- "pooled"

  plot_labels_partial <- c()
  for(i in 1:length(region_to_country_map)){
    zone <- names(region_to_country_map)[i]
    zone_labels <- paste(paste0(zone, ": "), name_labels_partial, sep="")
    plot_labels_partial <- c(plot_labels_partial, zone_labels)
    alpha_partial <- data.frame(as.matrix(drop(out$alpha_state[,i,])))
    colnames(alpha_partial) <- zone_labels
    data_partial <- bayesplot::mcmc_intervals_data(alpha_partial,prob=.95,transformation=function(x) 1-exp(-x),point_est="mean")
    data_partial$type <- "partial"
    data_global <- rbind(data_global,data_partial)
  }

  plot_labels <- c(plot_labels, plot_labels_partial)
  # print(plot_labels)
  return (list(data=data_global, plot_labels=plot_labels))

}

#data$type[1] = "First Intervention"
plot_covariate_effects <- function (data, plot_labels, filename) {

  levels(data$parameter) = gsub("t(", "", levels(data$parameter), fixed=TRUE)
  levels(data$parameter) = gsub(")", "", levels(data$parameter), fixed=TRUE)
  data$parameter = (as.character(data$parameter))

  no_point_est <- all(data$point_est == "none")
  x_lim <- range(c(data$ll, data$hh))
  x_range <- diff(x_lim)
  x_lim[1] <- x_lim[1] - 0.05 * x_range
  x_lim[2] <- x_lim[2] + 0.05 * x_range
  layer_vertical_line <- if (0 > x_lim[1] && 0 < x_lim[2]) {
    bayesplot::vline_0(color = "gray90", size = 0.5)
  } else {
    geom_blank(
      mapping = NULL, data = NULL,
      show.legend = FALSE, inherit.aes = FALSE)
  }
  args_outer <- list(mapping = aes_(x = ~ll, xend = ~hh, y = ~parameter,
                                    yend = ~parameter)) #, color = bayesplot::get_color("mid"))
  args_inner <- list(mapping = aes_(x = ~l, xend = ~h, y = ~parameter,
                                    yend = ~parameter), size = 2, show.legend = FALSE)
  args_point <- list(mapping = aes_(x = ~m, y = ~parameter),
                     data = data, size = 4, shape = 21)

  args_point$color <- "blue" #get_color("dark_highlight")

  point_func <- geom_point
  layer_outer <- do.call(geom_segment, args_outer)
  layer_inner <- do.call(geom_segment, args_inner)
  layer_point <- do.call(point_func, args_point)

  data$parameter = factor(as.character(data$parameter),levels=plot_labels[order(plot_labels)[length(plot_labels):1]])
  # data = data[order(-data$m),]
  p = ggplot(data) + ggpubr::theme_pubr() +  geom_point(
      aes(x=m,y=parameter,colour=type),position = position_dodge(-.5)
    ) + geom_linerange(
      aes(xmin=ll,xmax=hh,y=parameter,colour=type), position = position_dodge(-.5)
    ) +
    scale_x_continuous(
      breaks=seq(0,1,.25), labels = c(
        "0%\n(no effect on transmissibility)","25%","50%","75%","100%\n(ends transmissibility)"
      ), expand=c(0.005,0.005),expression(paste("Relative % reduction in  ",R[t]))
    ) + scale_colour_manual(name = "", values = c(("coral4"), ("seagreen"))) +
    geom_vline(xintercept=1,colour="darkgray") +
    scale_y_discrete("Governmental intervention\n") +
    #geom_vline(xintercept=0,colour="darkgray") +
    theme(plot.margin = margin(0, 2, 0, .5, "cm"))
  #+ guides(fill=guide_legend(nrow=2))

  ggsave(filename = paste0("results/", filename, "covars-alpha-reduction.png"),
         p,height=4,width=8)
  write.csv(data, paste0("results/", filename, "covars-alpha-reduction.csv"))
  dir.create("web/figures/desktop/", showWarnings = FALSE, recursive = TRUE)
  dir.create("web/figures/mobile/", showWarnings = FALSE, recursive = TRUE)
  cowplot::save_plot(filename = paste0("web/figures/desktop/",  "covars-alpha-reduction.svg"),
            p, base_height = 4, base_asp = 1.618 * 2 * 8/12)
  cowplot::save_plot(filename = paste0("web/figures/mobile/", "covars-alpha-reduction.svg"),
            p, base_height = 4, base_asp = 1.1)

}

select_covariate_effects()


coeff_sigma <- 7/100

prRichiesta <- 93/100

ordineQuantile <- (prRichiesta + 1)/2

q <- qnorm(ordineQuantile)

n <- ceiling((q/coeff_sigma)^2)

cat("Soluz.\n")
print(n)

cat("ATTENZ: Abbiamo vinto, andiamo al mare\n")
cat("TAAAAAAAAC ------------ \n")
cat("SIIIIII ABBIAMO FINITOOOOOO :)\n")


# context("LogLikelihood function")

data("faketree")
data("fakeexperiment")

# Adding an NA
# fakeexperiment[1,2] <- NA

# Parameters
psi    <- c(.01, .02)
mu     <- c(.05, .1)
eta    <- c(.9, .7)
Pi     <- 1 - .3
errtol <- 1e-15

O  <- new_aphylo(tip.annotation = fakeexperiment[,-1L], tree = as.phylo(faketree))

S  <- states(2)
Pr <- LogLike(
  new_aphylo_pruner(O), psi = psi, mu_d = mu, mu_s = mu, eta=eta,
  Pi = Pi)$Pr[[1]]

  # aphylo:::probabilities(
  # with(O, rbind(tip.annotation, node.annotation)),
  # O$pseq, psi, mu, eta, S, O$offspring)

# Pr1 <- LogLike(O, psi = psi, mu =mu,eta=eta, Pi = Pi)
# Pr2 <- LogLike(new_aphylo_pruner(O), psi = psi, mu =mu,eta=eta, Pi = Pi)
#
# Pr2$Pr - Pr1$Pr[[1]]

# Checking Leaf Probabilities --------------------------------------------------
# test_that("Leaf Probabilities", {
  # Checking cases compared to the states (0,0) (1,0) (0,1) (1,1)
  PrRaw   <- Pr
  PrRaw[] <- 1

  # Node 3 (0,0)
  PrRaw[4, 1] <- (1 - psi[1])^2 * eta[1]^2
  PrRaw[4, 2] <- psi[2] * (1 - psi[1]) * eta[1]^2
  PrRaw[4, 3] <- (1 - psi[1]) * psi[2] * eta[1]^2
  PrRaw[4, 4] <- psi[2]^2 * eta[1]^2

  # Node 4 (0,1)
  PrRaw[5, 1] <- (1 - psi[1])*psi[1] * eta[1] * eta[2]
  PrRaw[5, 2] <- psi[2] * psi[1] * eta[1] * eta[2]
  PrRaw[5, 3] <- (1 - psi[1]) * (1 - psi[2]) * eta[1] * eta[2]
  PrRaw[5, 4] <- psi[2] * (1 - psi[2]) * eta[1] * eta[2]

  # Node 5 (1,0)
  PrRaw[6, 1] <- psi[1]*(1 - psi[1]) * eta[2] * eta[1]
  PrRaw[6, 2] <- (1 - psi[2]) * (1 - psi[1]) * eta[2] * eta[1]
  PrRaw[6, 3] <- psi[1] * psi[2] * eta[2] * eta[1]
  PrRaw[6, 4] <- (1 - psi[2]) * psi[2] * eta[2] * eta[1]

  # Node 6 (1,1)
  PrRaw[7, 1] <- psi[1] ^ 2 * eta[2]^2
  PrRaw[7, 2] <- (1 - psi[2]) * psi[1] * eta[2]^2
  PrRaw[7, 3] <- psi[1] * (1 - psi[2]) * eta[2]^2
  PrRaw[7, 4] <- (1 - psi[2]) ^ 2 * eta[2]^2

  # These should be identical
  expect_equivalent(PrRaw[4:7,], Pr[c(5:7, 1:4),][4:7,])
# })

# Checking Internal Probabilities ----------------------------------------------
# test_that("Internal Probabilities", {
  M  <- aphylo:::prob_mat(mu)
  # Checking cases compared to the states (0,0) (1,0) (0,1) (1,1)

  PrRaw <- Pr[c(5:7, 1:4),]
  PrRaw[1:3,] <- 1

  # Node 1 (0,0)
  of1 <-
    PrRaw[4:5,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[4:5,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[4:5,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[4:5,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[2,1] <- prod(of1)

  # Node 2 (0,0)
  of1 <-
    PrRaw[6:7,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[6:7,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[6:7,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[6:7,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[3,1] <- prod(of1)

  # Node 1 (1,0)
  of1 <-
    PrRaw[4:5,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[4:5,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[4:5,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[4:5,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[2,2] <- prod(of1)

  # Node 2 (1,0)
  of1 <-
    PrRaw[6:7,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[6:7,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[6:7,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[6:7,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[3,2] <- prod(of1)

  # Node 1 (0,1)
  of1 <-
    PrRaw[4:5,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[4:5,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[4:5,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[4:5,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[2,3] <- prod(of1)

  # Node 2 (0,1)
  of1 <-
    PrRaw[6:7,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[6:7,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[6:7,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[6:7,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[3,3] <- prod(of1)

  # Node 1 (1,1)
  of1 <-
    PrRaw[4:5,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[4:5,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[4:5,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[4:5,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[2,4] <- prod(of1)

  # Node 2 (1,1)
  of1 <-
    PrRaw[6:7,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[6:7,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[6:7,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[6:7,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[3,4] <- prod(of1)

  # Node 0 (0,0)
  of1 <-
    PrRaw[2:3,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[2:3,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[2:3,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[2:3,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[1,1] <- prod(of1)

  # Node 0 (1,0)
  of1 <-
    PrRaw[2:3,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[2:3,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[2:3,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[2:3,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[1,2] <- prod(of1)

  # Node 0 (0,1)
  of1 <-
    PrRaw[2:3,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[2:3,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[2:3,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[2:3,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[1,3] <- prod(of1)

  # Node 0 (1,1)
  of1 <-
    PrRaw[2:3,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[2:3,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[2:3,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[2:3,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[1,4] <- prod(of1)

  expect_equal(Pr[c(5:7, 1:4),], PrRaw)
# })

# Likelihood of Rootnode -------------------------------------------------------
# test_that("Log-Likelihood", {
  ll0 <- LogLike(O, psi = psi, mu_d = mu, mu_s = mu, eta = eta, Pi = Pi)$ll

  PI   <- aphylo:::root_node_prob(Pi, S)
  root <- O$pseq[length(O$pseq)]
  ll1  <- log(sum(Pr[root, , drop = TRUE] * PI))

  expect_equal(abs(ll1 - ll0), 0, tol = errtol)
# })

# Proportionally when fixing etas or psi ---------------------------------------
# The baseline model, compared against the one with eta, when fixing
# eta0 = eta1 = 1/2, the likelihoods should be proportional to a constant equal
# to (1/2)^(P*#leafs).

# test_that("Leaf Probabilities", {

  # Setting eta to be 1/2
  eta    <- c(.5, .5)

  # Checking cases compared to the states (0,0) (1,0) (0,1) (1,1)
  PrRaw   <- Pr
  PrRaw[] <- 1

  # Node 3 (0,0)
  PrRaw[4, 1] <- (1 - psi[1])^2
  PrRaw[4, 2] <- psi[2] * (1 - psi[1])
  PrRaw[4, 3] <- (1 - psi[1]) * psi[2]
  PrRaw[4, 4] <- psi[2]^2

  # Node 4 (0,1)
  PrRaw[5, 1] <- (1 - psi[1])*psi[1]
  PrRaw[5, 2] <- psi[2] * psi[1]
  PrRaw[5, 3] <- (1 - psi[1]) * (1 - psi[2])
  PrRaw[5, 4] <- psi[2] * (1 - psi[2])

  # Node 5 (1,0)
  PrRaw[6, 1] <- psi[1]*(1 - psi[1])
  PrRaw[6, 2] <- (1 - psi[2]) * (1 - psi[1])
  PrRaw[6, 3] <- psi[1] * psi[2]
  PrRaw[6, 4] <- (1 - psi[2]) * psi[2]

  # Node 6 (1,1)
  PrRaw[7, 1] <- psi[1] ^ 2
  PrRaw[7, 2] <- (1 - psi[2]) * psi[1]
  PrRaw[7, 3] <- psi[1] * (1 - psi[2])
  PrRaw[7, 4] <- (1 - psi[2]) ^ 2

  M  <- aphylo:::prob_mat(mu)

  # Node 1 (0,0)
  of1 <-
    PrRaw[4:5,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[4:5,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[4:5,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[4:5,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[2,1] <- prod(of1)

  # Node 2 (0,0)
  of1 <-
    PrRaw[6:7,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[6:7,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[6:7,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[6:7,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[3,1] <- prod(of1)

  # Node 1 (1,0)
  of1 <-
    PrRaw[4:5,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[4:5,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[4:5,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[4:5,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[2,2] <- prod(of1)

  # Node 2 (1,0)
  of1 <-
    PrRaw[6:7,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[6:7,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[6:7,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[6:7,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[3,2] <- prod(of1)

  # Node 1 (0,1)
  of1 <-
    PrRaw[4:5,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[4:5,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[4:5,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[4:5,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[2,3] <- prod(of1)

  # Node 2 (0,1)
  of1 <-
    PrRaw[6:7,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[6:7,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[6:7,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[6:7,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[3,3] <- prod(of1)

  # Node 1 (1,1)
  of1 <-
    PrRaw[4:5,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[4:5,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[4:5,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[4:5,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[2,4] <- prod(of1)

  # Node 2 (1,1)
  of1 <-
    PrRaw[6:7,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[6:7,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[6:7,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[6:7,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[3,4] <- prod(of1)

  # Node 0 (0,0)
  of1 <-
    PrRaw[2:3,1]*M[1,1]*M[1,1] + # (0,0), (0,0)
    PrRaw[2:3,2]*M[1,2]*M[1,1] + # (0,0), (1,0)
    PrRaw[2:3,3]*M[1,1]*M[1,2] + # (0,0), (0,1)
    PrRaw[2:3,4]*M[1,2]*M[1,2]   # (0,0), (1,1)

  PrRaw[1,1] <- prod(of1)

  # Node 0 (1,0)
  of1 <-
    PrRaw[2:3,1]*M[2,1]*M[1,1] + # (1,0), (0,0)
    PrRaw[2:3,2]*M[2,2]*M[1,1] + # (1,0), (1,0)
    PrRaw[2:3,3]*M[2,1]*M[1,2] + # (1,0), (0,1)
    PrRaw[2:3,4]*M[2,2]*M[1,2]   # (1,0), (1,1)

  PrRaw[1,2] <- prod(of1)

  # Node 0 (0,1)
  of1 <-
    PrRaw[2:3,1]*M[1,1]*M[2,1] + # (0,1), (0,0)
    PrRaw[2:3,2]*M[1,2]*M[2,1] + # (0,1), (1,0)
    PrRaw[2:3,3]*M[1,1]*M[2,2] + # (0,1), (0,1)
    PrRaw[2:3,4]*M[1,2]*M[2,2]   # (0,1), (1,1)

  PrRaw[1,3] <- prod(of1)

  # Node 0 (1,1)
  of1 <-
    PrRaw[2:3,1]*M[2,1]*M[2,1] + # (1,1), (0,0)
    PrRaw[2:3,2]*M[2,2]*M[2,1] + # (1,1), (1,0)
    PrRaw[2:3,3]*M[2,1]*M[2,2] + # (1,1), (0,1)
    PrRaw[2:3,4]*M[2,2]*M[2,2]   # (1,1), (1,1)

  PrRaw[1,4] <- prod(of1)

  # Computing likelihood
  ll0 <- LogLike(O, psi = psi, mu_d = mu, mu_s = mu, eta = eta, Pi = Pi)$ll

  PI   <- aphylo:::root_node_prob(Pi, S)
  root <- O$pseq[length(O$pseq)]
  ll1  <- log(sum(PrRaw[1, , drop = TRUE] * PI))

  # This likelihoods are proportional to (1/2)^(P*#leafs)
  expect_equal((exp(ll0)/exp(ll1))^(1/(2*4)), 0.5, tol = errtol)

# })

# ------------------------------------------------------------------------------
# test_that("Joint loglike for multiAphylo", {

set.seed(113)
trees <- lapply(sample(20:50, 10, TRUE), raphylo)
trees <- do.call(c, trees)

psi  <- c(0.01, 0.05)
mu   <- c(0.03, 0.10)
Pi   <- .2
eta  <- c(.7, .9)
ans0 <- LogLike(trees, psi = psi, mu_d = mu, mu_s = mu, Pi = Pi, eta = eta, verb_ans = FALSE)
ans1 <- 0
for (i in seq_along(trees)) {

  ans1 <- ans1 +
    LogLike(
      tree     = trees[[i]],
      psi      = psi,
      mu_d     = mu,
      mu_s     = mu,
      Pi       = Pi,
      eta      = eta,
      verb_ans = FALSE
      )$ll

}

expect_equal(ans1, ans0$ll)

# })

# Test for multiphylo_pruner ---------------------------------------------------

trees_pruner <- new_aphylo_pruner(trees)

ans2 <- LogLike(
  trees_pruner, psi = psi, mu_d = mu, mu_s = mu, Pi = Pi, eta = eta,
  verb_ans = FALSE)

expect_equal(ans0$ll, ans2$ll)


cat(Filter(function(x) !is.na(x), sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  if (s == "") {
    return(NA)
  } else {
    gsub("^0+", "0", gsub("^0+1", "1", paste(rev(as.integer(intToBits(s))), collapse="")))
  }
})), sep="\n")


b <- c(0, 1, 2, 1, 2)
cat(sapply(as.integer(readLines(tail(commandArgs(), n=1))), function(s) {
  as.integer(s / 5) + b[s %% 5 + 1]
}), sep="\n")


# title : GBM vs Light GBM in R
# author : Heo Sung Wook
# depends :  h2o

library(h2o)

# before using h2o, 'h2o.init()' must be needed.
h2o.init()
h2o.removeAll()

# read data set
churn <- read.csv("../data/churn.csv")

# for using h2o, data must be "h2o data frame"
churn_hex <- as.h2o(churn)

# split data, train:valid:test = 6:2:2
splits <- h2o.splitFrame(churn_hex, c(0.6,0.2), seed=1234)

# assign train, valid, test each
train <- h2o.assign(splits[[1]], "train.hex")
valid <- h2o.assign(splits[[2]], "valid.hex")
test <- h2o.assign(splits[[3]], "test.hex")

# 20's column is target('Churn.')
colnames(churn)

# parameter = default
start.time <- Sys.time()
ml_GBM <- h2o.gbm(training_frame = train,
                  validation_frame = valid,
                  x=1:19,
                  y=20,
                  seed = 1234)

Sys.time() - start.time # check time

# check model performance by using test data set
# AUC = 0.9118117
# LogLoss = 0.1953534
h2o.performance(ml_GBM, newdata = test)

# In h2o, there is no specific module for LightGBM yet.
# Instead, using "tree_method='hist'" and "grow_policy='lossguide'" in h2o.xgboost() offer "LightGBM algorithm" to us
# you can find detail information in h2o website => http://docs.h2o.ai/h2o/latest-stable/h2o-docs/data-science/xgboost.html
# parameter = default
start.time <- Sys.time()
ml_LGB <- h2o.xgboost( training_frame = train,
                       validation_frame = valid,
                       x=1:19,
                       y=20,
                       tree_method="hist",
                       grow_policy="lossguide",
                       seed = 1234)

Sys.time() - start.time # check time

# check model performance by using test data set
# AUC = 0.9234419
# LogLoss = 0.1694313
h2o.performance(ml_LGB, newdata = test)


# 3. faza: Vizualizacija podatkov

library(ggplot2)

graf1 <- ggplot(data=skupnaTabela %>% filter(Measurement_Type == "Growth", Name %in% c("NYSE", "NASDAQ", "N225", "FTSE", "SSE", "AEX", "TSX",  "DAX", "ASX", "IBOVESPA")), aes(x=Date, y=Measurement, color=Name)) + geom_line()

graf2 <- ggplot(data=skupnaTabela %>% filter(Measurement_Type %in% c("Open", "High", "Low"), Name == "NYSE"), aes(x=Date, y=Measurement, fill = Measurement_Type)) + geom_col(position = "dodge")

graf3 <- ggplot(data=skupnaTabela %>% filter(Measurement_Type == "Volume", Date == "2020-01-01"), aes(x=Name, y=Measurement)) + geom_col()

grafMapa_sveta <- map_data("world") %>% select(c(1:5))

zemljevid_rasti <- right_join(svetovna_rast  %>% filter(Date == "2020-03-01"), Mapa_sveta, by = "region")

svetovna_rast$region <- gsub(svetovna_rast$region[37:48], "UK", svetovna_rast$region)
svetovna_rast$region <- gsub("United States", "USA", svetovna_rast$region)

cplot <- ggplot(zemljevid_rasti, aes(x =long,y= lat, group = group, fill=Measurement))+
  geom_polygon(color="white") +
  theme_void() + coord_equal() + labs(fill="Growth") +
  theme(legend.position="bottom")

cplot


# 4. faza: Analiza podatkov

# Uvozimo funkcijo za uvoz spletne strani.
# source("lib/xml.r")

# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()

podatki <- nutrition[, -c(6, 7, 8, 9, 11, 13, 15, 16, 17, 24)]

podatki <- podatki[-(48:54),]
row.names(podatki) <- podatki$Jed
podatki <- podatki[, -1]

skalar1 <- scale(podatki)

k <- kmeans(skalar1, 6, nstart=1000)
kat <- k$cluster
barve <- c("red", "green", "blue", "yellow", "gold", "black")

# Uporabimo pairs
pdf("slike/pairs1.pdf")
pairs(skalar1, col = barve[kat])
dev.off()
# Vidimo, da imamo osamelec, ki ga lahko dobimo z naslednjo funkcijo
os_st <- as.integer(row.names(table(k$cluster))[table(k$cluster) == 1]) # Vrne grupo osamelca v tem primeru
os <- row.names(skalar1)[kat %in% os_st] # Ime osamelca
# Pogledamo pairs brez le-tega
pdf("slike/pairs2.pdf")
pairs(skalar1[!(kat %in% os_st), ], col = barve[kat[!(kat %in% os_st)]])
dev.off()
# Osamelcev več ni v podatkih, ki jih bomo uporabili
# Prvotni osamelec nato odstranimo iz podatkov

podatki <- podatki[!(kat %in% os_st), ]
kat <- kat[!(kat %in% os_st)]

cat("Rišem grafa grupiranj...\n")
pdf("slike/grupiranje1.pdf")

plot(podatki[, "Serving.Size..g."], podatki[, "Calories"],
     col = barve[kat],
     xlab = "Masa jedi v gramih",
     ylab = "Kalorije",
     main = "Razmerje med velikostjo porcije ter kalorijami le-te")

dev.off()

pdf("slike/grupiranje2.pdf")

plot(podatki$Calories, podatki$Calories.From.Fat,
     col = barve[kat],
     xlab = "Kalorije",
     ylab = "Kalorije iz maščob",
     main = "Razmerje med celotnimi kalorijami in kalorijami iz maščob")

dev.off()

# Poizkusimo poizkati najboljše prileganje in napovedovanje proteinov v jedi ob znani količini natrija.

attach(podatki)

cat("Rišem graf napovedi...\n")
pdf("slike/napoved.pdf")
plot(Calories, Calories.From.Fat, xlab = "Kalorije", ylab = "Kalorije iz maščob")
lin <- lm(Calories.From.Fat ~ Calories)
kv <- lm(Calories.From.Fat ~ I(Calories^2) + Calories)
# z <- lowess(Calories, Calories.From.Fat)
mls <- loess(Calories.From.Fat ~ Calories)
abline(lin, col = "blue")
curve(predict(kv, data.frame(Calories=x)), add = TRUE, col = "red")
# lines(z, col = "green")
curve(predict(mls, data.frame(Calories=x)), add = TRUE, col = "green")

legend("bottomright",
       legend = c("Kvadratni", "Linearni", "Loess"),
       col = c("red", "blue", "green"),
       lty = c("solid", "solid", "solid"),
       bg = "white")
dev.off()

# Ocenimo napako
vs_kvadratov <- sapply(list(lin, kv, mls), function(x) sum(x$residuals^2))
# Vidimo, da je najnatančnejši mls model, sledi mu kvadratni

# Sestavimo sedaj tabelo, ki bo napovedala za število kalorij pripadajočo vrednost kalorij iz maščob

kv_napoved1 <- predict(kv, data.frame(Calories=seq(40, 140, 50)))
mls_napoved <- predict(mls, data.frame(Calories=seq(min(Calories), max(Calories), 50)))
kv_napoved2 <- predict(kv, data.frame(Calories=seq(max(Calories)+50, 1500, 50)))
napoved <- c(kv_napoved1, mls_napoved, kv_napoved2)

tabela_napovedi <- data.frame(Kalorije = seq(40, 1500, 50), Kalorije.iz.mascob = napoved)
a <- c(540, 240, 290, 340, 440, 590, 390, 190)
b <- c(225, 70, 100, 400/3, 200, 230, 170, 110)
b <- b[order(a)]
a <- sort(a)
attach(tabela_napovedi)
tabela_napovedi$tocna.vrednost <- "ni podatka"
tabela_napovedi$tocna.vrednost[Kalorije %in% a] <- b
detach(tabela_napovedi)

detach(podatki)


#! /usr/bin/env Rscript
# Auth: Michael Zeller 5/28/2019

#Load needed libraries
library(ape)
library(ggplot2)
library(lubridate)
library(gap)

#Substring functions
#https://stackoverflow.com/questions/7963898/extracting-the-last-n-characters-from-a-string-in-r
substrRight <- function(x, n){
  substr(x, nchar(x)-n+1, nchar(x))
}

getDistFromOldest <- function(t){
  #Grab R from commandline arguments, or print usage
  treeFile1 <- t

  #Load user specified tree file
  tree1<-read.tree(treeFile1)

  #Get patristic distance matrix
  dist1 <-cophenetic(tree1)

  #Get names
  dates1 <- substrRight(colnames(dist1),10)
  dates1 <- as.Date(dates1, format = "%m/%d/%Y")
  if(is.na(dates1[1])) {
    dates1 <- substrRight(colnames(dist1),10)
    dates1 <- as.Date(dates1, tryFormats = c("%m/%d/%Y","%Y-%m-%d"))
  }
  oldestId <- which(dates1 == sort(dates1)[1])[[1]]

  #Calculate decimal date
  decdate <- decimal_date(dates1)

  #Get clades
  clades <- sapply(strsplit(colnames(dist1), "|", fixed = TRUE), "[", 3)

  #Return
  resultFrame <- data.frame("dates" = dates1, "decimalDate" = decdate, "dist" = dist1[oldestId,], "clade" = clades)
  return(resultFrame)
}

getBranchFrames <- function(t){
  #Grab R from commandline arguments, or print usage
  treeFile1 <- t

  #Load user specified tree file
  tree1<-read.tree(treeFile1)

  #Set up dataframe
  tipLen<-length(tree1$tip.label)
  treeInfo<-setNames(tree1$edge.length[sapply(1:tipLen,function(x,y) which(y==x),y=tree1$edge[,2])],tree1$tip.label)
  resultFrame <- data.frame("branchLengths" = treeInfo)
  clades <- sapply(strsplit(rownames(resultFrame), "|", fixed = TRUE), "[", 3)
  dates <- sapply(strsplit(rownames(resultFrame), "|", fixed = TRUE), "[", 4)
  dates <- as.Date(dates, tryFormats = c("%m/%d/%Y","%Y-%m-%d"))
  resultFrame <- cbind("names" = rownames(resultFrame), resultFrame, "clade" = clades, "date" = dates)

  return(resultFrame)
}

plotCophenDist<- function(df){
  (ggplot(df, aes(dates, dist, color = clade)) +
     geom_point(aes(size = 2)) +
     geom_smooth(method = "lm", se = FALSE)
  )
}

plotBranchHisto <- function(df){
  (ggplot(df, aes(x = branchLengths, color = clade, fill = clade)) +
     geom_histogram(aes(y=..density..), binwidth = 0.001, alpha=0.6, position="identity", lwd=0.2) +
     theme(legend.position="bottom")
  )
}

plotTimeDist <- function(df){
  (ggplot(df, aes(date, branchLengths, color = clade)) +
     geom_point(aes(size = 2))
     #theme(axis.text.x = element_text(angle = 90, hjust = 1))
  )
}

manualChow <- function(lmPooled, lmA, lmB){
  #Get residual sum of squares
  rssA <- sum(residuals(lmA)^2)
  rssB <- sum(residuals(lmB)^2)
  rssPooled <- sum(residuals(lmPooled)^2)

  #Assume intercepts = 2
  k = 2

  #Calculate f critical chow statistic at the 95% confidence level
  fcrit = qf(0.95, df1 = lmA$df, df2 = lmB$df)
  chowStat = ((rssPooled - (rssA + rssB))/k)/((rssA+rssB)/(lmA$df + lmB$df - (2*k)))
  p <- pf(chowStat, lmA$df, lmB$df, lower.tail=FALSE)

  #Return
  result <- c(fcrit, chowStat, p)
  names(result) = c("F-critical", "Chow Statistic", "P-value")
  return(result)
}

#Draw
#reassort234 <- getDistFromOldest("2-3-4/reassortment234.tre")
#reassort56 <- getDistFromOldest("5-6/reassortment56.tre")
#reassort789 <- getDistFromOldest("7-8-9/reassortment789.tre")
reassortDelta1a <- getDistFromOldest("ha_delta1a/ha_delta1a.tre")
reassort2010 <- getDistFromOldest("ha_2010.1/ha_2010.1.tre")
reassortClusteriv <- getDistFromOldest("ha_clusteriv/clusteriv.tre")

#ggplot
#install.packages("gap") #https://rdrr.io/cran/gap/man/chow.test.html
plotCophenDist(reassortDelta1a)
set1 = reassortDelta1a[which(reassortDelta1a$clade == "02A"),]
set2 = reassortDelta1a[which(reassortDelta1a$clade == "02B"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plotCophenDist(reassort2010)
set1 = reassort2010[which(reassort2010$clade == "02A"),]
set2 = reassort2010[which(reassort2010$clade == "02B"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))

plotCophenDist(reassortClusteriv)
set1 = reassort2010[which(reassort2010$clade == "02A"),]
set2 = reassort2010[which(reassort2010$clade == "02B"),]
(chow.test(set1$dist, set1$decimalDate, set2$dist, set2$decimalDate))


#' Bind matrices by row, and fill missing columns with NA.
#'
#' The matrices are bound together using their column names or the column
#' indices (in that order of precedence.) Numeric columns may be converted to
#' character beforehand, e.g. using format.  If a matrix doesn't have
#' colnames, the column number is used. Note that this means that a
#' column with name \code{"1"} is merged with the first column of a matrix
#' without name and so on. The returned matrix will always have column names.
#'
#' Vectors are converted to 1-column matrices.
#'
#' Matrices of factors are not supported. (They are anyways quite
#' inconvenient.) You may convert them first to either numeric or character
#' matrices. If a matrices of different types are merged, then normal
#' covnersion precendence will apply.
#'
#' Row names are ignored.
#'
#' @param ... the matrices to rbind. The first argument can be a list of
#'   matrices, in which case all other arguments are ignored.
#' @return a matrix with column names
#' @author C. Beleites
#' @seealso \code{\link[base]{rbind}}, \code{\link[base]{cbind}},
#'    \code{\link[plyr]{rbind.fill}}
#' @family binding functions
#' @export
#' @keywords manip
#' @examples
#' A <- matrix (1:4, 2)
#' B <- matrix (6:11, 2)
#' A
#' B
#' rbind.fill.matrix (A, B)
#'
#' colnames (A) <- c (3, 1)
#' A
#' rbind.fill.matrix (A, B)
#'
#' rbind.fill.matrix (A, 99)
rbind.fill.matrix <- function(...) {
  matrices <- list(...)
  if (length(matrices) == 0) return()
  if (is.list(matrices[[1]]) && !is.matrix(matrices[[1]])) {
    matrices <- matrices[[1]]
  }

  ## check the arguments
  tmp <- unlist(lapply(matrices, is.factor))
  if (any(tmp)) {
    stop("Input ", paste(which(tmp), collapse = ", "), " is a factor and ",
      "needs to be converted first to either numeric or character.")
  }

  matrices[] <- lapply(matrices, as.matrix)

  # Work out common column names
  lcols <- lapply(matrices, function(x) amv_dimnames(x)[[2]])
  cols  <- unique(unlist(lcols))

  # Calculate rows in output
  rows <- unlist(lapply(matrices, nrow))
  nrows <- sum(rows)

  # Generate output template
  output <- matrix(NA, nrow = nrows, ncol = length(cols))
  colnames(output) <- cols

  # Compute start and length for each matrix
  pos <- matrix(c(cumsum(rows) - rows + 1, rows), ncol = 2)

  ## fill in the new matrix
  for (i in seq_along(rows)) {
    rng <- seq(pos[i, 1], length.out = pos[i, 2])
    output[rng, lcols[[i]]] <- matrices[[i]]
  }

  output
}


#' Network Topology Metrics
#'
#' Calculates stream network topology metrics
#'
#' Requires /NHDPlusAttributes directory (see \code{\link{net_nhdplus}})
#'
#' Length and area measures are scaled by M values
#'
#' @param netdelin output from \code{net_delin}
#' @param vpu NHDPlusV2 Vector Processing Unit
#' @param nhdplus_path Directory for NHDPlusV2 files (\code{\link{net_nhdplus}})
#'
#' @return \code{data.frame}: \code{$group.comid} stream network root COMID;
#'   \code{$vpu} NHDPlusV2 vector processing unit;\code{M} Position of sampling
#'   point on COMID, as proportion of COMID from upstream end; \code{WS.ord}
#'   strahler order for root node;\code{$head.h2o} number of headwater reaches;
#'   \code{$trib.jun} number of tributary junctions; \code{reach.cnt} number of
#'   reaches in network; \code{diver.cnt} count of divergent flow paths;
#'   \code{$AREASQKM} drainage area (km^2); \code{$LENGTHKM} total lenght of
#'   network flowlines (km); \code{drain.den} drainage density (\code{LENGTHKM}
#'   / \code{AREASQKM})
#'
#' @examples
#' # identify NHDPlusV2 COMID
#' a <- net_sample(nhdplus_path = getwd(), vpu = "01", ws_order = 6, n = 5)
#' # delineate stream network
#' b <- net_delin(group_comid = as.character(a[,"COMID"]), nhdplus_path = getwd(), vpu = "01")
#' calculate topology summary
#' c <- net_calc(netdelin = b, vpu = "01", nhdplus_path = getwd())
#' @export

net_calc <- function(netdelin, vpu, nhdplus_path){
  directory <- grep(paste(vpu, "/NHDPlusAttributes", sep = ""),
                    list.dirs(nhdplus_path, full.names = T),
                    value = T)
  Vaa <- grep("PlusFlowlineVAA.dbf",
              list.files(directory[1], full.names = T),
              value = T)
  slope <- grep("elevslope.dbf",
                list.files(directory, full.names = T),
                value = T)
  flow.files <- grep("PlusFlow.dbf",
                     list.files(directory[1], full.names = T),
                     value = T)

  flow <- foreign::read.dbf(flow.files)
  vaa <- foreign::read.dbf(Vaa)
  slope <- foreign::read.dbf(slope)
  names(slope) <- toupper(names(slope))
  names(vaa) <- toupper(names(vaa))

  full.net <- unique(netdelin$Network)

  reach.data <- Reduce(function(x, y)
    merge(x, y, by.x = "net.comid", by.y = "COMID", all.x = T),
    list(full.net, vaa, slope))

  #calculate network order
  WS.ord <- reach.data[as.character(reach.data[,"group.comid"]) ==
                         as.character(reach.data[,"net.comid"]),
                       c("net.id","M", "STREAMORDE")]

  names(WS.ord) <- c("net.id", "M", "WS.ord")

  #catchemnts catchment area
  #group by, substract, multiply
  #value at end of flowline
  cat.area <- aggregate(reach.data[, c("AREASQKM", "LENGTHKM")],
                        by = list(net.id = reach.data[,  "net.id"],
                                  group.comid = reach.data[,"group.comid"]),
                        sum)
  incr <- reach.data[as.character(reach.data[,"group.comid"]) ==
                       as.character(reach.data[,"net.comid"]),
                     c("net.id", "AREASQKM","LENGTHKM", "M")]

  incr <- merge(incr, cat.area, by = "net.id")
  area <- (incr[,"AREASQKM.y"] - incr[,"AREASQKM.x"]) + incr[,"AREASQKM.x"]*incr[,"M"]
  len <- (incr[,"LENGTHKM.y"] - incr[,"LENGTHKM.x"]) + incr[,"LENGTHKM.x"]*incr[,"M"]

  #scaled length and catchment vlaues
  cat.area <- data.frame(net.id = incr[,"net.id"],
                         AreaSQKM = area, LengthKM = len)

  drain.den <- cat.area[ ,"LengthKM"] / cat.area[ ,"AreaSQKM"]
  cat.area <- data.frame(cat.area, drain.den)

  #diversion feature count
  #counts minor flow paths of divergences
  if (any(reach.data[,c("STREAMORDE")] !=
          reach.data[,"STREAMCALC"] &
          reach.data[,"DIVERGENCE"]==2)){

    div.rm <- reach.data[reach.data[,c("STREAMORDE")] !=
                           reach.data[,"STREAMCALC"] &
                           reach.data[, "DIVERGENCE"] == 2,
                         c("net.id", "net.comid", "group.comid")]

    diver.cnt <- aggregate(div.rm[, "group.comid"],
                           by = list(div.rm[,"net.id"]),
                           length)

    names(diver.cnt) <- c("net.id", "diver.cnt")

  } else {
    diver.cnt <- data.frame(net.id = 99999, diver.cnt = 999999)
  }

  #headwaters & Tribs
  head.h2o <- aggregate(reach.data[
    reach.data[,"STARTFLAG"] == 1, "STREAMORDE"],
    by = list(reach.data[reach.data[,"STARTFLAG"] == 1, "net.id"]),
    length)

  names(head.h2o) <- c("net.id", "head.h2o")

  trib.jun <- as.numeric(as.character(head.h2o[, "head.h2o"])) - 1
  head.h2o <- data.frame(head.h2o, trib.jun)

  #edge count
  edges <- head.h2o[,"head.h2o"] + head.h2o[,"trib.jun"]
  reach.cnt <- data.frame(net.id = head.h2o[,"net.id"], reach.cnt = edges)

  #relief - at outlet; I want to move this to basin metric
  #maxelev <- aggregate(reach.data[,"MAXELEVSMO"],
  #                    by = list(reach.data[,"group.comid"]),
  #                   max)
  #minelev <- aggregate(reach.data[, "MINELEVSMO"],
  #                    by = list(reach.data[, "group.comid"]),
  #                   min)
  #relief <- maxelev[,"x"]-minelev[,"x"]
  #relief <- data.frame(COMID = maxelev[,"Group.1"],
  #                    maxelev = maxelev[,"x"],
  #                   minelev = minelev[,"x"],
  #                  releif = relief)

  #aggregate table for summaries of group comid
  data.out <- unique(full.net[, c("net.id","group.comid", "vpu")])

  names(data.out)[2] <- "COMID"

  data.out <- Reduce(function(x, y)
    merge(x, y, by = "net.id", all.x = T),
    list(data.out, WS.ord,head.h2o, reach.cnt, diver.cnt, cat.area))#, relief))

  names(data.out)[2] <- "group.comid"

  return(data.out)
}


library(ggplot2)
library(gganimate)

#Data source: United Nations, Department of Economic and Social Affairs, Population Division (2019). World Population

mydata=read.csv("C:/Users/GAPE/Downloads/fertility-vs-child-mortality.csv",header=T)

mydata=mydata[!is.na(mydata$Year)&!is.na(mydata$Country)&!is.na(mydata$Mortality)&!is.na(mydata$Population)&!is.na(mydata$Fertility),]

p = ggplot(mydata[mydata$Year>=1980,], aes(Fertility, Mortality, size = Population, colour = Country)) +
  theme_minimal()+
  geom_point(alpha = 0.8) +
  scale_size(range = c(2, 12)) +
  theme(legend.position = 'none') +
  labs(title = 'Global change in child mortality by fertility. Year: {frame_time}',subtitle='Points for countries proportional to population', x = 'Fertility (Live births per woman)', y = 'Child mortality (< 5 years, %)') +
  transition_time(Year) +
  ease_aes('linear')

animate(p, 100, 10)


#' @title predict.eoa
#'
#' @description Prediction method for eoar objects.
#'
#' @param object an eoar object produced by function \code{eoar}
#'
#' @param newdata A data frame containing new covariate
#' values at which to do the prediction.
#'
#' @param type Text string specifying the type of prediction.
#' \itemize{
#'   \item \code{"response"} returns the predicted value of the eoar rate parameter,
#' lambda, evaluated using the median coefficient estimates
#' in \code{object}. \code{"response"}
#' evaluates the model using \code{object$estimates[object$coef.labels]}
#' (or \code{coef(object)}) as coefficients, and returns the result after
#' taking the anti-log (exp()).
#'   \item \code{"quantile"} returns a quantile from the distribution of
#'   the eoar rate parameter, lambda, evaluated using all the posterior samples
#'   of the coefficients.  \code{"quantile"} evaluates the model using
#'   all posterior samples of the coefficients housed in \code{object$out},
#'   and returns the \code{p}-th quantile(s) from the distribution of
#'   these predicted values (in anti-log space). This provides a way to
#'   compute predictive intervals for the response.  Setting
#'   \code{type="quantile"} and \code{p=c(0.025, 0.975)} produces a
#'   95% predictive interval for the predicted values.
#' }
#'
#' @param p A vector specifing which quantiles to return when
#' \code{type="quantile"}.
#'
#' @param \dots Included for compatability with other predict methods.
#'
#' @return If \code{newdata} is NULL, the predicted
#' lambda values for every row of the fitting data set.
#' If \code{newdata} is not NULL, results of applying
#' the lambda model to covarates in \code{newdata}.
#'
#' @author Trent McDonald
#'
#' @export
predict.eoar <- function(object, newdata, type="response", p=c(0.025,0.5,0.975), ...){

  X <- model.matrix(object, newdata)
  if(type=="response"){
    preds <- X %*% matrix(coef(object),ncol=1)
    preds <- exp(preds)
  } else {
    betaMat <- t(as.matrix(object$out[,object$coef.labels]))
    preds <- X %*% betaMat
    preds <- exp(preds)
    preds <- t(apply( preds, 1, quantile, p=p))
  }
  preds

}


library(raster)
library(WatershedTools)
library(sf)
library(data.table)
library(RSQLite)

metabDB <- dbConnect(RSQLite::SQLite(), "../metabolismDB/metabolism.sqlite")
dbExecute(metabDB, "PRAGMA foreign_keys = ON")

metadat <- fread("catchment_list.csv")[catchment == "thur"]
shareDir <- file.path(metadat$dir, metadat$catchment, metadat$version)

drain <- raster(file.path(shareDir, "drainage.tif"))
accum <- raster(file.path(shareDir, "accumulation.tif"))
elev <- raster(file.path(shareDir, "filled_dem.tif"))
stream <- raster(file.path(shareDir, "thur_stream.tif"))
catchmentAreas <- raster(file.path(shareDir, "catchment_area.tif"))

# get discharge
qSites = data.table(dbReadTable(metabDB, "siteDischargeView"))[expedition == 'ThurFall2018']
qSites = st_as_sf(qSites, coords = c('x', 'y'), crs = qSites$epsg[1])
qSites$catchmentArea <- raster::extract(catchmentAreas, qSites)

## make data frame of catchment areas to compute
caDF = data.table(area = values(catchmentAreas), coordinates(catchmentAreas))
caDF = caDF[complete.cases(caDF),]

# get predicted Q for each point
colnames(qSites)[grep("(discharge|catchmentArea)", colnames(qSites))] = c('Q', 'A')
q = discharge_scaling(caDF$area, qSites)
q = rasterFromXYZ(cbind(caDF$x, caDF$y, q))
writeRaster(q, file = file.path(shareDir, "tmp", "discharge.tif"))

val = values(q)
val = val[!is.na(val)]
plot(log(caDF$area), log(val), xlab="log(Catchment Area)", ylab="log(discharge)",
		pch='x', cex=0.3, col='red', main=x)
points(log(qSites$A), log(qSites$Q), pch=16, cex=0.7, col='blue')

dat = data.table(x = coordinates(q)[,1], y = coordinates(q)[,2], q = values(q))
dat = dat[complete.cases(dat)]
geom <- hydraulic_geometry(dat$q)
coordinates(geom) <- dat[,c('x', 'y')]
gridded(geom) <- TRUE
geom <- stack(geom)
proj4string(geom) <- proj4string(catchmentAreas)

gdir = file.path(shareDir, "geometry_ThurFall2018")
dir.create(gdir, showWarnings = FALSE)

for(x in names(geom)) {
	writeRaster(geom[[x]], file.path(gdir, paste0(x, "_", "ThurFall2018.tif")),
			options = c("COMPRESS=LZW", "PREDICTOR=3"))
}

# only if needed due to non-matching extents
compareRaster(stream, drain, elev, accum, catchmentAreas, geom)
## two extents
# small one
# 	stream, catchmentAreas, geom
# big one
# 	drain, elev, accum
drain = crop(drain, stream)
elev = crop(elev, stream)
accum = crop(accum, stream)
compareRaster(stream, drain, elev, accum, catchmentAreas, geom)

thurWS = Watershed(stream = stream, drainage = drain, elevation = elev,
		accumulation = accum, catchmentArea = catchmentAreas,
		otherLayers = geom)
thurWS$data$slope = wsSlope(thurWS)
saveRDS(thurWS, file.path(shareDir, "watershed_ThurFall2018.rds"))

dbDisconnect(metabDB)


# Reproduce disease map model, as developed by Aki and colleagues

rm(list = ls())
gc()
set.seed(1954)

# modelName <- "disease_map"
modelName <- "disease_map_ela"
# modelName <- "skim_logit_ela"

setwd("~/Desktop/Code/laplace_approximation/Script/")
.libPaths("~/Rlib")

# Setting for habenero cluster
# setwd("/rigel/home/ccm2172/laplace_approximation/Script")
# .libPaths("/rigel/home/ccm2172/Rlib")

scriptDir <- getwd()
modelDir <- file.path(scriptDir, "models3")
dataDir <- file.path(scriptDir, "data")
outDir <- file.path(scriptDir, "deliv", modelName)
delivDir <- file.path("deliv", modelName)

dataFile <- "disease_data_full.r"
# dataFile <- "disease_data_100.r"

library(rstan)
library(cmdstanr)
set_cmdstan_path("~/Desktop/Code/laplace_approximation/cmdStan/")
# set_cmdstan_path("/rigel/home/ccm2172/laplace_approximation/cmdStan")
library(parallel)
# library(rootSolve)
# library(invgamma)
source(file.path("tools", "cmdStanTools.r"))
source(file.path("tools", "stanTools.r"))

data <- read_rdump(file.path(dataDir, dataFile))

reduced <- TRUE
n_sample <- 250  # 911
if (reduced) {
  # select_index <- sample(1:911, n_sample)
  bin <- floor(911 / n_sample)
  select_index <- rep(NA, n_sample)
  for (i in 1:n_sample) select_index[i] <-
      sample(((i - 1) * bin + 1):(i * bin), 1)
  # select_index <- seq(from = 1, to = 910, by = 5)
  data$x <- data$x[select_index, ]
  data$y <- data$y[select_index]
  data$ye <- data$ye[select_index]
  data$n_obs <- n_sample
}

##########################################################################
# Construct prior (see Michael's dsicussion on inverse-gamma). Use
# range of the data to find lower and upper bounds for rho.
if (FALSE) {
  fit <- stan(file = "models2/inv_gamma_prior.stan", iter = 1, warmup = 0, chains = 1,
              seed = 5838298, algorithm = "Fixed_param")
}
# a = 2.42393
# b = 14.8171
data$rho_alpha_prior <- 2.42393
data$rho_beta_prior <- 14.8171
with(data, stan_rdump(ls(data), "data/disease_data.r"))

###########################################################################
if (TRUE) {
  file <- file.path(modelDir, modelName, paste0(modelName, ".stan"))
  mod <- cmdstan_model(file)
}

nChains <- 4
num_cores <- min(nChains, detectCores())

fit <- mod$sample(
  data = data, num_chains = nChains, num_cores = num_cores,
  num_warmup = 500, num_samples = 500, seed = 123,
  adapt_delta = 0.8)
stanfit <- read_stan_csv(fit$output_files())
dir.create(outDir)
saveRDS(stanfit, file = file.path(outDir, paste(modelName, n_sample,
                                         "_Fit.Rsave", sep = "")))

# parms <- c("alpha", "rho", "theta_pred[1]", "theta_pred[2]", "lp__")
parms <- c("alpha", "rho", "theta[1]", "theta[2]", "lp__")

dir.create(delivDir)
pdf(file = file.path(delivDir, paste(modelName,"Plots%03d.pdf",
                                     sep = "")),
    width = 6, height = 6, onefile = F)

mcmcHistory(stanfit, parms)
mcmcDensity(stanfit, parms, byChain = TRUE)
mcmcDensity(stanfit, parms)

dev.off()

ptable <- parameterTable(stanfit, parms)
time <- sum(colSums(get_elapsed_time(stanfit)))
eff <- ptable[, 9] / time
eff_bulk <- ptable[, 21] / time
eff_tail <- ptable[, 22] / time
ptable <- cbind(ptable, eff, eff_bulk, eff_tail)

write.csv(ptable, file = file.path(delivDir, paste(modelName,
                                                   "ParameterTable.csv", sep = "")))

ptable[, c(1:3, 21, 22, 24, 25)]


model_initializeR <- function(data, data_init, init_pars, model = "Multinomial", period_start, end_beta,
                  alpha = 1, beta_1 = 0.6, delta_1 = 0.3,
                  lambda = 1 / (66.26 * 365), mu = 1 / (66.26 * 365), D_d = 17.8, De = 5.2,
                  Dr = 17.8, mCFR = NULL, init.exposed.ratio = 3, init.confirmed.ratio = 0.0588,
                  auto.initialize = TRUE,opt_num=100, override = FALSE, ... ){
  if(data_init[1]==0){
    stop("Please enter a non-zero value for the initial number of  total confirmed cases. A suggestion is replace 0 by 1 ")
  }
  if(model=="Multinomial"){
    obsP = data$Confirmed
    obsR = data$Recovered
    obsD = data$Deceased

  }
  else if(model=="Poisson"||model=="Binomial"){
    obsP=data$Confirmed
  }

  if(is.null(mCFR)) mCFR = tail(cumsum(obsD) / cumsum(obsD+obsR),1)

  mu_c = mCFR/D_d
  Dr = Dr/(1-mCFR)

  ## Fixed parameters

  fix_pars = c(alpha = alpha, beta_1 = beta_1, delta_1 = delta_1,
               lambda = lambda, mu = mu, mu_c = mu_c, De = De, Dr = Dr, N = N)

  ## Initializing parameters

  ## Initial states

  #initial number of ascertained cases
  P0  = data_init[1] - data_init[2] - data_init[3]
  #initial number of ascertained recoveries
  RR0 = data_init[2]
  #initial number of ascertained deaths
  DR0 = data_init[3]
  #initial number of unascertained infectious cases
  U0 =round( (P0) * (1-init.confirmed.ratio)/init.confirmed.ratio)
  #initial number of ascertained recoveries
  RR0 = data_init[2]
  #initial number of unascertained recoveries
  RU0 = round(((1-init.confirmed.ratio)/init.confirmed.ratio) * RR0)
  #initial number of ascertained deaths
  DR0 = data_init[3]
  #initial number of unascertained deaths
  DU0 = round(((1-init.confirmed.ratio)/init.confirmed.ratio) * DR0)
  #initial number of latent cases, De=5.3
  E0 = init.exposed.ratio*(U0 + P0)
  #initial number of susceptible individuals
  S0 = N - (E0 + U0 + P0 + RU0 + RR0 + DU0 + DR0)
  # initial states c(S = S0, E = E0, U = U0, P = P0,  RU = RU0, RR = RR0, DU = DU0, DR = DR0)
  yinit = c("S" = S0, "E" = E0, "U" = U0, "P" = P0, "RU" = RU0, "RR" = RR0, "DU" = DU0, "DR" = DR0)

  if(period_start[1] != 1){
    period_start = c(1, period_start)
  }

  n_period=length(period_start)
  if(auto.initialize){
    init_pars = par_initializeR(data = data, data_init = data_init, end_beta = end_beta, init_pars = init_pars, fix_pars = fix_pars,
                                opt_num = opt_num,period_start=period_start,init_state_num = yinit, model = model,
                                ...)[3:(2*n_period+2)]
    cat(" " , fill = TRUE)
    cat("MLE estimates : " , fill = TRUE)
    cat("beta = (", paste0(round(init_pars[1:n_period],2)/2, collapse = ", "), ")", fill = TRUE)
    cat("r = (", paste0(round(init_pars[n_period + 1:n_period],3), collapse = ", "), ")", fill = TRUE)
    cat(" " , fill = TRUE)
  }
  else{
    if(is.null(init_pars) && !override){
      stop("Please enter the initial Parameters")
    }
  }

  if(length(period_start) != length(init_pars)/2 && !override)
    stop("Number of periods is not equal to number of initial parameters")

  return(list("init_pars" = init_pars, "fix_pars" = fix_pars, "init_state_num" = yinit, "period_start" = period_start))

}