#Density plot of out of sample R2 values as a function of spatial scale (core-plot-site).
rm(list=ls())
source('paths.r')
source('NEFI_functions/zero_truncated_density.r')

library(RCurl)
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/zero_truncated_density.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

# only include complete cases (no missing data)
compl_cases <- F

#set output path.----
if (compl_cases==T){ output.path <- 'valR2_fg_compl_cases_density_fig.png'
} else output.path <- 'valR2_fg_density_fig.png'
#output.path <- NEON_cps_out.of.sample_rsq_density_figure.path

#load in-sample fits.----
pl.cal <- readRDS(prior_16S_all.fg.groups_JAGSfits.path)
# pl.cal <- readRDS(ted_ITS_prior_phylo.group_JAGSfits)
# pl.cal$function_group <- fg.cal
#pl.cal <- readRDS(paste0(scc_gen_16S_dir, "JAGS_output/prior_phylo_JAGSfit_fewer_taxa.rds"))
#phylum.mod <- readRDS(paste0(scc_gen_16S_dir,"JAGS_output/prior_phylo_JAGSfit_phylum_fewer_taxa_more_burnin.rds"))
#pl.cal$phylum <- pl.cal$phylum

#get in sample r2 values.----
cal.rsq <- list()
for(i in 1:length(pl.cal)){
  if(names(pl.cal)[i] != 'function_group'){
    y <- pl.cal[[i]]$no.nutr.preds$observed
    x <- pl.cal[[i]]$no.nutr.preds$predicted
  }
  if(names(pl.cal)[i] == 'function_group'){
    y <- pl.cal[[i]]$no.nutr.preds$observed
    x <- pl.cal[[i]]$no.nutr.preds$predicted
  }
  lev.rsq <- list()
  for(k in 1:ncol(y)){
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    names(rsq) <- colnames(y)[k]
    lev.rsq[[k]] <- rsq
  }
  lev.rsq <- unlist(lev.rsq)
  lev.rsq <- lev.rsq[-grep('other',names(lev.rsq))]
  cal.rsq[[i]] <- lev.rsq
}
cal.rsq <- unlist(cal.rsq)

#load forecasts predicted and observed.----
#functional groups
# fg.cast <- readRDS(NEON_site_fcast_fg.path)
# fg.core <- readRDS(NEON_ITS_fastq_taxa_fg.path)
# #trick out to make work with phylo stuff.
# fg.core$abundances$geneticSampleID <- NULL
# fg.plot.truth <- readRDS(NEON_plot.level_fg_obs_fastq.path)
# fg.site.truth <- readRDS(NEON_site.level_fg_obs_fastq.path)
# #format fg stuff so we can pop it into the pl list.
# fg.truth <- list(fg.plot.truth,fg.site.truth)
# names(fg.truth) <- c('plot.fit','site.fit')

#phylogenetic groups.
# if (compl_cases==T){ pl.cast <- readRDS(paste0(pecan_gen_16S_dir,"/NEON_forecast_data/NEON_fcast_comp_cases.rds"))
# } else pl.cast <- readRDS(NEON_cps_fcast_all_phylo_16S.path)
pl.truth <- readRDS(NEON_all.fg_plot.site_obs_16S.path)

if (compl_cases== T){
  pl.cast <- readRDS(paste0(pecan_gen_16S_dir,"NEON_forecast_data/NEON_fcast_fg_comp_cases.rds"))
} else pl.cast <- readRDS(NEON_cps_fcast_fg_16S.path)
#pl.core <- readRDS(NEON_16S_phylo_groups_abundances.path)

#
# pl.cast <- readRDS(NEON_site_fcast_all_phylo_levels.path)
# pl.truth <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq.path)
# pl.core <- readRDS(NEON_ITS_fastq_all_cosmo_phylo_groups.path)
#merge in fg stuff
# pl.core$function_group <- fg.core
# pl.truth$function_group <- fg.truth
# pl.cast$function_group <- fg.cast

#get core, plot site R2 values out of sample.----
all.core.rsq <- list()
all.plot.rsq <- list()
all.site.rsq <- list()
for(i in 1:length(pl.cast)){
  fcast <- pl.cast[[i]]
  core.rsq <- list()
  plot.rsq <- list()
  site.rsq <- list()
  #core.level----
  y <- pl.truth[[i]]$core.fit
  #y <- (pl.core[[i]]$abundances + 1)/pl.core[[i]]$seq_total
  x <- fcast$core.fit$mean
  #make sure row and column orders match.
  rownames(y) <- gsub('-GEN','',rownames(y))
  truth <- y
    map <- readRDS(core_obs_16S.path)
  truth <- as.data.frame(truth)
  truth$deprecatedVialID <- rownames(truth)
  truth1 <- merge(truth, map[,c("deprecatedVialID", "geneticSampleID")], by = "deprecatedVialID")
  truth1 <- truth1[!duplicated(truth1$geneticSampleID),]
  rownames(truth1) <- gsub('-GEN','',truth1$geneticSampleID)
  truth <- truth1
  y <- truth

  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(x)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    names(rsq) <- fungi_name
    core.rsq[[k]] <- rsq
  }
  #plot.level----
  x <- fcast$plot.fit$mean
  y <- pl.truth[[i]]$plot.fit$mean
  #make sure row and column order match.
  rownames(y) <- gsub('\\.','_',rownames(y))
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(y)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    names(rsq) <- fungi_name
    plot.rsq[[k]] <- rsq
  }
  #site.level----
  x <- fcast$site.fit$mean
  y <- pl.truth[[i]]$site.fit$mean
  #make sure row and column order match.
  rownames(y) <- gsub('-GEN','',rownames(y))
  y <- y[rownames(y) %in% rownames(x),]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[,colnames(y) %in% colnames(x)]
  x <- x[,colnames(x) %in% colnames(y)]
  x <- x[order(match(rownames(x),rownames(y))),]
  x <- x[,order(match(colnames(x),colnames(y)))]
  #fit model, grab r2.
  for(k in 1:ncol(y)){
    fungi_name <- colnames(x)[k]
    rsq <- summary(lm(y[,k] ~ x[,k]))$r.squared
    names(rsq) <- fungi_name
    site.rsq[[k]] <- rsq
  }
  #wrap up for return.----
  all.core.rsq[[i]] <- unlist(core.rsq)
  all.plot.rsq[[i]] <- unlist(plot.rsq)
  all.site.rsq[[i]] <- unlist(site.rsq)

}
core.rsq <- unlist(all.core.rsq)
plot.rsq <- unlist(all.plot.rsq)
site.rsq <- unlist(all.site.rsq)
core.rsq <- core.rsq[-grep('other',names(core.rsq))]
plot.rsq <- plot.rsq[-grep('other',names(plot.rsq))]
site.rsq <- site.rsq[-grep('other',names(site.rsq))]

#Subset to observations that have a minimum calibration R2 value.----
pass <- cal.rsq[cal.rsq > .1]
core.rsq <- core.rsq[names(core.rsq) %in% names(pass)]
plot.rsq <- plot.rsq[names(plot.rsq) %in% names(pass)]
site.rsq <- site.rsq[names(site.rsq) %in% names(pass)]
core.d <- zero_truncated_density(core.rsq)
plot.d <- zero_truncated_density(plot.rsq)
site.d <- zero_truncated_density(site.rsq)

#png save line.----
png(filename=output.path,width=5,height=5,units='in',res=300)

#global plot settings.----
par(mfrow = c(1,1))
limx <- c(0,1)
limy <- c(0, 10)
trans <- 0.2 #shading transparency.
o.cex <- 1.3 #outer label size.
cols <- c('purple','cyan','yellow')
par(mfrow = c(1,1), mar = c(4.5,4,1,1))

#plot.----
plot(core.d,xlim = c(0, 0.8), ylim = limy, bty = 'n', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(core.d, col = adjustcolor(cols[1],trans))
polygon(plot.d, col = adjustcolor(cols[2],trans))
polygon(site.d, col = adjustcolor(cols[3],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 2.5, cex = o.cex)
legend(x = 0.6, y = 6, legend = c('core','plot','site'), col ='black', pt.bg=adjustcolor(cols,trans), bty = 'n', pch = 22, pt.cex = 1.5)

#end plot.----
dev.off()


pieces <- c("R","B","N","Q","K","N","B","R")

generateFirstRank <- function() {
  attempt <- paste0(sample(pieces), collapse = "")
  while (!check_position(attempt)) {
    attempt <- paste0(sample(pieces), collapse = "")
  }
  return(attempt)
}

check_position <- function(position) {
  if (regexpr('.*R.*K.*R.*', position) == -1) return(FALSE)
  if (regexpr('.*B(..|....|......|)B.*', position) == -1) return(FALSE)
  TRUE
}

convert_to_unicode <- function(s) {
  s <- sub("K","\u2654", s)
  s <- sub("Q","\u2655", s)
  s <- gsub("R","\u2656", s)
  s <- gsub("B","\u2657", s)
  s <- gsub("N","\u2658", s)
}

cat(convert_to_unicode(generateFirstRank()), "\n")


#' Repeats an array along an arbitrary axis
#'
#' @param x      An array object
#' @param n      Integer, how often to repeat
#' @param along  Along which axis to repeat (default: 1)
#' @return       An array that is repeated `n` times on axis `along`
#' @export
rep = function(x, n, along=1) {
    xl = base::rep(list(x), n)
    bind(xl, along=along)
}

#' @rdname rep
#' @export
crep = function(x, n) rep(x, n, along=2)

#' @rdname rep
#' @export
rrep = function(x, n) rep(x, n, along=1)


#Extract binary interactions from diet matrix
  bin_inter <- function(x) {

    bin.inter <- matrix(nrow=ncol(x)*nrow(x),ncol=3,data=NA)
    colnames(bin.inter) = c("Predator","FeedInter","Prey")

    for(i in 1:ncol(x)){
      for(j in 1:nrow(x)){
        bin.inter[((i*nrow(x))-nrow(x))+j,1] <- colnames(x)[i]
        bin.inter[((i*nrow(x))-nrow(x))+j,2] <- as.matrix(x[j,i])
        bin.inter[((i*nrow(x))-nrow(x))+j,3] <- rownames(x)[j]
      }
    }

    return(bin.inter)
  }


# app.r
# This file contains the server and ui functions of the shiny web app.
#
# For running the app form a R terminal use:
# shiny::runApp("D:\\Dokumente\\GitHub\\2D-FEM-Solver\\R Shiny Webapp\\app.r")

library(shiny)
library(shinythemes)
source("R Shiny Webapp\\2D_fem_pre_processor.r", chdir = TRUE)

# Compile the C++ source and run the solver.
init_solver()

# Call C++ functions form the compiled source to calculate all
# the displacements from the provided input file which contains
# the mesh data.
input_filename <- "R Shiny Webapp\\Mesh_Balken_V2.txt"
displacements = solve_linear_elastic(input_filename)
mises_stresses = output_mises_stress()

# Reshape data.
x <- unname(sapply(displacements, `[[`, 1))
y <- unname(sapply(displacements, `[[`, 2))
ux <- unname(sapply(displacements, `[[`, 3))
uy <- unname(sapply(displacements, `[[`, 4))

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Mechanical Linear Elastic 2D FEM Solver"),

    # Color theme of the page.
    theme = shinytheme("slate"),

    fluidRow(
        # Left sidebar panel for inputs.
        column(2,
            fluidRow(
                wellPanel(
                    h4("Solver Input Filename"),
                    textOutput("text_filename")
                )
            ),

            fluidRow(
                wellPanel(
                # Input: Select a timestep.
                sliderInput("bins",
                        "Time:",
                        min = 0,
                        max = 1,
                        value = 1),

                # Button for updating plots.
                actionButton("update", "Update Plot"),
                width = 2
                )
            )

        ),

        # Main panel.
        column(10,
            wellPanel(
                h4("Stress and Displacment Plot"),

                # Plot mesh with stresses and displacements.
                plotOutput("distPlot")
            )
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    output$text_filename <- renderText({paste(input_filename)})

    output$distPlot <- renderPlot({
        # Generate bins based on input$bins from ui.R
        bins <- input$bins

        # Draw plot in app.
        mesh_ggplot(x, y, ux*bins, uy*bins, mises_stresses)
    })
}

# Run the application
shinyApp(ui = ui, server = server)


# Util for cross-validation
library(caret)
library(foreach)
library(doParallel)
library(ggplot2)
library(reshape2)
library(scales)
library(pbapply)
source("utils/accuracy-statistics.r")
source("pixel-based/utils/load-sampling-data.r")

# Pass in the function that takes as input a data.frame and produces a cross-validated data.frame in return
CrossValidate = function(formula, data, train_function, predict_function, folds=10, fold_column=data[,"dominant_lc"],
    covariate_names=names(data), cv_seed=0xfedbeef, oversample=FALSE, packages=NULL, ...)
{
    set.seed(cv_seed)
    folds = createFolds(fold_column, folds)

    #Predictions = NULL
    #for (i in 1:length(folds))
    Predictions = foreach(fold=iter(folds), .combine=rbind, .multicombine=TRUE, .inorder=TRUE, .packages=packages) %dopar%
    {
        #fold = folds[[i]]
        TrainingData = data[-fold,]
        if (oversample)
            TrainingData = Oversample(TrainingData, fold_column=fold_column, seed=cv_seed)
        set.seed(cv_seed)
        Model = train_function(formula=formula, ..., data=TrainingData)
        #print(dim(Model[[1]]))
        #print(dim(Model[[2]]))
        Prediction = predict_function(Model, ..., newdata=data[fold,covariate_names])
        #print(dim(Prediction))
        #Predictions = rbind(Predictions, Prediction)
    }
    Predictions = Predictions[order(unlist(folds)),]
    return(Predictions)
}

# Train on and predict over ecozone clusters.
ClusterTrain = function(formula, data, train_function=NULL, val_data, predict_function=predict,
                        cv_seed=0xfedbeef, include_neighbours=FALSE, cluster_col="bc_id",
                        trainpredict_function=NULL, ...)
{
    if (is.null(train_function) && is.null(trainpredict_function))
        stop("Pass either the trainfunction or the trainpredict_function")
    set.seed(cv_seed)

    TrainClusters = if (include_neighbours) ClusterNeighbours() else {
        UniqueECs = unique(data[[cluster_col]])
        UniqueECs = as.character(UniqueECs[!is.na(UniqueECs)])
        ECList = as.list(UniqueECs)
        names(ECList) = UniqueECs
        ECList
    }
    # Remove validation that does not belong to any cluster
    val_data = val_data[!is.na(val_data[[cluster_col]]),]

    Prediction = pblapply(TrainClusters, function(x) {
        ClusterRows = val_data[[cluster_col]]==x[[1]]
        if (!is.null(train_function))
        {
            model = train_function(formula=formula, ..., data=data[data[[cluster_col]] %in% x,]) # Train on zone plus (optionally) neighbours
            ResultMat = predict_function(model, ..., newdata=val_data[ClusterRows,]) # Predict on zone only
        } else {
            ResultMat = trainpredict_function(formula=formula, data=data[data[[cluster_col]] %in% x,], newdata=val_data[ClusterRows,], ...)
        }
        if (!is.matrix(ResultMat))
            ResultMat = as.matrix(ResultMat)
        cbind(ResultMat, order=which(ClusterRows))
    })
    ResultOrder = do.call(rbind, Prediction)
    stopifnot(all(!duplicated(ResultOrder[,"order"]))) # No point should be in two zones
    ResultInOrder = ResultOrder[order(ResultOrder[,"order"]),]
    ResultInOrder = ResultInOrder[,!colnames(ResultInOrder) %in% "order"] # Remove order column

    return(ResultInOrder)
}

# Run binary relevance, i.e. one model per class.
# Formula should be empty on LHS, i.e. paste0("~", paste(Covariates, collapse = "+"))
BinaryRelevance = function(formula, data, train_function, val_data, predict_function=predict,
    seed=0xfedbeef, classes=GetCommonClassNames(), scale=TRUE, filename=NULL, overwrite=FALSE, LeaveZeroes = FALSE, ...)
{
    if (!is.null(filename) && !overwrite && file.exists(filename))
    {
        Predictions = read.csv(filename)
        if (scale) Predictions = ScalePredictions(Predictions, LeaveZeroes)
        return(Predictions)
    }

    Predictions = matrix(ncol=length(classes), nrow=nrow(val_data), dimnames=list(list(), classes))

    for (Class in classes)
    {
        print(Class)
        ClassFormula = update.formula(formula, paste0(Class, " ~ ."))
        set.seed(seed)
        Model = train_function(ClassFormula, data=data, ...)
        gc(full=TRUE)
        RegPredictions = predict_function(Model, newdata=val_data, ...)
        Predictions[, Class] = RegPredictions
        rm(Model, RegPredictions)
        gc(full=TRUE)
    }

    if (!is.null(filename))
    {
        OutDir = dirname(filename)
        if (!dir.exists(OutDir))
            dir.create(OutDir)
        write.csv(Predictions, filename, row.names=FALSE)
    }

    if (scale) Predictions = ScalePredictions(Predictions, LeaveZeroes)

    return(as.data.frame(Predictions))
}

# Rescale predictions so that htey add up to 100%
ScalePredictions = function(Predictions, LeaveZeroes = TRUE)
{
    Predictions = as.matrix(Predictions)
        Predictions = Predictions / rowSums(Predictions) * 100
        # There is a possibility that all classes have been predicted as 0, so we can't normalise.
        # In that case we just keep them as 0%. It won't add up to 100%. Alternatively we can set it to 1/nclass.
        Predictions[is.nan(Predictions)] = if (LeaveZeroes) 0 else 100/ncol(Predictions)
        return(as.data.frame(Predictions))
}

# Validation metrics and plots
AccuracyStatisticsPlots = function(predicted, observed, ...)
{
    # RMSE values and correlation
    AST = AccuracyStatTable(predicted, observed)
    print(AST)
    op = par(mfrow=c(2,2))
    barplot(AST$RMSE, names.arg=rownames(AST), main="RMSE")
    barplot(AST$MAE, names.arg=rownames(AST), main="MAE")
    barplot(AST$ME, names.arg=rownames(AST), main="ME")
    try(corrplot::corrplot(cor(predicted, observed), method="ellipse"))
    par(op)
}

# Simple oversampling function
Oversample = function(Data, fold_column = Data[[FactorName]], seed=0xfedbeef)
{
    Factor = fold_column
    MaxSamples = max(table(Factor))
    Result=NULL

    set.seed(seed)
    for (ClassName in levels(Factor))
    {
        OneClassOnly = Data[Factor==ClassName,]
        ClassRows = sample(1:nrow(OneClassOnly), MaxSamples, replace=TRUE)
        ClassDF = OneClassOnly[ClassRows,]
        Result = rbind(Result, ClassDF)
    }
    return(Result)
}

# Plot a 1:1 hexplot, expects a data.frame rather than a matrix, and it should be 0-100 rather than 0-1
PlotHex = function(predicted, observed, main="")
{
    hp = ggplot(data.frame(Prediction=unlist(predicted), Truth=unlist(observed)), aes(Truth, Prediction)) +
        geom_hex() +# xlim(0, 100) + ylim(0, 100) +
        scale_fill_gradient2(high="red", mid=muted("red"), low="grey90", midpoint=log(1000), trans="log") +
        #scale_fill_distiller(palette="Spectral", trans="log") + #log scale, 7 was the oranges
        geom_abline(slope=1, intercept=0) + ggtitle(main)
    return(hp)
}

# Plot 1:1 boxplot
PlotBox = function(predicted, observed, main="", binpredicted=FALSE, transposeaxes=FALSE,
                   varwidth = TRUE, outlier.size = 0.3, outlier.alpha = 0.1, width=0.2, display.n=FALSE)
{
    #OneToOne = data.frame(Predicted=seq(0, 100, 10), Bins=1:11)
    if (!binpredicted) {
        TruthBins = unlist(observed)
        TruthBins = round(TruthBins, -1)
        ValidationDF = data.frame(Truth=unlist(observed), Bins=as.factor(TruthBins), Predicted=unlist(predicted))
        OneToOne = data.frame(Predicted=as.numeric(levels(ValidationDF$Bins)), Bins=1:length(levels(ValidationDF$Bins)))
        ncount = if (display.n) {
            paste(levels(ValidationDF$Bins),"\n(N=",round(table(ValidationDF$Bins)/1000),"k)",sep="")
        } else waiver()
        ggplot(ValidationDF, aes(Bins, Predicted)) +
            stat_boxplot(geom ='errorbar', width=width) +
            geom_boxplot(varwidth = varwidth, outlier.size = outlier.size, outlier.alpha = outlier.alpha) +
            geom_line(data=OneToOne) +
            xlab("Reference") +
            scale_x_discrete(labels=ncount) +
            ggtitle(main)
    } else {
        PredBins = unlist(predicted)
        PredBins = round(PredBins, -1)
        ValidationDF = data.frame(Truth=unlist(observed), Bins=as.factor(PredBins), Predicted=unlist(predicted))
        OneToOne = data.frame(Predicted=as.numeric(levels(ValidationDF$Bins)), Bins=1:length(levels(ValidationDF$Bins)))
        if (!transposeaxes)
        {
            ncount = if (display.n) {
                paste(levels(ValidationDF$Truth),"\n(N=",round(table(ValidationDF$Truth)/1000),"k)",sep="")
            } else waiver()
            ggplot(ValidationDF, aes(Truth, Bins)) +
                stat_boxplot(geom ='errorbar', width=width) +
                geom_boxplot(varwidth = varwidth, outlier.size = outlier.size, outlier.alpha = outlier.alpha) +
                geom_line(data=OneToOne, aes(Predicted, Bins)) +
                ylab("Predicted") + xlab("Reference") +
                scale_x_discrete(labels=ncount)+
                ggtitle(main)
        } else {
            ncount = if (display.n) {
                paste(levels(ValidationDF$Bins),"\n(N=",round(table(ValidationDF$Bins)/1000, 1),"k)",sep="")
            } else waiver()
            ggplot(ValidationDF, aes(Bins, Truth)) +
                stat_boxplot(geom ='errorbar', width=width) +
                geom_boxplot(varwidth = varwidth, outlier.size = outlier.size, outlier.alpha = outlier.alpha) +
                geom_line(data=OneToOne, aes(Bins, Predicted)) +
                xlab("Predicted") + ylab("Reference") +
                scale_x_discrete(labels=ncount)+
                ggtitle(main)
        }
    }
}

# Accuracy, Precision, Uncertainty (RMSE, MAE, ME) plot
APUPlot = function(predicted, observed)
{
    GetASTable = function(Class)
    {
        PredClass = if (Class != "Overall") predicted[,Class] else unlist(predicted)
        TruthClass = if (Class != "Overall") observed[,Class] else unlist(observed)
        PredBins = round(PredClass, -1)
        ValidationDF = data.frame(Truth=TruthClass, Bins=as.factor(PredBins), Predicted=PredClass)
        BinAS = t(sapply(levels(ValidationDF$Bins), function(Bin) {
            ValidationBin = ValidationDF[ValidationDF$Bins == Bin,]
            AS = AccuracyStats(ValidationBin$Predicted, ValidationBin$Truth)
            return(c(unlist(AS), obs=nrow(ValidationBin)/nrow(ValidationDF)*100, obsabs=nrow(ValidationBin), bin=as.numeric(Bin)))
        }))
        BinAS = data.frame(BinAS, class=Class)
        return(BinAS)
    }
    BinAS = lapply(GetCommonClassNames(), GetASTable)
    BinAS = c(list(GetASTable("Overall")), BinAS)
    BinAS = do.call("rbind", BinAS)
    # Exclude too small bins
    BinAS = BinAS[BinAS$obsabs > 10,]
    # Reorder and prettify names
    ClassNames = PrettifyNames(BinAS$class)
    BinAS$class = factor(ClassNames, c("Overall", unique(ClassNames[ClassNames != "Overall"])))
    scaleval = 1#1.5 # 300
    ggplot(BinAS, aes(x=bin, y=RMSE)) + geom_line(aes(colour="RMSE")) +
        geom_line(aes(y=MAE, colour="MAE")) + geom_line(aes(y=ME, colour="ME")) +
        geom_line(aes(y=RMSEAdj, colour="RMSEAdj")) +
        geom_col(aes(y=obs/scaleval, fill="Density"), alpha=0, colour="black") +
        scale_y_continuous(sec.axis = sec_axis(~.*scaleval, name = "Probability density (%)")) +
        labs(x="Predicted fraction (%)", y="Statistic (%)") +
        scale_colour_discrete(name = 'Statistic', breaks=c("RMSE", "MAE", "ME", "RMSEAdj")) + scale_fill_manual(name = 'Histogram', values=c("Density"="white")) +
        facet_wrap(vars(class), nrow=2)
}

# Boxplot comparison between different methods
# predicted_list is a list with the prediction table, with the name being the name of the model
ggplotBox = function(predicted_list, observed, main = "", ...)
{
    ModelData = NULL
    for (i in 1:length(predicted_list))
    {
        predicted = predicted_list[[i]]
        ModelName = names(predicted_list)[i]
        DiffDF = predicted - observed
        DiffMelt = melt(abs(DiffDF), variable.name="Class", value.name="AE", measure.vars=1:length(DiffDF))
        DiffMelt$Model = ModelName
        # Duplicate to add an "overall" class
        DiffAll = DiffMelt
        DiffAll$Class = "Overall"
        DiffMelt = rbind(DiffAll, DiffMelt)
        ModelData = rbind(ModelData, DiffMelt)
    }
    ModelData$Model = factor(ModelData$Model, levels=names(predicted_list), ordered=TRUE)

    ggplot(ModelData, aes(x=Model, y=AE, fill=Class)) + geom_boxplot(...) + ggtitle(main) +
        stat_summary(fun = mean, geom = "errorbar",
                     aes(ymax = ..y.., ymin = ..y.., group = Class),
                     width = 0.75, linetype = "dotted", position = position_dodge())
}

ggplotBoxLines = function(predicted_list, observed, main = "", ...)
{
    ModelData = NULL
    for (i in 1:length(predicted_list))
    {
        predicted = predicted_list[[i]]
        ModelName = names(predicted_list)[i]
        DiffDF = predicted - observed
        DiffMelt = melt(abs(DiffDF), variable.name="Class", value.name="AE", measure.vars=1:length(DiffDF))
        DiffMelt$Model = ModelName
        # Duplicate to add an "overall" class
        DiffAll = DiffMelt
        DiffAll$Class = "Overall"
        DiffMelt = rbind(DiffAll, DiffMelt)
        ModelData = rbind(ModelData, DiffMelt)
    }
    ModelData$Model = factor(ModelData$Model, levels=names(predicted_list), ordered=TRUE)

    ggplot(ModelData, aes(x=Model, y=AE, fill=Class)) + ggtitle(main) +
        stat_summary(fun = mean, geom = "errorbar",
                     aes(ymax = ..y.., ymin = ..y.., group = Class, colour = Class),
                     width = 0.75)
}

ggplotBar = function(ModelsToPlot, statistic="RMSE", ylab=NULL, digits=0, textsize=2.5, textvjust=-0.1, ...)
{
    if (is.null(ylab)) ylab=statistic
    ModelStats=NULL
    for (i in 1:length(ModelsToPlot))
    {
        LMM = AccuracyStatTable(ModelsToPlot[[i]], Truth[,Classes], ...)[statistic]
        LMM[[paste0(statistic,"R")]] = round(LMM[[statistic]], digits = digits) # For printing rounded numbers
        LMM$Model=names(ModelsToPlot)[i]
        ClassNames = PrettifyNames(rownames(LMM))
        LMM$Class=factor(ClassNames, c("Overall", ClassNames[ClassNames != "Overall"]))
        ModelStats = rbind(ModelStats, LMM)
    }
    ModelStats$Model = factor(ModelStats$Model, levels = names(ModelsToPlot))
    ggplot(ModelStats, aes_string("Model", statistic, fill="Class")) +
        geom_col(position = "dodge", colour="black") +
        geom_text(aes_string(label=sprintf("%s", paste0(statistic,"R"))), position=position_dodge(width = 0.9), vjust=textvjust, size=textsize) +
        scale_fill_manual(name = "Class", values = GetCommonClassColours(TRUE, 0.1)) +
        coord_cartesian(clip = 'off') + ylab(ylab)
}

# Additional statistics per class: how well we predict 0, 100, 0<x<50, 50<x<100
OneToOneStats = function(predicted, observed, row.name="")
{
    predicted = unlist(predicted)
    observed = unlist(observed)

    ZeroPredictions = predicted[observed == 0] == 0
    HundredPredictions = predicted[observed == 100] == 100
    LRidx = observed > 0 & observed <= 50
    LRPredictions = predicted[LRidx] > 0 & predicted[LRidx] <= 50
    URidx = observed > 50 & observed < 100
    URPredictions = predicted[URidx] > 0 & predicted[URidx] <= 50

    ZeroAccuracy = mean(ZeroPredictions)
    ZeroSD = sd(ZeroPredictions)
    HundredAccuracy = mean(HundredPredictions)
    HundredSD = sd(HundredPredictions)
    LowerRange = mean(LRPredictions)
    LowerSD = sd(LRPredictions)
    UpperRange = mean(URPredictions)
    UpperSD = sd(URPredictions)

    Result = data.frame(ZeroAccuracy = ZeroAccuracy, ZeroSD=ZeroSD,
        LowerRange=LowerRange, LowerSD=LowerSD,
        UpperRange=UpperRange, UpperSD=UpperSD,
        HundredAccuracy=HundredAccuracy, HundredSD=HundredSD)
    rownames(Result) = row.name
    return(Result)
}

# Looped over all classes
OneToOneStatTable = function(predicted, observed, long=FALSE)
{
    Result = OneToOneStats(predicted, observed, "Overall")
    for (i in 1:ncol(observed))
    {
        Result = rbind(Result, OneToOneStats(predicted[,i], observed[,i], names(observed)[i]))
    }

    if (long) return(OneToOneStatTableToLong(Result))
    return(Result)
}

# Convert stat table to long format
OneToOneStatTableToLong = function(OTOST)
{
    LongAcc = OTOST[,seq(1, ncol(OTOST), 2)]
    LongSD = OTOST[,seq(2, ncol(OTOST), 2)]
    LongAcc$class = rownames(LongAcc)
    LongSD$class = rownames(LongSD)
    AccLong = melt(LongAcc, id.vars="class", variable.name="statistic", value.name="accuracy")
    SDLong = melt(LongSD, id.vars="class", variable.name="statistic", value.name="sd")
    Result = cbind(AccLong, sd=SDLong[,3])
    return(Result)
}

OneToOneStatPlot = function(predicted, observed, main="")
{
    OOTable = OneToOneStatTable(predicted, observed)
    OOTableLong = OneToOneStatTableToLong(OOTable)
    print(ggplot(OOTableLong, aes(class, accuracy, fill=statistic)) +
        geom_bar(stat="identity", position="dodge") +
        geom_errorbar(aes(ymax=accuracy+sd, ymin=accuracy-sd), position="dodge") +
        ggtitle(main))
    return(OOTable)
}

# Spatial residual bubbleplot
# Predicted and observed should be data.frames with 100 as max value
# none.threshold: What to take as "no bias"; ==0 is very rare, and 5% off is fine
ResidualBubblePlot = function(predicted, observed, geometry, none.threshold=5, main="")
{
    Resids = predicted-observed
    Resids.sf = st_set_geometry(Resids, geometry)
    Resids.long = reshape2::melt(Resids.sf, id.vars="geometry", variable.name="class")
    Resids.long$size = abs(Resids.long$value)
    Resids.long$type = ifelse(Resids.long$value > none.threshold, "positive", ifelse(Resids.long$value < -none.threshold, "negative", "none"))
    ggplot(Resids.long) + geom_sf(aes(colour=type, size=size), alpha=0.5) +
        scale_colour_manual(values=c(positive="red", none="green", negative="blue")) +
        scale_size(range=c(0.1, 1), breaks=c(0, 20, 40, 60, 80)) +
        facet_wrap("class") + ggtitle(main)
}

# Perform histogram matching for each class
# extremes is about whether to match extremes; 1 is yes, 0 is not for predicted 0/100, -1 is not for the corresponding quantile
HistMatchPredictions = function(predicted, training=LoadTrainingAndCovariates(), extremes=1)
{
    HMPredictions = predicted
    for (Class in names(predicted))
    {
        if (extremes == 1) {
            HMPredictions[,Class] = histmatch(predicted[,Class], training[,Class])
        } else {
            if (extremes == 0) {
                ExtremeRowsP = predicted[,Class] == 0 | predicted[,Class] == 100
            } else if (extremes == -1) {
                PercentileT0 = mean(training[,Class] == 0)
                PercentileT100 = 1-mean(training[,Class] == 100)
                ExtremeRowsP = predicted[,Class] < quantile(predicted[,Class], PercentileT0) |
                               predicted[,Class] > quantile(predicted[,Class], PercentileT100)
            }
            ExtremeRowsT = training[,Class] == 0 | training[,Class] == 100
            HMPredictions[!ExtremeRowsP,Class] = histmatch(predicted[!ExtremeRowsP,Class], training[!ExtremeRowsT,Class])
        }
    }

    # Sometimes, the histograms match in the way that everything becomes 0, so it's impossible to scale everything.
    # In cases like that, restore original values.
    ZeroRows = apply(HMPredictions, 1, function(x)all(x==0))
    HMPredictions[ZeroRows,] = predicted[ZeroRows,]
    # Scale
    HMPredictions = HMPredictions / rowSums(HMPredictions) * 100

    return(HMPredictions)
}

# Rasterise an SF object
SfToRaster = function(sfo, xsamplingrate=0.2, ysamplingrate=0.2, layers=GetCommonClassNames(), fun=max, ...)
{
    xres = (st_bbox(sfo)["xmax"]-st_bbox(sfo)["xmin"])/xsamplingrate
    yres = (st_bbox(sfo)["ymax"]-st_bbox(sfo)["ymin"])/ysamplingrate
    rast = raster()
    sfoextent = extent(sfo)
    sfoextent@xmin = sfoextent@xmin - 0.5*xsamplingrate
    sfoextent@xmax = sfoextent@xmax - 0.5*xsamplingrate
    sfoextent@ymin = sfoextent@ymin - 0.5*ysamplingrate
    sfoextent@ymax = sfoextent@ymax - 0.5*ysamplingrate
    extent(rast) = sfoextent
    ncol(rast) = xres
    nrow(rast) = yres
    PR.ras = rasterize(sfo[layers], rast, fun=fun, ...)
    return(PR.ras)
}


#-------------------------------------------------------------------------------
# Licence:
# Copyright (c) 2012-2015 Luzzi Valerio for Gecosistema S.r.l.
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
# Name:        time.r
# Purpose:     date & time utilities
#
# Author:      Luzzi Valerio
#
# Created:     12/10/2015
#-------------------------------------------------------------------------------

#' isDate
#'
#' This function returns TRUE is text is a Date.
#' @param text - a string
#' @keywords isDate
#' @export
#' @return returns TRUE if \code{text} is a Date
#' @examples
#' isDate("2015-10-12")
isDate<-function(text){res = tryCatch(length(as.Date(text))>0,error=function(e){return(FALSE)});return(res)}

#' date2julian
#'
#' This function returns julian number for a date
#' @param date - the orginal date
#' @keywords date2julian,julian
#' @export
#' @return returns the julian number for \code{date}.
#' @examples
#' date2julian("2015-10-12")
date2julian<-function(date){return(strftime(date,"%j"))}

#' julian2date
#'
#' This function returns the date for julian number YYYYjjj
#' @param j - the julian number in the form YYYYjjj
#' @keywords julian2date
#' @export
#' @return returns the date number for \code{j}.
#' @examples
#' julian2date("2015221")
julian2date<-function(j){ j= as.numeric(j);return(strptime(j,"%Y%j"))}

#' dtos
#'
#' This function returns a date string fromatted
#' @param date   - the original date
#' @param format - the format.
#' @keywords dtos
#' @export
#' @return returns a date in a string form according to the format.
#' @examples
#' dtos("2015-10-12","%d/%m/%Y")
dtos<-function(date,format="%Y-%m-%d"){
  if (is.null(date))
    date= Sys.time()

  return(strftime(date,format))
}


pdf_file<-"pdf/hist_eurobarometer_71_1x4.pdf"
cairo_pdf(bg="grey98", pdf_file,width=12,height=3)

par(omi=c(1,0.5,0.75,0.5),mai=c(0.1,1.25,0.1,0.2),family="Lato Light",las=1)
source("scripts/inc_datadesign_dbconnect.r")

# Daten einlesen und Grafik vorbereiten

sql<-"select * from v_za4972_countries"
myData<-dbGetQuery(con,sql)
attach(myData)
par(mfcol=c(1,4))

# Grafik erstellen

for (i in 2:5) hist(myData[,i],main=names(myData[i]),xlab="")
dev.off()


context("Testing Customer")

#create a random Customer with user friendly function
#	-- showwarnings=TRUE to indicate this. Default is FALSE
#
# context("\t\tcreate a random Customer with user friendly function ")
c1<- new("Customer",showwarnings=FALSE)

# context("\t\tcreate an explizit defined Customer with S4 initializer")
c2<- new("Customer",id = "C02", label="Customer 02", x = 10, y= 20, demand = 10 )

# context("\t\tcreate a Customer from a data.frame")
df <- data.frame(id = "C02", label="Customer 02", x = 14, y= 23, demand = 10 )
c3 <- new("Customer",df)

# context("\t\tconvert Customer to data.frame")
df2 <- as.data.frame(c3)

# context("\t\tor convert a data.frame to a Customer")
c3a <- as.Customer(df2)

lic3 <- as.list(c3)
c3b <- as.Customer(lic3)
#Do some testing
#
context("\tTest 01: Are Objects created correctly?")
test_that("Test for identical objects", {
  expect_false(identical(c1,c3)) # Customer 1 and 3  should NOT be idenitical
  expect_true(identical(c3,c3a)) # Customer 3 and 3a should be idenitical
  expect_true(identical(c3,c3b)) # Customer 3 and 3b should be idenitical

})

context("\tTest 02: Are the Node-Methods for Customer working?")
test_that("Node-Methods work for Customer", {

  expect_true(getDistance(c2,c3) == 5)  			   # should be 5
	# use a cost-factor:
  expect_true(getDistance(c2,c3, costfactor = 2) == 10)   # should be 10
})
context("\tTest 03: Are the Customers correctly validated?")
test_that("Validation is implemented correctly", {

  	expect_error(c1$demand <- -12, "Invalid Object of Type 'Customer': Error with value demand: at least one value is negative. Only positive Values are allowed.")
})

context("done.")
context("--------------------------------------------------")


library(plyr)
library(dplyr)
library(Nippon)
library(stringr)
library(stringi)
library(jsonlite)
library(ggplot2)
library(ggmap)

register_google(key = "<Google API Key>")

# 中文字轉數字
chinese2digits <- function(x){
 vals <- sapply(str_split(x, "")[[1]], function(chi_digit){
   mapvalues(chi_digit, c("零", "一", "二", "三", "四", "五", "六", "七", "八", "九",
                          "十", "百", "千", "萬", "億"), c(0:10, 10^c(2,3,4,8)), FALSE)
 }) %>% as.integer
 digit_output <- 0
 base_term <- 1
 for (i in rev(seq_along(vals)))
 {
   if (vals[i] >= 10 && i == 1)
   {
     base_term <- ifelse(vals[i] > base_term, vals[i], base_term * vals[i])
     digit_output <- digit_output + vals[i]
   } else if (vals[i] >= 10)
   {
     base_term <- ifelse(vals[i] > base_term, vals[i], base_term * vals[i])
   } else
   {
     digit_output <- digit_output + base_term * vals[i]
   }
 }
 return(digit_output)
}

shop_data <- read.table("~/Desktop/R_Project/shop_data.csv", header = TRUE, sep = ",", encoding = "UTF-8", stringsAsFactors = FALSE)
shop_data <- shop_data %>%
    filter(分公司狀態 == "1") %>%
    select(公司名稱, 分公司統一編號, 分公司地址)

# 處理地址
# 不知道為什麼 mutate 弄不起來，只好用 for
for(i in 1:nrow(shop_data)){
  # 全形轉半形
  shop_data$分公司地址[i] <- zen2han(as.character(shop_data$分公司地址[i]))

  # 中文字轉數字
  # 程式碼修改自：https://www.ptt.cc/bbs/R_Language/M.1466006460.A.4DC.html
  shop_data$分公司地址[i] <- sapply(shop_data$分公司地址[i], function(x){
    pattern_starts <- "[零一二三四五六七八九十百千萬億]+樓"
    if (!str_detect(x, pattern_starts))
    return(x)
    stairs <- str_extract(x, pattern_starts)
    x <- str_replace(x, str_c("(\\d+)(", pattern_starts, ")"), "\\1, \\2")
    x <- str_replace(stairs, "樓", "") %>% chinese2digits %>% str_c("樓") %>%
    {str_replace(x, stairs, .)}
    return(x)
  }) %>% `names<-`(NULL)

  shop_data$分公司地址[i] <- sapply(shop_data$分公司地址[i], function(x){
    pattern_starts <- "[零一二三四五六七八九十百千萬億]+F"
    if (!str_detect(x, pattern_starts))
    return(x)
    stairs <- str_extract(x, pattern_starts)
    x <- str_replace(x, str_c("(\\d+)(", pattern_starts, ")"), "\\1, \\2")
    x <- str_replace(stairs, "F", "") %>% chinese2digits %>% str_c("F") %>%
    {str_replace(x, stairs, .)}
    return(x)
  }) %>% `names<-`(NULL)

  shop_data$分公司地址[i] <- sapply(shop_data$分公司地址[i], function(x){
    pattern_starts <- "[零一二三四五六七八九十百千萬億]+號"
    if (!str_detect(x, pattern_starts))
    return(x)
    no <- str_extract(x, pattern_starts)
    x <- str_replace(x, str_c("(\\d+)(", pattern_starts, ")"), "\\1, \\2")
    x <- str_replace(no, "號", "") %>% chinese2digits %>% str_c("號") %>%
    {str_replace(x, no, .)}
    return(x)
  }) %>% `names<-`(NULL)
}

# 異體字
shop_data <- shop_data %>% mutate(分公司地址 = {
  分公司地址 %>%
  str_replace_all("台", "臺") %>%
  str_replace_all("巿", "市")
})

# 縣轄市應算在縣底下
shop_data <- shop_data %>% mutate(分公司地址 = {
  分公司地址 %>%
  str_replace_all("^竹北市", "新竹縣竹北市") %>%
  str_replace_all("^彰化市", "彰化縣彰化市") %>%
  str_replace_all("^員林市", "彰化縣員林市") %>%
  str_replace_all("^苗栗市", "苗栗縣苗栗市") %>%
  str_replace_all("^頭份市", "苗栗縣頭份市") %>%
  str_replace_all("^南投市", "南投縣南投市") %>%
  str_replace_all("^斗六市", "雲林縣斗六市") %>%
  str_replace_all("^太保市", "嘉義縣太保市") %>%
  str_replace_all("^朴子市", "嘉義縣朴子市") %>%
  str_replace_all("^屏東市", "屏東縣屏東市") %>%
  str_replace_all("^宜蘭市", "宜蘭縣宜蘭市") %>%
  str_replace_all("^花蓮市", "花蓮縣花蓮市") %>%
  str_replace_all("^臺東市", "臺東縣臺東市") %>%
  str_replace_all("^馬公市", "澎湖縣馬公市")
})
# 處理直轄市改制後的名稱
shop_data <- shop_data %>% mutate(分公司地址 = {
  分公司地址 %>%
  str_replace_all("臺北縣", "新北市") %>%
  str_replace_all("桃園縣", "桃園市") %>%
  str_replace_all("臺中縣", "臺中市") %>%
  str_replace_all("臺南縣", "臺南市") %>%
  str_replace_all("高雄縣", "高雄市")
})

shop_data <- shop_data %>% mutate(city = substring(分公司地址, 0, 3))
shop_data <- shop_data %>% mutate_geocode(分公司地址)

# 計算超商數量
shop_count <- shop_data %>%
    group_by(公司名稱) %>%
    dplyr::summarise(n = n_distinct(分公司統一編號))
ggplot(data=shop_count, mapping=aes(x="公司名稱", y = n ,fill=公司名稱)) +
    geom_bar(stat="identity",width = 1, size = 1,position='stack') +
    coord_polar("y", start=0) +
    theme_void() +
    labs(fill='超商') +
    geom_text(aes( label = scales::percent(n / sum(n))), position = position_stack(vjust = 0.5)) +
    theme(text=element_text(family="黑體-繁 中黑", size=12))

town_list <- fromJSON("~/Desktop/R_Project/town_list.json")
population <- fromJSON("~/Desktop/R_Project/population.json")
area <- fromJSON("~/Desktop/R_Project/area.json")

# 每個縣市的總店數
shop_per_city <- shop_data %>% group_by(city, 公司名稱) %>% dplyr::summarise(n = n_distinct(分公司統一編號))
ggplot(data = shop_per_city, mapping = aes(x = city, y = n, fill = shop_per_city$公司名稱)) +
    geom_bar(stat = "identity") +
    labs(x = '縣市', y = '數量', fill='超商') +
    theme(text=element_text(family="黑體-繁 中黑", size=12), axis.text.x=element_text(angle=45))

# 平均每家店服務的人口數
. <- shop_per_city %>%
    group_by(city) %>%
    summarise(num = sum(n))
people_per_shop <- left_join(., population, by = c("city" = "city"))
ggplot(data = people_per_shop, mapping = aes(x = city, y = (population / num) / 1e2, fill = people_per_shop$city)) +
    geom_bar(stat = "identity") +
    labs(x = '縣市', y = '服務人口（百人）', fill='縣市') +
    geom_text(aes(label = floor((population / num) / 10) / 10), size = 3,  position = position_stack(vjust = 0.5)) +
    theme(text=element_text(family="黑體-繁 中黑", size=12), axis.text.x=element_text(angle=45), legend.position="none")

# 平均每家店服務的範圍
area_per_shop <- left_join(., area, by = c("city" = "city"))
ggplot(data = area_per_shop, mapping = aes(x = city, y = (area / num), fill = area_per_shop$city)) +
    geom_bar(stat = "identity") +
    labs(x = '縣市', y = '服務範圍（平方公里）', fill='縣市') +
    geom_text(aes(label = floor((area / num) * 100) / 100), size = 3,  position = position_stack(vjust = 0.5)) +
    theme(text=element_text(family="黑體-繁 中黑", size=12), axis.text.x=element_text(angle=45), legend.position="none")

# 繪製地圖
qmplot(lon, lat, data = shop_data, maptype = "toner-lite", color = I("red"), zoom = 9)

# 臺北: 25.108215, 121.451381   24.989190, 121.570576
travel_time_taipei <- c()
for(i in 1:200){
    lon <- runif(1, min=121.451381, max=121.570576)
    lat <- runif(1, min=24.989190, max=25.108215)
    dis <- (shop_data$lon - lon) ^ 2 + (shop_data$lat - lat) ^ 2
    . <- mapdist(as.numeric(c(lon, lat)), c(shop_data$分公司地址[which.min(dis)]), mode="walking")
    if(is.numeric(.$seconds)) travel_time_taipei <- c(travel_time_taipei, .$seconds)
}

# 雲林嘉義 23.824379, 120.251754   23.405572, 120.486646
travel_time_yunlin_chiayi <- c()
for(i in 1:200){
    lon <- runif(1, min=121.451381, max=121.570576)
    lat <- runif(1, min=24.989190, max=25.108215)
    dis <- (shop_data$lon - lon) ^ 2 + (shop_data$lat - lat) ^ 2
    . <- mapdist(as.numeric(c(lon, lat)), c(shop_data$分公司地址[which.min(dis)]), mode="walking")
    if(is.numeric(.$seconds)) travel_time_yunlin_chiayi <- c(travel_time_yunlin_chiayi, .$seconds)
}

# 宜蘭 24.614054, 121.805200  24.786233, 121.654558
travel_time_yilan <- c()
for(i in 1:200){
    lon <- runif(1, min=121.451381, max=121.570576)
    lat <- runif(1, min=24.989190, max=25.108215)
    dis <- (shop_data$lon - lon) ^ 2 + (shop_data$lat - lat) ^ 2
    . <- mapdist(as.numeric(c(lon, lat)), c(shop_data$分公司地址[which.min(dis)]), mode="walking")
    if(is.numeric(.$seconds)) travel_time_yilan <- c(travel_time_yilan, .$seconds)
}


a <- \(x) x + 1


setwd("~/GitHub/bias-study/data") #machine-dependent... sorry. probably a better way of doing this
library(ggplot2)
library(mefa)
library(lsmeans)
library(multcomp)

bias_data <- read.csv("cleaned_data.csv")
#Filter out the people who admitted to cheating
bias_data <- bias_data[bias_data$id %in% c("87912012", "30619584", "51665387", "25917069", "50263296", "60755967", "2893057", "28653725", "76648162", "21045111", "72925790", "88825154", "97626871", "29657674", "26308857", "79273300", "77642132", "83205605", "9782123", "28428523", "95378753", "62759895", "45694489", "57315921", "20505415", "73348785", "77955785", "45840218", "79707421", "7321301", "43548417", "89431160", "29089701", "61154389", "71996586", "21418137", "76395409", "79544988", "76024785"),]
bias_data <- bias_data[bias_data$demographics_cheat == "no",]
#Select the columns for statistics
id <- rep(as.vector(t(bias_data["id"])), each=2)#airline, states
condition <- rep(as.vector(t(bias_data["studyCondition"])), each=2)#airline, states
condition <- factor(condition,c("onlyNew", "difference", "both"))
visType <- rep(c("airline", "states"), nrow(bias_data))
focus <- as.vector(t(bias_data[c("focusAirline", "focusState")]))
sequence <- as.vector(t(bias_data[c("seqAirline", "seqStates")]))
control <- factor(as.factor(ifelse(sequence == 1, 1, 0)), c("1", "0"))
order <- ifelse(rep(as.vector(t(bias_data["firstCondition"])), each=2) == visType, 1, 2)#airline, states
cleaned_data_frame <- data.frame(id, condition, visType, focus, sequence, order, control)

#-----How many questions when viewing the precise data-----
how_many_precise <- cleaned_data_frame
#Calcualte approximate error
approx_howMany_answer <- as.vector(t(bias_data[c("approx_airline_howMany_answer", "approx_states_howMany_answer")]))
approx_howMany_approx <- as.vector(t(bias_data[c("approx_airline_howMany_approx", "approx_states_howMany_approx")]))
precise_howMany_precise <- as.vector(t(bias_data[c("precise_airline_howMany_precise", "precise_states_howMany_precise")]))
precise_howMany_answer <- as.vector(t(bias_data[c("precise_airline_howMany_answer", "precise_states_howMany_answer")]))

how_many_precise$approximate_error <- (approx_howMany_answer - approx_howMany_approx)/ approx_howMany_approx
how_many_precise$expected_bias <- (precise_howMany_precise - approx_howMany_approx)/ precise_howMany_precise
how_many_precise$measured_bias <- (precise_howMany_precise - precise_howMany_answer)/ precise_howMany_precise

#One would hope we can remove: visType, focus, sequence, order
#how_many_precise <- how_many_precise[c(T, T, T, T, T, T, T, T, T, T, T, T, T, T, T, T, F, T, T, T),] #remove outlier answer
how_many_precise_test <- lm(measured_bias ~ expected_bias + approximate_error + visType + condition + focus + sequence + order + (1 | id), data=how_many_precise)
how_many_precise_test <- lm(measured_bias ~ control + expected_bias*condition + (1 | id), data=how_many_precise)

how_many_precise_plot <- ggplot(how_many_precise, aes(expected_bias, measured_bias, color=condition, fill=condition)) + theme(text = element_text(size=16)) + geom_point() + geom_smooth(se=T, method="lm")
ggsave("plots/how_many_precise.pdf", how_many_precise_plot)

how_many_precise_boxplot <- ggplot(how_many_precise, aes(condition, measured_bias)) + geom_boxplot()
ggsave("plots/how_many_precise_box.pdf", how_many_precise_boxplot)

#-----Comparison questions when viewing the precise data-----
compare_precise <- rep(cleaned_data_frame, 3)
#Calculate approximate error (Only looking at the first approximate answer, since I think this was the intended behavior)

approx_compare_answer <- as.vector(t(bias_data[c("approx_airline_howManyCompare_0_answer", "approx_states_howManyCompare_0_answer")]))
approx_compare_approx <- as.vector(t(bias_data[c("approx_airline_howManyCompare_0_approx", "approx_states_howManyCompare_0_approx")]))
precise_compare_approx <- as.vector(t(bias_data[c("precise_airline_howManyCompare_0_approx", "precise_states_howManyCompare_0_approx", "precise_airline_howManyCompare_1_approx", "precise_states_howManyCompare_1_approx", "precise_airline_howManyCompare_2_approx", "precise_states_howManyCompare_2_approx")]))
precise_compare_precise <- as.vector(t(bias_data[c("precise_airline_howManyCompare_0_precise", "precise_states_howManyCompare_0_precise", "precise_airline_howManyCompare_1_precise", "precise_states_howManyCompare_1_precise", "precise_airline_howManyCompare_2_precise", "precise_states_howManyCompare_2_precise")]))
precise_compare_answer <- as.vector(t(bias_data[c("precise_airline_howManyCompare_0_answer", "precise_states_howManyCompare_0_answer", "precise_airline_howManyCompare_1_answer", "precise_states_howManyCompare_1_answer", "precise_airline_howManyCompare_2_answer", "precise_states_howManyCompare_2_answer")]))
precise_compare_comparison <- as.vector(t(bias_data[c("precise_airline_howManyCompare_0_data", "precise_states_howManyCompare_0_data", "precise_airline_howManyCompare_1_data", "precise_states_howManyCompare_1_data", "precise_airline_howManyCompare_2_data", "precise_states_howManyCompare_2_data")]))
approx_compare_comparison <- as.vector(t(bias_data[c("approx_airline_howManyCompare_0_data", "approx_states_howManyCompare_0_data")]))

compare_precise$approximate_error <- rep((approx_compare_answer - approx_compare_approx)/approx_compare_approx, 3)
compare_precise$expected_bias <- (precise_compare_precise - precise_compare_approx)/precise_compare_precise
compare_precise$measured_bias <- (precise_compare_precise - precise_compare_answer)/precise_compare_precise
compare_precise$approximate_comparison <- rep(approx_compare_comparison, 3)
compare_precise$precise_comparison <- rep(precise_compare_comparison)

#One would hope we can remove: visType, focus, sequence, order, approximate_comparison, precise_comparison
compare_precise_test <- lm(measured_bias ~ expected_bias + approximate_error + approximate_comparison + precise_comparison + visType + condition + focus + sequence + order + (1 | id), data=compare_precise)
compare_precise_test <- lm(measured_bias ~ control + expected_bias*condition + (1 | id), data=compare_precise)

compare_precise_plot <- ggplot(compare_precise, aes(expected_bias, measured_bias, color=condition, fill=condition)) + theme(text = element_text(size=16)) + geom_point() + geom_smooth(se=T, method="lm")
ggsave("plots/compare_precise.pdf", compare_precise_plot)

compare_precise_boxplot <- ggplot(compare_precise, aes(condition, measured_bias)) + geom_boxplot()
ggsave("plots/compare_precise_box.pdf", compare_precise_boxplot)

#-----Question of "how many of X were there?-----
jaccard_precise <- cleaned_data_frame

jaccard_precise$expected_bias <- as.vector(t(bias_data[c("precise_states_SelectAll_jaccard_answer_precise", "precise_airline_SelectAll_jaccard_answer_precise")]))
jaccard_precise$approximate_error <- as.vector(t(bias_data[c("precise_states_SelectAll_jaccard_approx_precise", "precise_airline_SelectAll_jaccard_approx_precise")]))
jaccard_precise$measured_bias <- as.vector(t(bias_data[c("precise_states_SelectAll_jaccard_approx_answer", "precise_airline_SelectAll_jaccard_approx_answer")]))

jaccard_precise_test <- lm(measured_bias ~ control + expected_bias*condition + (1 | id), data=jaccard_precise)

jaccard_precise_plot <- ggplot(jaccard_precise, aes(expected_bias, measured_bias, color=condition, fill=condition)) + theme(text = element_text(size=16)) + geom_jitter() + geom_smooth(se=T, method="lm")
ggsave("plots/jaccard_precise_jitter.pdf", jaccard_precise_plot)

jaccard_precise_boxplot <- ggplot(jaccard_precise, aes(condition, measured_bias)) + geom_boxplot()
ggsave("plots/jaccard_precise_box.pdf", jaccard_precise_boxplot)


#plot tedersoo fits
rm(list=ls())
library(data.table)
source('NEFI_functions/crib_fun.r')
d <- readRDS('/fs/data3/caverill/NEFI_microbial/model_fits/ted_frequentist.rds')

png(filename='figures/tedersoo_fits.png',width=10,height=10,units='in',res=300)

par(mfrow = c(5,5),
    mai = c(0,0,0,0),
    oma = c(5,5,1,1))

for(i in 1:length(d)){
  z <- d[[i]]
  plot(z$data[,1] ~ z$data$fitted, ylab = NA,xlab=NA, cex = 0.5, pch = 16)
  abline(lm(z$data[,1] ~ z$data$fitted), lwd =2)
  mtext(paste('r2=',round(z$r.sq,2)), side = 3, line = -5, adj = 0.05, cex = 0.8, col = 'purple')
  mtext(paste(names(d)[i])          , side = 3, line = -3, adj = 0.05, cex = 0.8, col = 'purple')
}

mtext('observed', side = 2, line = 3, outer = T)
mtext('fitted'  , side = 1, line = 3, outer = T)

dev.off()


############
############ Diverse invaders manuscript script,by Hu Jie
#### Reading data
ngs.r<-read.table("otu.raw.txt", header=T, row.names=1, sep="\t")  ## otu rawdata
env<-read.table("env.txt", sep="\t", header=T, row.names=1)        ## soil properties

ngs.i<-ngs.r[,1:dim(env)[1]]                                   ## only abundance
ngs.i<-ngs.i[,order(colnames(ngs.i))]                          ## order the data
taxo.i<-ngs.r[,-c(1:dim(env)[1])]                              ## only taxonomy

#### calculate value for method description
colSums(ngs.i)
mean(colSums(ngs.i))
min(colSums(ngs.i))
max(colSums(ngs.i))

#### calculate relative abundance of each otu
ngs.relat<-0*ngs.i                                                       ## creat a empty matrix
for(i in 1:dim(ngs.relat)[2]) ngs.relat[,i]<-ngs.i[,i]/colSums(ngs.i)[i] ## loop to calculate relative abundance
colSums(ngs.relat)                                                       ## check if calculate correctly

#### Standardization of abundance
ngs.b<-round(ngs.relat*min(colSums(ngs.i)),0) ## recover otu number based relative otu abundance
ngs.rt<-data.frame(ngs.b,taxo.i)              ## combine otu and taxonomy
ngs.b.filter<-ngs.rt[,1:dim(env)[1]]          ## subset based on dimensionality of env.txt

ngs.b$zero.num<-rowSums(ngs.b==0)             ## calculate the zero amount of each row
ngs.b$sum<-rowSums(ngs.b)                     ## calculate sum of each row, it makes some mistakes!!!!

colb<-data.frame(colSums(ngs.b!=0))           ## OTU richness of each sample

ngs.01<-as.data.frame(1*(ngs.b.filter>0))     ## transfer to 0/1 matrix


#####################################################################################
#
# Mark Cembrowski, Janelia Research Campus, April 15 2015
#
# This script return sgenes that are enriched in one (or more) populations, relative
# to another set of one or more populations.  sampleX will be the enriched population,
# sampleY will be the depleted population.
#
#####################################################################################

getEnrGenes <- function(sampleX,sampleY,fdr=-1,foldThres=-1,fpkmThres=-1,avgPass=T){
	# Populate a matrix with the genes that fit supplied arguments.
	# Begin with fold change.
	if(foldThres>1){
		if(avgPass){
			enrXFold <- .apply(fpkmPoolMat[,sampleX],1,min)>
				(foldThres* (.apply(fpkmPoolMat[,sampleY],1,max)) )
		}else{
			minX <- .apply(fpkmRepMat[,grepl(paste(sampleX,collapse='|'),colnames(fpkmRepMat))],1,min)
			maxY <- .apply(fpkmRepMat[,grepl(paste(sampleY,collapse='|'),colnames(fpkmRepMat))],1,max)
			enrXFold <- minX>(foldThres*maxY)
	}
		enrXFold <- rownames(fpkmPoolMat)[enrXFold]
	}else{
		# Take an effective fold threshold of 1, preventing underexpressed
		# genes in sampleX from showing up if not screening for fold changes
		# (e.g., when using FDR to screen).  Otherwise, the FDR results
		# give bidirectional (ie, significantly up AND down regulated) genes
		# which is undesirable.
		enrXFold <- .apply(fpkmPoolMat[,sampleX],1,min)>
				( .apply(fpkmPoolMat[,sampleY],1,max) )
		enrXFold <- rownames(fpkmPoolMat)[enrXFold]
	}

	# Next, annotate all genes that cross threshold.
	if(fpkmThres>0){
		if(avgPass){
			enrXFpkm <- .apply(fpkmPoolMat[,sampleX],1,max)>fpkmThres
		}else{
			enrXFpkm <- fpkmRepMat[,grepl(paste(sampleX,collapse='|'),colnames(fpkmRepMat))]
			enrXFpkm <- .apply(enrXFpkm,1,min)>fpkmThres

		}
		enrXFpkm <- rownames(fpkmPoolMat)[enrXFpkm]
	}else{
		enrXFpkm <- rownames(fpkmPoolMat)
	}

	# Next, annotate all genes that are differentially expressed.
	enrXThres <- intersect(enrXFold,enrXFpkm)
	firstTest <- T
	if(fdr>0){
		for (ii in sampleX){
			for (jj in sampleY){
				# Recover pairwise DE tests.  May have a column name of sample1-sample2
				# OR sample2-sample1 ; cover both cases.
				theTest <- paste(ii,'.',jj,sep='')
				theCol <- which(colnames(qVal)%in%theTest)

				if(length(theCol)<0.1){
					theTest <- paste(jj,'.',ii,sep='')
					theCol <- which(colnames(qVal)%in%theTest)
				}
				enrXDeTemp <- qVal$gene_id[qVal[,theCol]<fdr]
				if(firstTest){
					enrXDe <- enrXDeTemp
					firstTest <- F
				}else{
					enrXDe <- intersect(enrXDe,enrXDeTemp)
				}
			}
		}
		enrX <- intersect(enrXThres,enrXDe)

	}else{
		enrX <- enrXThres
	}

	# Arrange things in a nice order, by fold change, for output.
	subEnr <- fpkmPoolMat[enrX,sampleX]
	subDep <- fpkmPoolMat[enrX,sampleY]
	foldEnrich <- .apply(subEnr,1,mean)/.apply(subDep,1,mean)

	enrX <- enrX[order(-foldEnrich)]

	invisible(enrX)
}

# This is a helper function that acts like apply when the argument X is a matrix/data
# frame, and just returns the supplied X when it is a vector.  This is to circumvent
# issues when X can be either a vector or matrix/data frame when selecting an arbitrary
# number of columns from a data frame.
.apply <- function(X,MARGIN,FUN){
	if(length(dim(X))<0.1){
		return(X)
	}else{
		return(apply(X,MARGIN,FUN))
	}
}


# shuffle ANGSD FST A and B values across sites and calculate windowed FST to get a null distribution of max genome-wide FST
# run last part of angsd_fst.sh first to get the *.fst.AB.gz files
# if using GATK nodam2 loci, groups into linkage blocks based on ngsLD output. Need to run ngsLD_find_blocks.sh/.r first

# to run on saga

# read command line arguments
args <- commandArgs(trailingOnly = TRUE)
print(args)

if (length(args) != 1) stop("Have to specify whether all loci (0) or GATK loci (1)", call.=FALSE)

gatkflag <- as.numeric(args[1])

if(gatkflag == 1){
	print('Using only GATK nodam2 loci. Will trim to unlinked blocks.')
} else if(gatkflag == 0){
	print('Using all loci. Note that this option does not trim to unlinked groups yet.')
} else {
	stop(paste(gatkflag, ' is not 0 or 1. Please only specify 0 (all loci) or 1 (gatk loci).'))
}

# parameters
winsz <- 50000 # window size
winstp <- 10000 # window step
nrep <- 1000 # number of reshuffles
minloci <- 2 # minimum number of loci per window to consider

outfilecan <- 'analysis/Can_40.Can_14.fst.siteshuffle.csv.gz' # used if all loci are used
outfilelof0711 <- 'analysis/Lof_07.Lof_11.fst.siteshuffle.csv.gz'
outfilelof0714 <- 'analysis/Lof_07.Lof_14.fst.siteshuffle.csv.gz'
outfilelof1114 <- 'analysis/Lof_11.Lof_14.fst.siteshuffle.csv.gz'

# load functions
require(data.table)

#############
# Prep data
#############
# load fst A/B data
can <- fread('analysis/Can_40.Can_14.fst.AB.gz')
setnames(can, c('CHROM', 'POS', 'A', 'B'))

lof0711 <- fread('analysis/Lof_07.Lof_11.fst.AB.gz')
setnames(lof0711, c('CHROM', 'POS', 'A', 'B'))

lof0714 <- fread('analysis/Lof_07.Lof_14.fst.AB.gz')
setnames(lof0714, c('CHROM', 'POS', 'A', 'B'))

lof1114 <- fread('analysis/Lof_11.Lof_14.fst.AB.gz')
setnames(lof1114, c('CHROM', 'POS', 'A', 'B'))

# trim to gatk loci if requested
if(gatkflag == 1){
	# list of loci to use
	gatk <- fread('data_2020.05.07/GATK_filtered_SNP_no_dam2.tab')
	setnames(gatk, c('CHROM', 'POS', 'REF', 'ALT'))

	# trim
	can <- can[gatk, on = c('CHROM', 'POS')]
	lof0711 <- lof0711[gatk, on = c('CHROM', 'POS')]
	lof0714 <- lof0714[gatk, on = c('CHROM', 'POS')]
	lof1114 <- lof1114[gatk, on = c('CHROM', 'POS')]

	# set new outfile names
	outfilecan <- 'analysis/Can_40.Can_14.gatk.nodam.fst.siteshuffle.csv.gz'
	outfilelof0711 <- 'analysis/Lof_07.Lof_11.gatk.nodam.fst.siteshuffle.csv.gz'
	outfilelof0714 <- 'analysis/Lof_07.Lof_14.gatk.nodam.fst.siteshuffle.csv.gz'
	outfilelof1114 <- 'analysis/Lof_11.Lof_14.gatk.nodam.fst.siteshuffle.csv.gz'
}

# remove unplaced
can <- can[!(CHROM %in% 'Unplaced'), ]
lof0711 <- lof0711[!(CHROM %in% 'Unplaced'), ]
lof0714 <- lof0714[!(CHROM %in% 'Unplaced'), ]
lof1114 <- lof1114[!(CHROM %in% 'Unplaced'), ]

# trim to unlinked loci if GATK loci were requested
if(gatkflag == 1){
	ld <- fread('analysis/ld.blocks.gatk.nodam.csv.gz') # linkage blocks from ngsLD_find_blocks.r

	can <- merge(can, ld[, .(CHROM, POS, cluster = cluster_can)], all.x = TRUE)
	lof0711 <- merge(lof0711, ld[, .(CHROM, POS, cluster = cluster_lof)], all.x = TRUE)
	lof0714 <- merge(lof0714, ld[, .(CHROM, POS, cluster = cluster_lof)], all.x = TRUE)
	lof1114 <- merge(lof1114, ld[, .(CHROM, POS, cluster = cluster_lof)], all.x = TRUE)

	# average Fst in linkage blocks and find a locus near the middle of each block to keep
	findmid <- function(POS){ # function to return a value near the middle of a vector of positions
		mn <- mean(range(POS))
		return(POS[which.min(abs(POS - mn))])
	}

	can[, keep := 1] # column for marking which loci to keep
	can[!is.na(cluster), keep := 0] # in general, drop loci that are in a cluster
	canclust <- can[!is.na(cluster), .(CHROM = unique(CHROM), midPOS = findmid(POS), nloci = length(POS), sumA = sum(A), sumB = sum(B)), by = cluster] # find the cluster midpoints and sum of the FST components
	can <- merge(can, canclust[, .(CHROM, POS = midPOS, sumA, sumB, nloci, clustermid = 1)], all.x = TRUE) # label the cluster midpoints
	can[clustermid == 1, ':='(keep = 1, A = sumA, B = sumB)] # move A and B from cluster mids over to the right column for FST calculations and mark them to keep
	can <- can[keep == 1, ] # drop all loci in clusters that aren't midpoints
	can[, ':='(keep = NULL, sumA = NULL, sumB = NULL, clustermid = NULL)] # drop extra columns

	lof0711[, keep := 1] # column for marking which loci to keep
	lof0711[!is.na(cluster), keep := 0] # in general, drop loci that are in a cluster
	lof0711clust <- lof0711[!is.na(cluster), .(CHROM = unique(CHROM), midPOS = findmid(POS), nloci = length(POS), sumA = sum(A), sumB = sum(B)), by = cluster] # find the cluster midpoints and sum of the FST components
	lof0711 <- merge(lof0711, lof0711clust[, .(CHROM, POS = midPOS, sumA, sumB, nloci, clustermid = 1)], all.x = TRUE) # label the cluster midpoints
	lof0711[clustermid == 1, ':='(keep = 1, A = sumA, B = sumB)] # move A and B from cluster mids over to the right column for FST calculations and mark them to keep
	lof0711 <- lof0711[keep == 1, ] # drop all loci in clusters that aren't midpoints
	lof0711[, ':='(keep = NULL, sumA = NULL, sumB = NULL, clustermid = NULL)] # drop extra columns

	lof0714[, keep := 1] # column for marking which loci to keep
	lof0714[!is.na(cluster), keep := 0] # in general, drop loci that are in a cluster
	lof0714clust <- lof0714[!is.na(cluster), .(CHROM = unique(CHROM), midPOS = findmid(POS), nloci = length(POS), sumA = sum(A), sumB = sum(B)), by = cluster] # find the cluster midpoints and sum of the FST components
	lof0714 <- merge(lof0714, lof0714clust[, .(CHROM, POS = midPOS, sumA, sumB, nloci, clustermid = 1)], all.x = TRUE) # label the cluster midpoints
	lof0714[clustermid == 1, ':='(keep = 1, A = sumA, B = sumB)] # move A and B from cluster mids over to the right column for FST calculations and mark them to keep
	lof0714 <- lof0714[keep == 1, ] # drop all loci in clusters that aren't midpoints
	lof0714[, ':='(keep = NULL, sumA = NULL, sumB = NULL, clustermid = NULL)] # drop extra columns

	lof1114[, keep := 1] # column for marking which loci to keep
	lof1114[!is.na(cluster), keep := 0] # in general, drop loci that are in a cluster
	lof1114clust <- lof1114[!is.na(cluster), .(CHROM = unique(CHROM), midPOS = findmid(POS), nloci = length(POS), sumA = sum(A), sumB = sum(B)), by = cluster] # find the cluster midpoints and sum of the FST components
	lof1114 <- merge(lof1114, lof1114clust[, .(CHROM, POS = midPOS, sumA, sumB, nloci, clustermid = 1)], all.x = TRUE) # label the cluster midpoints
	lof1114[clustermid == 1, ':='(keep = 1, A = sumA, B = sumB)] # move A and B from cluster mids over to the right column for FST calculations and mark them to keep
	lof1114 <- lof1114[keep == 1, ] # drop all loci in clusters that aren't midpoints
	lof1114[, ':='(keep = NULL, sumA = NULL, sumB = NULL, clustermid = NULL)] # drop extra columns

	# write out fst trimmed to unlinked blocks
	write.csv(can, gzfile('analysis/Can_40.Can_14.gatk.nodam.ldtrim.fst.AB.csv.gz'))
	write.csv(lof0711, gzfile('analysis/Lof_07.Lof_11.gatk.nodam.ldtrim.fst.AB.csv.gz'))
	write.csv(lof0714, gzfile('analysis/Lof_07.Lof_14.gatk.nodam.ldtrim.fst.AB.csv.gz'))
	write.csv(lof1114, gzfile('analysis/Lof_11.Lof_14.gatk.nodam.ldtrim.fst.AB.csv.gz'))

}

# create new columns as indices for windows
for(j in 1:(winsz/winstp)){
	can[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
	lof0711[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
	lof0714[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
	lof1114[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
}

# mark windows with < minloci for removal
rem <- rep(0,4) # number of windows removed for each of the 4 comparisons
for(j in 1:(winsz/winstp)){
	canwin <- can[, .(nsnps = length(POS)), by = .(win = get(paste0('win', j)))] # calc num snps per window
	rem[1] <- rem[1] + canwin[, sum(nsnps < minloci)] # record number to be removed
	canwin[, (paste0('win', j, 'keep')) := 1] # create col to mark which windows to keep
	canwin[nsnps < minloci, (paste0('win', j, 'keep')) := 0] # mark windows to remove
	canwin[, nsnps := NULL] # drop column
	setnames(canwin, "win", paste0('win', j)) # change col name
	can <- merge(can, canwin, by = paste0('win', j), all.x = TRUE) # merge keeper col back to full dataset

	lof0711win <- lof0711[, .(nsnps = length(POS)), by = .(win = get(paste0('win', j)))]
	rem[2] <- rem[2] + lof0711win[, sum(nsnps < minloci)]
	lof0711win[, (paste0('win', j, 'keep')) := 1]
	lof0711win[nsnps < minloci, (paste0('win', j, 'keep')) := 0]
	lof0711win[, nsnps := NULL]
	setnames(lof0711win, "win", paste0('win', j))
	lof0711 <- merge(lof0711, lof0711win, by = paste0('win', j), all.x = TRUE)

	lof0714win <- lof0714[, .(nsnps = length(POS)), by = .(win = get(paste0('win', j)))]
	rem[3] <- rem[3] + lof0714win[, sum(nsnps < minloci)]
	lof0714win[, (paste0('win', j, 'keep')) := 1]
	lof0714win[nsnps < minloci, (paste0('win', j, 'keep')) := 0]
	lof0714win[, nsnps := NULL]
	setnames(lof0714win, "win", paste0('win', j))
	lof0714 <- merge(lof0714, lof0714win, by = paste0('win', j), all.x = TRUE)

	lof1114win <- lof1114[, .(nsnps = length(POS)), by = .(win = get(paste0('win', j)))]
	rem[4] <- rem[4] + lof1114win[, sum(nsnps < minloci)]
	lof1114win[, (paste0('win', j, 'keep')) := 1]
	lof1114win[nsnps < minloci, (paste0('win', j, 'keep')) := 0]
	lof1114win[, nsnps := NULL]
	setnames(lof1114win, "win", paste0('win', j))
	lof1114 <- merge(lof1114, lof1114win, by = paste0('win', j), all.x = TRUE)
}

rem # number of windows removed for each comparison

####################################
# shuffle and recalc windowed FST
####################################
colnms <- c('CHROM', 'POS', paste0('win', 1:(winsz/winstp)), paste0('win', 1:(winsz/winstp), 'keep')) # list of column names we want out of the base data.table

# CAN
print('Starting Can')
for(i in 1:nrep){
	cat(i); cat(' ')
	# create new dataset
	inds <- sample(1:nrow(can), nrow(can), replace = FALSE)
	temp <- cbind(can[, ..colnms], can[inds, .(A, B)]) # shuffle FSTs across positions

	# calc fst for each window to keep
	for(j in 1:(winsz/winstp)){
		temp2 <- temp[get(paste0('win', j, 'keep')) == 1, ] # trim to windows to keep. can't combine with next line for some reason.
		if(j ==1) tempfsts <- temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))]
		if(j > 1) tempfsts <- rbind(tempfsts, temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))])
	}

	# save the max windowed fst
	# exclude windows with negative midpoints
	if(i == 1) maxfst <- tempfsts[POS > 0, max(fst, na.rm = TRUE)]
	if(i > 1) maxfst <- c(maxfst, tempfsts[POS > 0, max(fst, na.rm = TRUE)])
}

print(paste('Max:', max(maxfst, na.rm = TRUE), '; 95th:', quantile(maxfst, prob = 0.95, na.rm = TRUE)))

write.csv(maxfst, gzfile(outfilecan), row.names = FALSE)

rm(maxfst)

# Lof0711
print('Starting Lof0711')
for(i in 1:nrep){
	cat(i); cat(' ')
	# create new dataset
	inds <- sample(1:nrow(lof0711), nrow(lof0711), replace = FALSE)
	temp <- cbind(lof0711[, ..colnms], lof0711[inds, .(A, B)]) # shuffle FSTs across positions

	# calc fst for each window
	for(j in 1:(winsz/winstp)){
		temp2 <- temp[get(paste0('win', j, 'keep')) == 1, ]
		if(j ==1) tempfsts <- temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))]
		if(j > 1) tempfsts <- rbind(tempfsts, temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))])
	}

	# save the max windowed fst
	if(i == 1) maxfst <- tempfsts[POS > 0, max(fst, na.rm = TRUE)]
	if(i > 1) maxfst <- c(maxfst, tempfsts[POS > 0, max(fst, na.rm = TRUE)])
}

print(paste('Max:', max(maxfst, na.rm = TRUE), '; 95th:', quantile(maxfst, prob = 0.95, na.rm = TRUE)))

write.csv(maxfst, gzfile(outfilelof0711), row.names = FALSE)

rm(maxfst)

# Lof0714
print('Starting Lof0714')
for(i in 1:nrep){
 	cat(i); cat(' ')
	# create new dataset
	inds <- sample(1:nrow(lof0714), nrow(lof0714), replace = FALSE)
	temp <- cbind(lof0714[, ..colnms], lof0714[inds, .(A, B)]) # shuffle FSTs across positions

	# calc fst for each window
	for(j in 1:(winsz/winstp)){
		temp2 <- temp[get(paste0('win', j, 'keep')) == 1, ]
		if(j ==1) tempfsts <- temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))]
		if(j > 1) tempfsts <- rbind(tempfsts, temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))])
	}

	# save the max windowed fst
	if(i == 1) maxfst <- tempfsts[POS > 0, max(fst, na.rm = TRUE)]
	if(i > 1) maxfst <- c(maxfst, tempfsts[POS > 0, max(fst, na.rm = TRUE)])
}

print(paste('Max:', max(maxfst, na.rm = TRUE), '; 95th:', quantile(maxfst, prob = 0.95, na.rm = TRUE)))

write.csv(maxfst, gzfile(outfilelof0714), row.names = FALSE)

rm(maxfst)

# Lof1114
print('Starting Lof1114')
for(i in 1:nrep){
 	cat(i); cat(' ')
	# create new dataset
	inds <- sample(1:nrow(lof1114), nrow(lof1114), replace = FALSE)
	temp <- cbind(lof1114[, ..colnms], lof1114[inds, .(A, B)]) # shuffle FSTs across positions

	# calc fst for each window
	for(j in 1:(winsz/winstp)){
		temp2 <- temp[get(paste0('win', j, 'keep')) == 1, ]
		if(j ==1) tempfsts <- temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))]
		if(j > 1) tempfsts <- rbind(tempfsts, temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))])
	}

	# save the max windowed fst
	if(i == 1) maxfst <- tempfsts[POS > 0, max(fst, na.rm = TRUE)]
	if(i > 1) maxfst <- c(maxfst, tempfsts[POS > 0, max(fst, na.rm = TRUE)])
}

print(paste('Max:', max(maxfst, na.rm = TRUE), '; 95th:', quantile(maxfst, prob = 0.95, na.rm = TRUE)))

write.csv(maxfst, gzfile(outfilelof1114), row.names = FALSE)


# R for Data Science - Chapter 1
# Here we will go over the basics of ggplot2 and some of the other exploratory
# analaysis tools that will be employed throughout the book, Lets begin:

library(tidyverse)

# Imports all of the wonderful tidyverse that the book is based on (Thanks Hadley Wickman)

ggplot(data = mpg) + geom_point(mapping = aes(x = displ, y = hwy, color = class))

# We specify that we want to create a baseline graph and layer the geometric points
# overtop of the specified plane, and with the aes() we specify the aesthetic