# Script that will download roll call data for the Minnesota House of Representatives from openstates.org and calculate W-NOMINATE roll call ideology estimates for every lawmaker in the 2015-2016 Legislature.
# Inputs required: none
# Outputs produced: "nomscores.csv", a spreadsheet containing each lawmaker and their ideology estimate. This can be used in the companion scripts, "nominate-elex.r" and "nominate-rank.r, to produce graphs of the results.
# Note that these are ideology estimates only, and running sequential trials will likely produce slightly different results. This is fine. (If trials produce dramatically different results, something is likely wrong.
# This script can be customized for other years and states available on the OpenStates bulk data site (http://openstates.org/downloads/). HOWEVER, this will require care and trial & error. Different states code their data differently, and this script is designed for Minnesota's particular coding. Data may be missing from the legislator file for non-active legislators in other Minnesota years — this script includes manual coding to fill in information for three lawmakers who left the Minnesota House during the two-year session.
# Code by David H. Montgomery for the Pioneer Press, subject to the MIT License.
# Uses WNOMINATE package by Poole, Keith, Jeffrey Lewis, James Lo, and Royce Carroll. 2011, from "Scaling Roll Call Votes with wnominate in R", http://www.jstatsoft.org/v42/i14/paper.

library(RCurl)
library(dplyr)
library(wnominate)

temp <- tempfile() # Open a temporary file to store the ZIP
download.file("http://static.openstates.org/downloads/2016-06-08-mn-csv.zip",temp) # Download the ZIP into the temporary file

# Extract bill_votes.csv from the ZIP, put it in a data frame, and subset it to just the list of votes in the current legislative session.
billvotes <- read.csv(unzip(temp, files = "mn_bill_votes.csv"), stringsAsFactors = FALSE) %>% subset(session == "2015-2016", select = "vote_id")

# Extract the list of votes by legislator, and filter it to just those votes we highlighted in the prior step.
votesin <- read.csv(unzip(temp, files = "mn_bill_legislator_votes.csv"), stringsAsFactors = FALSE) %>% semi_join(billvotes, by = "vote_id")

romney <- read.csv("romney.csv", stringsAsFactors = F) # Load Romney margin by district

# Load the legislator directory
info <- read.csv(unzip(temp, files = "mn_legislators.csv"), stringsAsFactors = FALSE)
# Code "Democratic-Farmer-Labor" to "DFL"
info$party <- gsub("Democratic-Farmer-Labor","DFL",info$party)
# Fill in some missing information for deceased or resigned lawmakers
info[143:145,10] <- "lower"
info[143,11] <- "46A"
info[144,11] <- "3A"
info[145,11] <- "50B"
info[143:145,12] <- "DFL"
info <- subset(info, chamber == "lower") %>% arrange(last_name, first_name) %>% inner_join(romney, by= "district") # Subset to just active members, then sort by last and first name. Important!

unlink(temp) # Unlink the ZIP

dir <- unique(votesin[,2:3]) %>% arrange(name)
v <- unique(votesin$vote_id)
n <- dir[,2]
id <- dir[,1]

# Go through votes and add in missing votes as "NA"
# This will take a while
for (i in 1:length(v)) {
	for (j in 1:length(n)) {
		if(!(n[j] %in% subset(votesin, vote_id == v[i])$name)) {
			votesin <- rbind(votesin,data.frame(
				"vote_id"=v[i],
				"leg_id"=dir[j,1],
				"name"=dir[j,2],
				"vote"=NA)
			)
		}
	}
}

votesin <- arrange(votesin, vote_id, name) # Sort. Important!

# Produce matrix from roll calls.
votesout <- matrix(
	votesin$vote,
	nrow = length(unique(votesin$name)),
	ncol = length(unique(votesin$vote_id)),
	dimnames = list(c(unique(votesin$name)),unique(votesin$vote_id))
)

# Create a 'rollcall' object, combining with a legislator directory..
mnlegvotes <- rollcall(
	votesout, # The matrix to base the rollcall on.
	yea = "yes", # How yeas are coded
	nay = "no", # How nays are coded
	missing = NA, # How missing votes are coded
	legis.names = n, # List of legislative names
	vote.names = v, # List of vote names
	legis.data = info # Legislative directory
)

# 1-dimensional ranking
mnlegnom <- wnominate(mnlegvotes, dims = 1, polarity = "Drazkowski")

# Save as CSV
write.csv(mnlegnom$legislators[,c(11,12,24,17)],"nomscores.csv")


source("cfg.r")
graphics.off()

dat = loadInputData()

plot_experiment_lines <- function(pr_dataset, drought_var) {
    paramFile = paste0(paramFile, '_', pr_dataset, '_', drought_var, '.csv')

    params = read.csv(paramFile, stringsAsFactors=FALSE)
    param <- function(p, line = ensemble_no) params[line, p]

    maxTC = param('max_T') * logistic(0,  param('mort_x0'),  -param('mort_k')) * logistic(0, param('ex_x0'), -param('ex_k'))

    Run <- function(FUN, datVs, params) {

        ins = list(retutnVar = TRUE)
        for (i in 1:length(datVs))  ins[i + 1] = dat[[datVs[i]]]

        ensemble <- function(line) {
            for (j in 1:length(params)) ins[j + i + 1] = param(params[j], line)
            do.call(FUN, ins)
        }
        dat = layer.apply(ensemble_no, ensemble)
        return(dat)
    }

    y = dat[['TreeCover']]
    pr_var = paste0("MAP_", pr_dataset); dr_var =  paste0(drought_var, '_', pr_dataset)
    x = list(dat[[pr_var]],
          Run(LimMAT,c("MAT"),c("min_mat", "max_mat")),
          Run(LimMort, c('BurntArea', dr_var,'MTWM','PopDen'),
                       c('v_drought', 'v_maxTemp', 'v_popDen', 'p_fire', "k_popden", 'p_drought',
                         'min_maxTemp', 'max_maxTemp', 'p_maxTemp')),
          Run(LimExc, c('urban', 'crop', 'pas'),
                      c('v_crop', 'v_pas')))

    x0 = c('MAP_x0', 'MAT_x0', 'mort_x0', 'ex_x0')
    k  = c('MAP_k' , 'MAT_k' , 'mort_k' , 'ex_k' )

    xlim = list(c(0, 3000),
                c(-2, 30),
                c(0, 80),
                c(0, 40))

    unlogX = c(T, T, F, F)

    xscale = list(1, param('max_mat') - param('min_mat'), 100, 100)
    xscale = list(1,1, 100, 100)
    xshift = list(0, param('min_mat'), 0, 0)

    units = c('mm/yr', '~DEG~C', 'Disturbance area (%)', 'Land use (%)')

    plotControl <- function(x, unlogX, xlim, xscale, xshift, x0, k, ksc, sc, title, units, yaxt) {
        #dev.new()
        plot(xlim, c(0, 100), type ='n', yaxt = yaxt, xlab = '', ylab = '')

        y = y * 100/0.8
        y = layer.apply(1:nlayers(x), function(i) y)

        if (unlogX) xp = exp(x) else xp = x
        xp = xp * xscale + xshift

        mask = all(!is.na(xp) & !is.na(y))
        xv = as.vector(xp[mask]); yv = as.vector(y[mask])

        cols = blues9[unlist(mapply(rep, 1:9, 9 + (1:9)^3))]
        cols = densCols(xv,yv, colramp = colorRampPalette(cols))
        points(yv~xv, pch = 20, cex = 2, col = cols)

        xscale = rep(xscale, length.out = length(ensemble_no))
        xshift = rep(xshift, length.out = length(ensemble_no))

        x =  seq(xlim[1], xlim[2], length.out = 101)
        xd = mapply(function(i,j) (x-j)/i, xscale, xshift, SIMPLIFY = FALSE)
        if (title == "MAT") xd = lapply(xd, function(i) {i[i<0] = 0; i})

        if (unlogX) xd = lapply(xd, logmin)

        x0 = params[ensemble_no, x0]; k = params[ensemble_no,k]

        y  =  mapply(logistic, xd, x0, k * ksc) #* 0.8# * t(sc)
        y = sweep(y, 2, sc, '*')

        if (ksc == -1) y = sweep(y, 2, logistic(0, x0, k*ksc), '/')
        y  = apply(y, 1, quantile, c(0.01, 0.5, 0.99))

        #x = x * xscale + xshift
        lines(x, y[1,] * 100, col = 'black', lty = 2, lwd = 1.5)
        lines(x, y[2,] * 100, col = 'black', lty = 1, lwd = 1.5)
        lines(x, y[3,] * 100, col = 'black', lty = 2, lwd = 1.5)

        mtext.units(side = 1, line = 2, units, cex = 0.8)
        mtext.units(side = 3, line = -1.5, title, adj = (-ksc/2.3 + 0.5))
    }

    fname = paste0("figs/limitation_line", '_', pr_dataset, '-', drought_var, '.png')
    png(fname, height = 5, width = 5, unit = 'in', res = 300)
        par(mfrow = c(2, 2), mar = c(3.5, 1, 0, 0), oma = c(0, 2, 1, 1))
        mapply(plotControl, x, unlogX, xlim, xscale, xshift, x0, k,
               c(1, 1, -1, -1), list(1, 1, 1, 1),
               plot_title , units,
               c('s', 'n', 's', 'n'))

        mtext(outer = TRUE, side = 2, line = 1, 'Tree Cover (%)', cex = 0.8)
    dev.off()#.gitWatermark()
}

runAll_pr_droughts(plot_experiment_lines)


library(dplyr)
source("style.r")

args = commandArgs(trailingOnly = TRUE)
data = read.csv(args[1])

data$time = data$time / 60
data = data %>%
	group_by(alpha, app_id) %>%
	mutate(thp = cumsum(tasks_fulfilled)/time)
data = data.frame(data)

data$app_id = factor(
					 data$app_id,
					 levels = c(1, 2, -1),
					 labels = c("Customer 1", "Customer 2", "Total"))
data$alpha = factor(
					data$alpha,
					levels = c(0, -2, -1, 1, 3, 100),
					labels = c("Max Throughput", "Round Robin",
							   "Dedicated Vehicles", "Mobius (Prop. Fair)",
							   "Mobius (alpha=3)", "Mobius (Max-Min)"))

p = ggplot(data, aes(x = time, y = thp, color = app_id, linetype = app_id)) +
	geom_line(size = 1.0) +
	scale_color_manual(values = c('#fc8d62', '#8da0cb', '#000000')) +
	scale_linetype_manual(values = c('solid', 'solid', 'dashed')) +
	facet_wrap(alpha ~ ., nrow = 2) +

	# formatting
	theme(
		  legend.position = "top",
		  legend.text = element_text(size = 10),
		  legend.margin=margin(0,0,0,0), legend.box.margin=margin(-7,-7,-7,-7)
	) +
	xlim(c(0, 60)) +
	xlab("Time (mins)") +
	ylab("Long-term Throughput\n(tasks/min)") +
	guides(linetype = FALSE) +
	labs(color = "")
ggsave(args[2], p, width = 5, height = 2.5, units = 'in')


# Transform the data as the coordinate system does
cdata <- function(plot) {
  pieces <- ggplot_build(plot)

  lapply(pieces$data, function(d) {
    plyr::ddply(d, "PANEL", function(panel_data) {
      scales <- pieces$layout$get_scales(panel_data$PANEL[1])
      panel_params <- plot$coordinates$setup_panel_params(scales$x, scales$y)
      plot$coordinates$transform(panel_data, panel_params)
    })
  })
}

pranges <- function(plot) {
  layout <- ggplot_build(plot)$layout

  x_ranges <- lapply(layout$panel_scales_x, function(scale) scale$get_limits())
  y_ranges <- lapply(layout$panel_scales_y, function(scale) scale$get_limits())

  npscales <- plot$scales$non_position_scales()
  npranges <- lapply(npscales$scales$scales, function(scale) scale$get_limits())

  c(list(x = x_ranges, y = y_ranges), npranges)
}


library(data.table)
library(tictoc)

tic("Read input to memory")

## Read in the species' variant vcf as a tab-separated table
snps <- read.table("<VCF_FILE>", stringsAsFactors=F, sep="\t")

## Read in reference index as a tab-separated table
x <- read.table("<REFINDEX>", sep="\t")
## Make list of scaffolds that are greater than/equal to 1Mb
x.list <- as.character(x[x[,2] >= 1000000,1]) #scaffold list of those > 1 Mbp

## Read in TEs in bed format (Chrom, Start, Stop) as tab-separated table
TEs <- read.table("<BED_FILE>", sep="\t", stringsAsFactors=F)
## Force all data into single data object type
TEs <- cbind(TEs)

## Log statement
log1 <- "Input data read in."
print(log1, quote=FALSE)
toc()

#### Observed values below

tic("Observed SNPs loop")

### Loop for each scaffold to get distance to TE for every SNP
## Initialize output list
output <- list()
## For each scaffold (a) in range of scaffold list
for(a in 1:length(x.list)) {
	## Subset TE file by current scaffold
	a_TEs <- TEs[TEs[,1] %in% x.list[a], ]
	## Set up output TE list
	TE_list <- list()
	## Run the following if there are TEs on this scaffold
	if(nrow(a_TEs) > 0) {
		## Obtain all the bp locations of TEs and remove overlaps
		## For each TE in scaffold TE list
		for(b in 1:nrow(a_TEs)) {
			## Make list of lists by TE index # > each base of the TE
			TE_list[[b]] <- seq(a_TEs[b,2], a_TEs[b,3])
		}
		## Set up data table (a_TEs) of this scaffold's TEs (unique only=remove overlaps)
		a_TEs <- data.table(TEs=unique(unlist(TE_list)))
		## a_TEs with new column 'merge', that contains the info from TEs data table? not scaffold ID, but either TE start or stop (which?)
		a_TEs[,merge:=TEs]
		## Sort the rows of a data.table (a_TEs) by the column (c) 'merge' (now the key)
		setkeyv(a_TEs, c('merge'))
		## Set up this scaffold's SNPs
		## Create data table of SNP positions for each SNP on the scaffold
		a_SNPs <- data.table(SNPs=snps[snps[,1] %in% x.list[a], 2])
		## a_SNPs with new column 'merge', that contains the info from the SNP data table?
		a_SNPs[,merge:=SNPs]
		### Sort the rows of a data.table (a_SNPs) by the column (c) 'merge' (now the key)
		setkeyv(a_SNPs, c('merge'))
		## Identify the nearest TE base pair for each SNP
		merge_SNPs_TEs <- a_TEs[a_SNPs, roll='nearest']
		## Measure the distance from each SNP to the TE
		## A value of zero means the snp is in the TE
		## Output = List of lists by scaffold index # > list of distances
		output[[a]] <- abs(merge_SNPs_TEs$SNPs - merge_SNPs_TEs$TEs)
		print(a)
	}
}
## Vector of all SNP to TE distances
output2 <- unlist(output)
## Table of distances (counts of SNPs at each distance from TE (in list) per scaffold)
output3 <- table(output2)

test1 <- as.numeric(names(output3))
test2 <- as.vector(output3)

## Log statement
log2 <- "Observed SNP to TE data tables complete."
print(log2, quote=FALSE)
toc()

#### Expected values below

tic("Calculate all possible SNP:TE distances loop")

### Loop for each scaffold to get distance to TE for every position in the genome
output_r <- list()
for(a in 1:length(x.list)) {
	## Subset TE file by this scaffold
	a_TEs <- TEs[TEs[,1] %in% x.list[a], ]
	## Set up output file list
	TE_list <- list()
	## Run the following if there are TEs on this scaffold
	if(nrow(a_TEs) > 0) {
		## Obtain all the bp locations of TEs and remove overlaps
		for(b in 1:nrow(a_TEs)) {
			TE_list[[b]] <- seq(a_TEs[b,2], a_TEs[b,3])
		}
		## Set up data table and properties of this scaffold's TEs
		a_TEs <- data.table(TEs=unique(unlist(TE_list)))
		a_TEs[,merge:=TEs]
		setkeyv(a_TEs, c('merge'))
		## Set up data table of every location on the scaffold
		a_SNPs <- data.table(SNPs=seq(from=1, to=x[x[,1] == x.list[a], 2], by=1))
		a_SNPs[,merge:=SNPs]
		setkeyv(a_SNPs, c('merge'))
		## Identify the nearest TE base pair for each position on the scaffold
		merge_SNPs_TEs <- a_TEs[a_SNPs, roll='nearest']
		## Measure the distance from each position to the TE
		## A value of zero means the position is in the TE
		output_r[[a]] <- abs(merge_SNPs_TEs$SNPs - merge_SNPs_TEs$TEs)
		print(a)
	}
}
## Vector of all positions to TE distances
output_r2 <- unlist(output_r)

## Log statement
log3 <- "All possible SNP to TE distances data table generated for expected values loop."
print(log3, quote=FALSE)
toc()

tic("Randomized SNP distribution sampling loop")

## One hundred sampling replicates from the whole genome values with summary
## Also more detailed check of the first five hundred bp
first500 <- list()
replicate_output <- c()
## Modified August 13 2020, to be 500 reps instead of 100 reps ##
#for(a in 1:100) {
for(a in 1:500) {
	## Sample the whole genome by the number of SNPs in the observed dataset
	a_rep <- sample(output_r2, length(output2))
	## Count the proportion that are inside of TEs
	in_TEs <- length(a_rep[a_rep == 0]) / length(a_rep)
	## Summarize the output
	summary_a_rep <- as.vector(summary(a_rep[a_rep > 0]))
	replicate_output <- rbind(replicate_output, c(in_TEs, summary_a_rep[2:5]))

	## Table the results
	a_rep <- table(a_rep)
	## Measure the proportion of SNPs at each position (SNPs that are not in TEs)
	## If you want to measure including SNPs in TEs, use the next commented line instead
	#a_rep <- as.vector(a_rep[names(a_rep) %in% seq(from=1, to=500, by=1)]) / sum(as.vector(a_rep[1:length(a_rep)]))
	#a_rep <- as.vector(a_rep[names(a_rep) %in% seq(from=1, to=500, by=1)]) / sum(as.vector(a_rep[2:length(a_rep)]))
	## New line below, line above commented out May 2, 2019 ##
	a_rep <- cbind(as.vector(names(a_rep)[names(a_rep) %in% seq(from=1, to=500, by=1)]), as.vector(a_rep[names(a_rep) %in% seq(from=1, to=500, by=1)]) / sum(as.vector(a_rep[2:length(a_rep)])))
	## Modified the line below May 2, 2019 ##
	first500[[a]] <- data.frame(position=as.numeric(a_rep[,1]), proportion=as.numeric(a_rep[,2]))
	print(a)
}
replicate_output <- data.frame(in_TEs=as.numeric(replicate_output[,1]), Q1=as.numeric(replicate_output[,2]), Median=as.numeric(replicate_output[,3]), Mean=as.numeric(replicate_output[,4]), Q3=as.numeric(replicate_output[,5]))

## Log statement
log4 <- "Expected SNP to TE data tables complete, Q1, Q3, median and mean calculated."
print(log4, quote=FALSE)
toc()

####### Write tables

tic("Write tables")

## Write table of expected values (summary)
write.table(replicate_output, file="<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>_expected_values.txt", sep="\t", quote=F, row.names=F, col.names=T)

## Write table of observed values (summary)
write.table(rbind(names(summary(output2)), summary(output2)), file="<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>_obs_values.txt", sep="\t",quote=F, row.names=F, col.names=F)

## Log statement
log5 <- "Expected and observed values table files created."
print(log5, quote=FALSE)
toc()

##### Plots

tic("Calculate basic stats for average expected SNP distribution")

## Get the mean for those 500 positions
#output_r3 <- rep(0,500)
#for(a in 1:500) {
#	a_rep <- mean(sapply(first500, "[[", a)) # Can change mean to min or median
#	output_r3[a] <- a_rep
#}

output_r3 <- rep(0,500)
output_r3_min <- c()
output_r3_max <- c()
for(a in 1:500) {
	a_rep <- c()
	for(b in 1:length(first500)) {
		b_rep <- first500[[b]][first500[[b]][,1] %in% a, 2]
		if(length(b_rep) == 1) {
			a_rep <- c(a_rep, b_rep)
		}
	}
	## If some randomizations didn't sample this site, add some zeros to represent those reps
	## Modified  line below August 13 2020, to be 500 reps, not 100 ##
	#a_rep <- c(a_rep, rep(0, (100 - length(a_rep))))
	a_rep <- c(a_rep, rep(0, (500 - length(a_rep))))
	## Added the following two lines June 3, 2019 ##
	output_r3_min <- c(output_r3_min, min(a_rep))
	output_r3_max <- c(output_r3_max, max(a_rep))
	a_rep <- mean(a_rep) # Can change mean to min or median
	output_r3[a] <- a_rep
}

output_close <- rep(0,500)
output3_names <- names(output3)
output3_values <- as.numeric(output3)
output3_sum <- sum(output3_values[2:length(output3_values)])
for(a in 1:500) {
	if(length(output3_values[output3_names %in% a]) > 0) {
		output_close[a] <- output3_values[output3_names %in% a] / output3_sum
	}
}

toc()
tic("Save workspace")

## Discard input tables from memory (SNP table is huge)
rm(snps)
rm(TEs)
rm(x)

## Save R workspace (SNP-TE positions and basic stats
## Important for ability to replot runs
save.image("<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>.RData")

tic("Generate plots")

### Plot the <VARIANT> enrichment from TE distance (modify the second abline as necessary) ###
output_close_r <- output_r3
par(mfrow=c(1,1))
par(mar=c(5,5,1,1))
pdf("<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>_enrichment_scaled_plot.pdf")
plot((output_close - output_close_r) * 100, pch=19, cex=0.5, xlab="Distance to TE (bp)", ylab="% Enrichment <VARIANT> Relative to Random", ylim=c(-0.0005, 0.002))
abline(h=0)
dev.off()

### Plot the <VARIANT> enrichment from TE distance, include exp ranges ###
output_close_r <- output_r3
pdf("<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>_enrichment_ranges_scaled_plot.pdf")
plot((output_close - output_close_r) * 100, pch=19, cex=0.2, xlab="Distance to TE (bp)", ylab="% Enrichment <VARIANT> Relative to Random", bty="l", ylim=c(-0.0005, 0.002))
abline(h=0)
points((output_close - output_close_r) * 100, pch=19, cex=0.2)
rep_range <- c()
for(a in 1:500) {
expected <- c(output_r3_min[a], output_r3_max[a])
expected_y <- (output_close[a] * 100) - (expected * 100)
expected_x <- c(a, a)
lines(expected_x, expected_y, lwd=0.3, col=rgb(0.3,0.3,0.3))
rep_range <- rbind(rep_range, c(a, expected_y[1], expected_y[2]))
}
dev.off()

rep_range <- data.frame(base_distance=as.numeric(rep_range[,1]), Expected_Max=as.numeric(rep_range[,2]), Expected_Min=as.numeric(rep_range[,3]))

write.table(rep_range, file="<OUTDIR>/<DATASET>_<SPECIES>_<TE_TYPE>_<IN_TYPE>_<VTYPE>_plot_min_max_values.txt", sep="\t", quote=F, row.names=F, col.names=T)

toc()
tic.clearlog()


#!/usr/bin/env Rscript

################################################
################################################
## REQUIREMENTS                               ##
################################################
################################################

## DIFFERENTIAL GENE EXPRESSION ANALYSIS
    ## - GENE COUNT QUANTIFICATION INPUTS FROM EITHER STRINGTIE2+FEATURECOUNTS OR BAMBU
    ## - SAMPLE INFORMATION INCLUDING CONDITIONS
    ## - THE PACKAGE BELOW NEEDS TO BE AVAILABLE TO LOAD WHEN RUNNING R

################################################
################################################
## LOAD LIBRARY                               ##
################################################
################################################

library(DESeq2)

################################################
################################################
## PARSE COMMAND-LINE PARAMETERS              ##
################################################
################################################
args = commandArgs(trailingOnly=TRUE)
if (length(args) < 2) {
    stop("Please input the directory with the featureCounts results and the sample information file", call.=FALSE)
}
# default output file
outfile <- "deseq2.results.txt"

transcriptquant <- args[1]
path            <-args[2]

################################################
################################################
## FORMAT GENE COUNT QUANTIFICATION OUTPUT    ##
################################################
################################################

#create a dataframe for all samples
if (transcriptquant == "stringtie2"){
    count.matrix       <- data.frame(read.table(path,sep="\t",header=TRUE, skip = 1))
    count.matrix$Chr   <- count.matrix$Start <- count.matrix$End <- count.matrix$Length <- count.matrix$Strand <- NULL
    colnames(count.matrix)[2:length(colnames(count.matrix))] <- unlist(lapply(strsplit(colnames(count.matrix)[2:length(colnames(count.matrix))],"\\."),"[[",1))
    count.matrix       <- aggregate(count.matrix[,-1],count.matrix["Geneid"],sum)
    countTab           <- count.matrix[,-1]
    rownames(countTab) <-count.matrix[,1]
}
if (transcriptquant == "bambu"){
    countTab           <- data.frame(read.table(path,sep="\t",header=TRUE))
    colnames(countTab) <- unlist(lapply(strsplit(colnames(countTab),"\\."),"[[",1))
    countTab[,1:length(colnames(countTab))] <- sapply(countTab, as.integer)
}

################################################
################################################
## READ IN SAMPLE INFORMATION (CONDITIONS)    ##
################################################
################################################

sample <- colnames(countTab)
group <- sub("(^[^-]+)_.*", "\\1", sample)
sampInfo <- data.frame(group, row.names = sample)
if (!all(rownames(sampInfo) == colnames(countTab))){
    sampInfo <- sampInfo[match(colnames(countTab), rownames(sampInfo)),]
}

################################################
################################################
## RUN DESEQ2                                 ##
################################################
################################################

dds <- DESeqDataSetFromMatrix(countData = countTab, colData = sampInfo, design = ~ group)
dds <- DESeq(dds)
res <- results(dds)
resOrdered <- res[order(res$pvalue),]
write.csv(as.data.frame(resOrdered), file=outfile)


regime <- "bolus"                   # exposure regime (bolus/continuous)
route <- "iv"                     # exposure route (oral/iv)
                                    # only relevant when regime="bolus" or iv
# Simulation parameters

A_type <- "VA"                # type of probabilistic analysis ("SA" or "VA")
chem_fix <- TRUE              # fixing the chemical and TK parameters or not (TRUE/FALSE)
n_boot <- 1000                # number of boostrap iterations (for SA)
n_out  <- 2                   # number of compartments to output (blood, total body)
t_A <- c(seq(0.05,0.2,by=0.05),seq(0.25,t_end,by=0.25))     # all time points for analysis (h), only relevant when chem_fix=TRUE

if (chem_fix & A_type=="SA") {

    # Sensitivity analysis with fixed chem parameters and varying physiology
    # initial list with names of all varying parameters

    Names_var <- c("BW",
                 paste("fBW",colnames(fBW[2+3*c(1:19)]),sep="_"),
                 "CO",
                 paste("fCO",colnames(fCO[2+3*c(1:19)]),sep="_"),
                 colnames(rates[2+3*c(0:4)]),
                 "nl","pl","pr","w")

    #initial list with median values of all varying parameters

    Medians <- cbind(fBW[fBW$species==species,2+3*c(0:19)],
                     fCO[fCO$species==species,2+3*c(0:19)],
                     rates[rates$species==species,2+3*c(0:4)],
                     data.frame(nl=1,pl=1,pr=1,w=1))
    colnames(Medians) <- Names_var
    Names_var_not <- colnames(Medians[which(Medians==0|is.na(Medians))])

    #update distribution parameters for varying parameters

    Medians <- Medians[!(colnames(Medians)%in%Names_var_not)]

    #exclude all compartments for which median = 0 or NA

    Lower <- Medians - 0.1*Medians
    Upper <- Medians + 0.1*Medians

    Names_var <- colnames(Medians)
    NP_var <- length(Names_var) #number of varying parameters

    # all fixed parameters (including 'varying parameters' that are 0 or NA)

    Names_fix <- c(colnames(TK[3:8]),
                   colnames(chem[2:5]),
                   colnames(fPC[2:57]),
                   Names_var_not)

    NP_fix <- length(Names_fix) # number of fixed parameters

    fix_in <- cbind(TK[TK$species==species&TK$chemical==chemical,colnames(TK)%in%Names_fix],
                    chem[chem$chemical==chemical,colnames(chem)%in%Names_fix],
                    fPC[fPC$species==species,colnames(fPC)%in%Names_fix],
                    fBW[fBW$species==species,colnames(fBW)%in%substr(Names_var_not[grep('fBW',Names_var_not)],start=5,stop=nchar(Names_var_not[grep('fBW',Names_var_not)]))],
                    fCO[fCO$species==species,colnames(fCO)%in%substr(Names_var_not[grep('fCO',Names_var_not)],start=5,stop=nchar(Names_var_not[grep('fCO',Names_var_not)]))],
                    rates[rates$species==species,colnames(rates)%in%Names_var_not])
    colnames(fix_in) <- Names_fix

 ######################################################
 # Create data frames with random samples

    X1 <- matrix(NA, nrow = n_sim, ncol = NP_var)
    colnames(X1) <- Names_var
    X1 <- as.data.frame(X1)

    X2 <- matrix(NA, nrow = n_sim, ncol = NP_var)
    colnames(X2) <- colnames(X1)
    X2 <- as.data.frame(X2)

    for(i in 1:NP_var){
      X1[,i] <- runif(n_sim, min = Lower[,i], max = Upper[,i])
      X2[,i] <- runif(n_sim, min = Lower[,i], max = Upper[,i])
    }

 ######################################################
 # Sobol design
    sa <- soboljansen(model = NULL, X1, X2, nboot = n_boot, conf = 0.95)
    SARes <- sa$X

    #create output data frame
    #SimRes <- matrix(NA, nrow = nrow(SARes), ncol = n_out*length(t_A))
    #colnames(SimRes) <- c(paste("blood_t",t_A,sep=""),paste("wholebody_t",t_A,sep=""))
    #SimRes <- as.data.frame(SimRes)

  } else if (A_type=="SA") {

    # Sensitivity analysis with fixed chem parameters and varying physiology
    # initial list with names of all varying parameters

    Names_var <- c(colnames(TK[3:8]),
                   colnames(chem[2:5]))

    #initial lower and upper limits for uniform distributions
    Lower <- as.data.frame(cbind(0,0,0,NA,NA,NA,10,0.001,0.00001,0.01))
    Upper <- as.data.frame(cbind(1,1,1,NA,NA,NA,1000,1000,10000000000000,100000))
    colnames(Lower) = colnames(Upper) = Names_var

    Names_var_not <- colnames(Lower[which(is.na(Lower))])

    Lower <- Lower[!(colnames(Lower)%in%Names_var_not)] #exclude all compartments for which median = 0 or NA
    Upper <- Upper[!(colnames(Upper)%in%Names_var_not)] #exclude all compartments for which median = 0 or NA

    Names_var <- colnames(Lower)
    NP_var <- length(Names_var) #number of varying parameters

    #list with names of all fixed parameters (including 'varying parameters' that are 0 or NA)

    Names_fix <- c("BW",
                   paste("fBW",colnames(fBW[2+3*c(1:19)]),sep="_"),
                   "CO",
                   paste("fCO",colnames(fCO[2+3*c(1:19)]),sep="_"),
                   colnames(rates[2+3*c(0:4)]),
                   colnames(fPC[2:57]),
                   "nl","pl","pr","w",
                   Names_var_not)
    NP_fix <- length(Names_fix) #number of fixed parameters

    fix_in <- cbind(fBW[fBW$species==species,"BW"],
                    fBW[fBW$species==species,colnames(fBW)%in%substr(Names_fix[grep('fBW',Names_fix)],start=5,stop=nchar(Names_fix[grep('fBW',Names_fix)]))],
                    fCO[fCO$species==species,"CO"],
                    fCO[fCO$species==species,colnames(fCO)%in%substr(Names_fix[grep('fCO',Names_fix)],start=5,stop=nchar(Names_fix[grep('fCO',Names_fix)]))],
                    rates[rates$species==species,colnames(rates)%in%Names_fix],
                    fPC[fPC$species==species,colnames(fPC)%in%Names_fix],
                    data.frame(nl=1,pl=1,pr=1,w=1),
                    TK[TK$species==species&TK$chemical==chemical,colnames(TK)%in%Names_var_not],
                    chem[chem$chemical==chemical,colnames(chem)%in%Names_var_not])
    colnames(fix_in) <- Names_fix

    #Change upper limit for clearance depending on physiology of species of interest
      #renal clearance = blood flow to kidneys
      Upper[,"Cl_renal"] <- fix_in$fCO_kidney * fix_in$CO / fix_in$BW
      #hepatic clearance = blood flow to liver (incl portal artery)
      Upper[,"Cl_hepatic"] <- (fix_in$fCO_liver+fix_in$fCO_intestine)*fix_in$CO/fix_in$BW

    #create data frames with random samples
    X1 <- matrix(NA, nrow = n_sim, ncol = NP_var)
    colnames(X1) <- Names_var
    X1 <- as.data.frame(X1)

    X2 <- matrix(NA, nrow = n_sim, ncol = NP_var)
    colnames(X2) <- colnames(X1)
    X2 <- as.data.frame(X2)

    for(i in 1:NP_var){
      X1[,i] <- runif(n_sim, min = Lower[,i], max = Upper[,i])
      X2[,i] <- runif(n_sim, min = Lower[,i], max = Upper[,i])
    }

    #Sobol design
    sa <- soboljansen(model = NULL, X1, X2, nboot = n_boot, conf = 0.95)
    SARes <- sa$X

    #create output data frame
    #SimRes <- matrix(NA, nrow = nrow(SARes), ncol = 3)
    #colnames(SimRes) <- c("Cmax","tmax","AUC_24h")
    #SimRes <- as.data.frame(SimRes)

  } else if (A_type=="VA") {

    # variability analysis with fixed chemical and TK parameters

    Names_var <- c("BW",
                   paste("fBW",colnames(fBW[2+3*c(1:19)]),sep="_"),
                   "CO",
                   paste("fCO",colnames(fCO[2+3*c(1:19)]),sep="_"),
                   colnames(rates[2+3*c(0:4)]))

    # initial list with mean + sd values of all varying parameters

    Means <- cbind(fBW[fBW$species==species,2+3*c(0:19)],
                   fCO[fCO$species==species,2+3*c(0:19)],
                   rates[rates$species==species,2+3*c(0:4)])
    SDs <- cbind(fBW[fBW$species==species,3+3*c(0:19)],
                 fCO[fCO$species==species,3+3*c(0:19)],
                 rates[rates$species==species,3+3*c(0:4)])
    Distributions <- cbind(fBW[fBW$species==species,4+3*c(0:19)],
                          fCO[fCO$species==species,4+3*c(0:19)],
                          rates[rates$species==species,4+3*c(0:4)])
    colnames(Means) = colnames(SDs) = colnames(Distributions) = Names_var
    Names_var_not <- colnames(SDs[which(is.na(SDs))])

    Means <- Means[!(colnames(Means)%in%Names_var_not)] #exclude all parameters without SD
    SDs <- SDs[!(colnames(SDs)%in%Names_var_not)] #exclude all parameters without SD
    Distributions <- Distributions[!(colnames(Distributions)%in%Names_var_not)] #exclude all parameters without SD

    Names_var <- colnames(SDs)
    NP_var <- length(Names_var) #number of varying parameters

    #list with names of all fixed parameters (including 'varying parameters' that are 0 or NA)
    Names_fix <- c(colnames(fPC[2:57]),
                   "nl","pl","pr","w",
                   colnames(TK[3:8]),
                   colnames(chem[2:5]),
                   Names_var_not)
    NP_fix <- length(Names_fix) # number of fixed parameters

    fix_in <- cbind(fPC[fPC$species==species,colnames(fPC)%in%Names_fix],
                    data.frame(nl=1,pl=1,pr=1,w=1),
                    TK[TK$species==species&TK$chemical==chemical,colnames(TK)%in%Names_fix],
                    chem[chem$chemical==chemical,colnames(chem)%in%Names_fix],
                    fBW[fBW$species==species,colnames(fBW)%in%substr(Names_fix[grep('fBW',Names_fix)],start=5,stop=nchar(Names_fix[grep('fBW',Names_fix)]))],
                    fCO[fCO$species==species,colnames(fCO)%in%substr(Names_fix[grep('fCO',Names_fix)],start=5,stop=nchar(Names_fix[grep('fCO',Names_fix)]))],
                    rates[rates$species==species,colnames(rates)%in%Names_fix])
    colnames(fix_in) <- Names_fix

    # create data frames with random samples
    X1 <- matrix(NA, nrow = n_sim, ncol = NP_var)
    colnames(X1) <- Names_var
    X1 <- as.data.frame(X1)
    SARes <- X1

    for(i in 1:NP_var){
      if (Distributions[i] == "N") {
        SARes[,i] <- rnorm(n_sim, mean = Means[,i], sd = SDs[,i])
      } else if (Distributions[i] == "B") {
        alpha <- ((1 - Means[,i]) / SDs[,i]^2 - 1 / Means[,i]) * Means[,i] ^ 2
        beta <- alpha * (1 / Means[,i] - 1)
        SARes[,i] <- rbeta(n_sim, shape1 = alpha, shape2 = beta)
      } else if (Distributions[i] == "LN") {
        CV <- SDs[,i]/Means[,i]
        mlog <- log(Means[,i]/sqrt(1+CV^2)) #mean of log values
        slog <- sqrt(log(1+CV^2)) #sd of log values
        SARes [,i] <- rlnorm(n_sim, meanlog = mlog, sdlog = slog)
      }
    }

    # create output data frame

    SimRes <- matrix(NA, nrow = nrow(SARes), ncol = n_out*length(t_A))

    colnames(SimRes) <- c(paste("blood_t",t_A,sep=""),paste("wholebody_t",t_A,sep=""))
    SimRes <- as.data.frame(SimRes)
    write.csv(SimRes,paste0("./Output/SimRes_blood_",idsim,".csv",sep=""),row.names = FALSE)
  }

##############################################################################################################################
# Model run for probabilistic analysis (to be done on separate/external server)

for (k in 1:(nrow(SARes))) {

      var_in_temp <- SARes
      par_in <-suppressWarnings(cbind(var_in_temp,fix_in))

      # adjust clearance rates of hypothetical chemicals based on values drawn for physiology

      write.csv(par_in,file=paste("./temp/par_in_",k,"_",idsim,".csv",sep=""),row.names = FALSE)
    }

    SimRes <- matrix(NA, nrow = nrow(par_in), ncol = n_out*length(t_A))
    colnames(SimRes) <- c(paste("blood_t",t_A,sep=""),paste("wholebody_t",t_A,sep=""))
    if (!chem_fix) {
                    SimRes <- matrix(NA, nrow = nrow(par_in), ncol = 3)
                    colnames(SimRes) <- c("Cmax","tmax","AUC_h")
    }

    SimRes <- as.data.frame(SimRes)

    # par_in

    for (j in 1:nrow(par_in)) {

      print(paste0("Running loop: ", j))
      print(paste("Current time: ", Sys.time()))

      out_sim<- multi_tool_fast(
        par_in = par_in[j,], # raw index input data frame
        species = species, regime = regime, route = route,
        E_dose = E_dose, E_start = E_start, E_end = E_end, E_int = E_int, # exposure scenario
        n_out = n_out, t_start = t_start, t_end = t_end, t_A = t_A,
        chem_fix = chem_fix)

      SimRes[j,]=out_sim
    }

    data_sim=t(rbind(SimRes,t_A))
    data_blood=data_sim[1:length(t_A),]
    ini=length(t_A)+1
    data_body=data_sim[ini:nrow(data_sim),]

    row.names(data_blood)=NULL
    row.names(data_body)=NULL

    res_sims_blood=list()
    for ( i in 1:n_sim) {
      t=as.numeric(data_blood[,n_sim+1])
      C=as.numeric(data_blood[,i])
      t=t[which(!is.na(C))]
      C=C[which(!is.na(C))]
      res_sims_blood[[i]]=cbind(t,C)
    }
    res_sims_body=list()
    for ( i in 1:n_sim) {
      t=as.numeric(data_body[,n_sim+1])
      C=as.numeric(data_body[,i])
      t=t[which(!is.na(C))]
      C=C[which(!is.na(C))]
      res_sims_body[[i]]=cbind(t,C)
    }


# This script reads data from the PantherDB project and takes a pair of functions
# per set of gene trees so that later it estimates the model parameters and predicts
# Them
rm(list = ls())

library(aphylo)
library(ape)

# Reading in the tree data
dat <- read.table(
  "../aphylo_paper/data-raw/experimental_function",
  sep="\t",
  stringsAsFactors = FALSE,
  col.names = c("node_id", "lead_id", "go_id", "annotation")
  )

# Getting the panther book
dat$book_id <- gsub("[:].+$", "", dat$node_id)

# Coding annotations
dat$status <- with(
  dat,
  ifelse(annotation == "NOT", 0L, ifelse(annotation == "", NA, 1L))
  )

library(dplyr)
counts <- group_by(dat, book_id, go_id) %>%
  summarize(
    nas   = sum(is.na(status)),
    zeros = sum(status[!is.na(status)] == 0),
    ones  = sum(status[!is.na(status)] == 1)
  )

counts <- counts[with(counts, order(zeros, ones, decreasing = TRUE)),]

# This is the set of books that we should use
counts_relevant <- as.data.frame(subset(counts, (zeros != 0) & (ones != 0)))

# Book PTHR23255 and go GO:0050431 is nice
# PTHR10788
# GO:0004805

read_aphylo <- function(family, fun) {
  ans <- read_panther(sprintf("../PANTHER11.1/books/%s/tree.tree", family))

  ids <- paste(family, gsub("[:].+", "", ans$tree$tip.label), sep = ":")

  A <- subset(dat, (book_id == family) & (node_id %in% ids) & (go_id == fun))
  A$node_id <- ans$tree$tip.label[match(A$node_id, ids)]

  # Creating the aphylo object
  try(new_aphylo(
    data.frame(A$node_id, fun= A$status, stringsAsFactors = FALSE,
               check.names = FALSE),
    as_po_tree(ans$tree)
  ))

}

L <- Map(
  read_aphylo,
  family = as.list(counts_relevant$book_id),
  fun    = as.list(counts_relevant$go_id)
  )

atree <- L[[2]]
ans_mle  <- aphylo_mle(atree, priors = function(x) dbeta(x, 2, 30))
ans_mcmc <- aphylo_mcmc(ans_mle$par, atree, priors = function(x) dbeta(x, 2, 30),
                        control=list(nbatch=1e5, thin=100, burnin=1e4, nchains=5))

score <- prediction_score(ans_mcmc)
plot(score)
Matrix::image(
  methods::as(cbind(
    predict(ans_mcmc, what = names(which(ans_mcmc$dat$annotations[,1] != 9))),
    ans_mcmc$dat$annotations[names(which(ans_mcmc$dat$annotations[,1] != 9)),]
  ), "dgCMatrix"))


ibrary(rgdal)
library(rBiometeo)

###########################################################à#############################################################################

source("aux_orientation.r")

###########################################################à#############################################################################
strade_orientation_df <- readOGR(".", "strade_df")

orient_gis=read.csv("Orientation_strade_df.csv")
strade_orientation <- readOGR(".", "strade_orientation")

strade_orientati_seg=segmented_lines(strade_orientation)
strade_orientati_seg_df=SpatialLinesDataFrame(strade_orientati_seg,data.frame(id=1:length(strade_orientati_seg)))
strade_orientati_seg_df$orient=orient_gis$Orientation
strade_orientati_seg_df$sector=compass_8(strade_orientation_df$orient)
strade_orientati_seg_df$sector_windstreet=strade_orientati_seg_df$sector

strade_orientati_seg_df$sector=compass_8(strade_orientation_df$orient)

idNE_SO=c(which(strade_orientati_seg_df$sector=="NE"),which(strade_orientati_seg_df$sector=="SW"))
idN_S=c(which(strade_orientati_seg_df$sector=="N"),which(strade_orientati_seg_df$sector=="S"))
idE_O=c(which(strade_orientati_seg_df$sector=="E"),which(strade_orientati_seg_df$sector=="W"))
idNW_SE=c(which(strade_orientati_seg_df$sector=="NW"),which(strade_orientati_seg_df$sector=="SE"))

strade_orientati_seg_df$sector_windstreet[idNE_SO]="asse_NE_SO"
strade_orientati_seg_df$sector_windstreet[idN_S]="asse_N_S"
strade_orientati_seg_df$sector_windstreet[idE_O]="asse_E_O"
strade_orientati_seg_df$sector_windstreet[idNW_SE]="asse_NW_SE"
writeOGR(strade_orientati_seg_df, ".", "strade_df_guerri", driver="ESRI Shapefile",overwrite_layer=T)

###########################################################à#############################################################################


## Assorted routines for manipulation of
## Zernike polynomials, interferogram analysis,
## and other forms of optical testing

## Author: M.L. Peck (mlpeck54@gmail.com)
## Language: R (http://www.r-project.org/)
## Copyright (c) 2004-2021, M.L. Peck

## greyscale

grey256 <- gray(seq(0,1,length=256))
gray256 <- grey256

## A rainbow that may be better than R's rainbow() color palette

rygcb <- colorRampPalette(c("red", "yellow", "green", "cyan", "blue"), space = "Lab",
            interpolate="spline")

## Yet another rainbow made up of additive and subtractive primaries

rygcbm <- colorRampPalette(c("red", "yellow", "green", "cyan", "blue", "magenta"),
			space="Lab", interpolate="spline")

## comparison plot of n wavefront estimates

plotn <- function(...,
  labels=NULL, addContours=FALSE,
  wftype="net", col=rygcb(400), qt=c(.01, .99)) {
	fits <- list(...)
	nwf <- length(fits)
	wfget <- paste("wf",wftype,sep=".")
	wfi <- get(wfget, pos=fits[[1]])
	nr <- nrow(wfi)
	nc <- ncol(wfi)
	wfs <- array(0, dim=c(nr,nc,nwf))
	wfs[,,1] <- wfi
	for (i in 2:nwf) wfs[,,i] <- get(wfget,pos=fits[[i]])
	rm(fits)
	if(is.null(labels)) labels=1:nwf

	rdiff <- matrix(0,nwf*(nwf-1)/2,2)
	k <- 1
	for (i in 1:(nwf-1)) {
		for (j in (i+1):nwf) {
			rdiff[k,] <- quantile(wfs[,,i]-wfs[,,j], probs=qt, na.rm=TRUE)
			k <- k+1
		}
	}
	zlim <- range(rdiff)
	if (tolower(.Platform$OS.type)=="windows") {
          windows(width = 5*nwf, height = 5*nwf)
        } else {
          X11(width = 5*nwf,height = 5*nwf)
        }
	par(mar=c(0,0,2,0))
	split.screen(figs=c(nwf,nwf))
	for (i in 1:nwf) {
	  screen(i)
	  wfi <- wfs[,,i]
	  class(wfi) <- "pupil"
	  plot(wfi, col=col, addContours=addContours, eqa=(wftype=="net"), axes=FALSE)
	  title(main=paste(labels[i],"rms=",format(pupilrms(wfi),digits=3)))
	}
	scr <- nwf+1
	for (row in 1:(nwf-1)) {
	  screen(scr)
	  plot(0:1,0:1,type="n",axes=FALSE)
	  text(0.5,0.5,labels[row])
	  scr <- scr+row
	  for (i in (row+1):nwf) {
		screen(scr)
		image(1:nr,1:nc,wfs[,,row]-wfs[,,i],col=grey256,asp=1,axes=FALSE,zlim=zlim,useRaster=TRUE)
		title(main=paste("rms diff =",format(pupilrms(wfs[,,row]-wfs[,,i]), digits=3)))
		scr <- scr+1
	  }
	}
	close.screen(all.screens=T)
}

## plot cross sections through a wavefront map

plotxs <- function(wf, cp, theta0=0, ylim=NULL, N=4, n=101,
	col0="black", col="gray", lty=2) {
  theta0 <- theta0*pi/180
  ixy <- seq(-1,1,length=n)
  theta <- (0:(N-1))*pi/N
  ix <- cp$rx*ixy
  iy <- cp$ry*ixy
  if (is.null(ylim)) ylim <- range(wf, na.rm=TRUE)
  plot(range(ixy),ylim, type="n", xlab="rho", ylab="Height")
  for (i in 1:N) {
	iix <- round(cp$xc+cos(theta[i])*ix)
	iiy <- round(cp$yc+sin(theta[i])*iy)
	points(ixy, diag(wf[iix,iiy]), type="l", col=col, lty=lty)
  }
  iix <- round(cp$xc+cos(theta0)*ix)
  iiy <- round(cp$yc+sin(theta0)*iy)
  points(ixy, diag(wf[iix,iiy]), type="l", col=col0, lty=lty)
}

###########
## Various fun stuff
###########

## Star test simulator & support routines

## calculate phase values for wavefront at wavelength lambda
## replaces NA values with 0

wftophase <- function(X, lambda = 1) {
    phi <- exp(2i*pi*X/lambda)
    phi[is.na(phi)] <- 0
    phi
}

## puts matrix X into corner of npadded x npadded matrix
## padded with zeroes

padmatrix <- function(X, npad, fill=0) {
    nr <- nrow(X)
    nc <- ncol(X)
    xpad <- matrix(fill, npad, npad)
    xpad[1:nr,1:nc] <- X
    xpad
}

## extract a matrix from the center of a larger matrix

submatrix <- function(X,size=255) {
    nr <- nrow(X)
    X[((nr-size)/2+1):((nr+size)/2),((nr-size)/2+1):((nr+size)/2)]
}

## shuffle quadrants of a 2d fft around to display as an image

fftshift <- function(X) {
    nr <- nrow(X)
    XS <- matrix(0,nr,nr)
    XS[1:(nr/2),1:(nr/2)] <- X[(nr/2+1):nr,(nr/2+1):nr]
    XS[(nr/2+1):nr,(nr/2+1):nr] <- X[1:(nr/2),1:(nr/2)]
    XS[(nr/2+1):nr,1:(nr/2)] <- X[1:(nr/2),(nr/2+1):nr]
    XS[1:(nr/2),(nr/2+1):nr] <- X[(nr/2+1):nr,1:(nr/2)]
    XS
}

## computes & displays fraunhofer diffraction pattern
## & mtf for wavefront described in zernike coefficients zcoef

startest <- function(wf=NULL, zcoef=NULL, maxorder=14L, phi=0,
	lambda = 1, defocus=5, cp=NULL,
	obstruct=NULL,
	npad = 4,
	gamma=2, psfmag=2, displaymtf=TRUE, displaywf=FALSE) {

    if (tolower(.Platform$OS.type) == "windows") {
      windows(width=15, height=5)
    } else {
      x11(width=15,height=5)
    }
    screens<- split.screen(c(1,3))

    if (is.null(wf)) {
      wf <- pupil(zcoef=zcoef, maxorder=maxorder, phi=phi, piston=0)
      cp <- cp.default
    } else {
      if (is.null(cp)) {
        stop("must specify cp if wf is non-null")
      }
    }
    nrow <- nrow(wf)
    ncol <- ncol(wf)
    wf.df <- pupil(zcoef=c(0, 0, 0, 1), maxorder=2, nrow=nrow, ncol=ncol, cp=cp)
    if (!is.null(obstruct)) {
      wf[is.na(wf.df)] <- NA
    }
    lx <- round(2*cp$rx)+1
    ly <- round(2*cp$ry)+1
    npad <- npad * .up2(lx,ly)

    phase <- wftophase(wf,lambda)
    up <- Mod(fft(padmatrix(phase,npad)))
    up <- up*up

    otf <- fft(up, inverse=TRUE)/npad^2
    otf <- otf[1:lx,1:ly]
    mtf <- Re(otf)
    mtf <- mtf/max(mtf)
    freqx <- seq(0,1,length=lx)
    freqy <- seq(0,1,length=ly)
    mtfideal <- 2/pi*(acos(freqx)-freqx*sqrt(1-freqx^2))

    nrpsf <- max(lx,ly)
    psf <- submatrix(fftshift(up),floor(nrpsf/psfmag))
    screen(screens[2])
    image(psf^(1/gamma),col=grey256,asp=1,bty='n', axes=FALSE, useRaster=TRUE)
    mtext("0")

    if (defocus >5) nrpsf <- 2*nrpsf
    if (defocus >15) nrpsf <- npad

    phase <- wftophase(wf - defocus/3.46*lambda*wf.df, lambda)
    up <- Mod(fft(padmatrix(phase,npad)))
    up <- up*up
    psf2 <- submatrix(fftshift(up),nrpsf)
    screen(screens[1])
    image(psf2^(1/gamma),col=grey256, asp=1,bty='n', axes=FALSE, useRaster=TRUE)
    mtext(-defocus)

    phase <- wftophase(wf + defocus/3.46*lambda*wf.df, lambda)
    up <- Mod(fft(padmatrix(phase,npad)))
    up <- up*up
    psf2 <- submatrix(fftshift(up),nrpsf)
    screen(screens[3])
    image(psf2^(1/gamma),col=grey256,asp=1,bty='n',axes=FALSE, useRaster=TRUE)
    mtext(defocus)
    close.screen(all.screens=TRUE)

    if (displaywf) {
            if (tolower(.Platform$OS.type) == "windows") windows() else x11()
            plot(wf/lambda)
    }

    if (displaymtf) {
            if (tolower(.Platform$OS.type) == "windows") windows() else x11()
            plot(freqx,mtf[1,],type="l",ylab="mtf",xlab="relative frequency")
            title(main='MTF vs. ideal')
            lines(freqy,mtf[,1])
            lines(freqx,mtfideal, lty=5)
            grid()
    }
    list(psf=psf, otf=otf, mtf=mtf)
}

## Kolmogorov turbulence

turbwf <- function(friedratio=1, zlist=makezlist(2,40), reps=1) {
    require(mvtnorm)
    dimz <- length(zlist$n)
    cova <- matrix(0, nrow=dimz, ncol=dimz)
    c0 <- friedratio^(5/3)*gamma(14/3)*(4.8*gamma(1.2))^(5/6)*(gamma(11/6))^2/(2^(8/3)*pi)
    for (i in 1:dimz) {
        for (j in i:dimz) {
            if ((zlist$m[i] == zlist$m[j]) && (zlist$t[i] == zlist$t[j])) {
                n <- zlist$n[i]
                np <- zlist$n[j]
                cova[i,j] <- (-1)^((n+np-2*zlist$m[i])/2) * sqrt((n+1)*(np+1)) *
                                gamma((n+np-5/3)/2)/(gamma((np-n+17/3)/2)*gamma((n-np+17/3)/2)*
                                gamma((n+np+23/3)/2))
                cova[j,i] <- cova[i,j]
            }
        }
    }
    cova <- cova * c0/(4*pi^2)
    zcoef.turb <- rmvnorm(reps, mean=rep(0,dimz), sigma=cova)
    if (reps==1) zcoef.turb <- as.vector(zcoef.turb)
    list(zcoef.turb=zcoef.turb, V=cova)
}

## Foucault test simulator

foucogram <- function(wf, edgex = 0, phradius = 0, slit=FALSE, pad=4, gamma=1,
                      map =FALSE, lev=0.5) {

    nr <- nrow(wf)
    nc <- ncol(wf)
    npad <- pad*nextn(max(nr,nc))
    phi<-padmatrix(wftophase(wf),npad)
    ca<-fftshift(fft(phi))
    u <- npad/2 + 1 + edgex
    ca[1:(u-phradius-1),]<-0
    ca[u,] <- .5*ca[u,]
    if (phradius>0) {
        if (slit) {
            for (i in 1:phradius) {
                f <- .5*(1+i/phradius)
                ca[(u+i),] <- f*ca[(u+i),]
                ca[(u-i),] <- (1-f)*ca[(u-i),]
            }
        } else {
            for (i in 1:phradius) {
                f <- .5 + i*sqrt(phradius^2-i^2)/(pi*phradius^2) + asin(i/phradius)/pi
                ca[(u+i),] <- f*ca[(u+i),]
                ca[(u-i),] <- (1-f)*ca[(u-i),]
            }
        }
    }
    ike <- Mod(fft(ca,inverse=T)[1:nr,1:nc])^2
    image(ike^(1/gamma),col=grey256,asp=nc/nr,axes=FALSE, useRaster=TRUE)
    if (map) {
        zmin <- floor(min(wf, na.rm=TRUE))
        zmax <- ceiling(max(wf, na.rm=TRUE))
        contour(wf,add=TRUE,levels=seq(zmin,zmax,by=lev),
                axes=FALSE,frame.plot=FALSE,col="red")
    }
    ike/max(ike)
}

## Synthetic interferogram

## notes: must have either non-null wf or zcoef. If wf is NULL
##        and cp is null make a new wavefront with current defaults
##        for matrix size and cp in pupil(), otherwise use the values
##        passed here. If wf is non-null zcoef is ignored
##        and the correct cp must be passed.

synth.interferogram <- function(wf=NULL, zcoef=NULL, maxorder=NULL,
                                nr=nrow(wf), nc=ncol(wf), cp=NULL,
                                phi=0, addzc=rep(0,4), fringescale=1,
                                plots=TRUE) {
  if (is.null(wf)) {
    if (is.null(cp)) {
      wf <- pupil(zcoef=zcoef, maxorder=maxorder, phi=phi, piston=0)+
            pupil(zcoef=addzc, maxorder=2)
      nr <- nrow(wf)
      nc <- ncol(wf)
      cp <- cp.default
    } else {
      wf <- pupil(zcoef=zcoef, maxorder=maxorder, phi=phi, piston=0,
                  nrow=nr, ncol=nc, cp=cp) +
            pupil(zcoef=addzc, maxorder=2, nrow=nr, ncol=nc, cp=cp)
    }
  } else {
    if (is.null(cp)) {
      stop("must specify a value for cp if wf is non-null")
    }
    wf <- wf + pupil(zcoef=addzc, maxorder=2, nrow=nr, ncol=nc, cp=cp)
  }
  igram <- cos(2*pi*wf/fringescale)
  igram[is.na(igram)] <- 0
  class(igram) <- c("pupil", class(igram))
  if (plots) plot(igram, col=grey256, addContours=FALSE)
  igram
}

#########
## general utilities
#########

## crop an array

crop <- function(img, cp, npad=20) {
    nr <- dim(img)[1]
    nc <- dim(img)[2]
    xmin <- max(1, round(cp$xc-cp$rx-npad))
    xmax <- min(nr, round(cp$xc+cp$rx+npad))
    ymin <- max(1, round(cp$yc-cp$ry-npad))
    ymax <- min(nc, round(cp$yc+cp$rx+npad))
    cp.new <- cp
    cp.new$xc <- cp$xc-xmin+1
    cp.new$yc <- cp$yc-ymin+1
    if (length(dim(img)) > 2) img <- img[xmin:xmax,ymin:ymax,]
    else img <- img[xmin:xmax,ymin:ymax]
    list(im=img, cp=cp.new)
}

## general purpose 2D convolution using FFT's.

## kern is the convolution kernel

convolve2d <- function(im, kern) {
	nr <- nrow(im)
	nc <- ncol(im)
	nrp <- nr + nrow(kern) - 1
	ncp <- nc + ncol(kern) - 1
	xs <- nrow(kern) %/% 2 + nrow(kern) %% 2
	ys <- ncol(kern) %/% 2 + ncol(kern) %% 2
	npad <- nextn(max(nrp, ncp))
	kern <- padmatrix(kern, npad=npad)
	im <- padmatrix(im, npad=npad)
	im.f <- Re(fft(fft(kern)*fft(im), inv=T))
	im.f <- im.f[xs:(nr+xs-1),ys:(nc+ys-1)]/(npad^2)
	return(im.f)
}

## Gaussian blur. fw is the standard deviation
## of the gaussian convolution kernel, in pixels.

gblur <- function(X, fw = 0, details=FALSE) {
  if (fw == 0) return(X)
  XP <- X
  XP[is.na(XP)] <- 0
  nr <- nrow(X)
  nc <- ncol(X)
  ksize <- max(ceiling(4 * fw), 3)
  if ((ksize %% 2) == 0) ksize <- ksize+1
  xc <- (ksize %/% 2) + 1
  xs <- ((1:ksize)-xc)/fw
  gkern <- outer(xs, xs, function(x,y) (x^2+y^2))
  gkern <- exp(-gkern/2)
  gkern <- round(gkern/min(gkern))
  npad <- nextn(max(nr,nc)+ksize-1)
  XP <- padmatrix(XP, npad)
  kernp <- padmatrix(gkern, npad)
  XP <- Re(fft(fft(XP)*fft(kernp), inv=TRUE))/(npad^2)/sum(gkern)
  XP <- XP[xc:(nr+xc-1), xc:(nc+xc-1)]
  XP[is.na(X)] <- NA
  if (details)
	  return(list(gkern=gkern, X=XP))
  else return(XP)
}

## Plot a complex matrix.
## Maybe make cmat a class, so this becomes default plot routine?

plot.cmat <- function(X, fn="Mod", col=grey256, cp=NULL, zoom=1, gamma=1, ...) {
	  ## define some possibly useful functions. Note Mod2 produces power spectrum

	logMod <- function(X) log(1+Mod(X))
	Mod2 <- function(X) Mod(X)^2
	logMod2 <- function(X) log(Mod2(X))
	nr <- nrow(X)
	nc <- ncol(X)
	xs <- seq(-nr/2,nr/2-1,length=nr)
	ys <- seq(-nc/2,nc/2-1,length=nc)
	if (!is.null(cp)) {
		xs <- (cp$rx/nr)*xs
		ys <- (cp$ry/nc)*ys
	}
	xsub <- max(1, floor(1+nr/2*(1-1/zoom))) : min(nr, ceiling(nr/2*(1+1/zoom)))
	ysub <- max(1, floor(1+nc/2*(1-1/zoom))) : min(nc, ceiling(nc/2*(1+1/zoom)))
	image(xs[xsub], ys[ysub], (eval(call(fn, X))[xsub,ysub])^(1/gamma),
	  col=col, asp=1, xlab="k_x", ylab="k_y", useRaster=TRUE, ...)
}

pick.sidelobe <- function(imagedata, logm=FALSE, gamma=3) {
	imagedata <- imagedata - mean(imagedata)
	npad <- nextn(max(nrow(imagedata), ncol(imagedata)))
	im <- padmatrix(imagedata, npad=npad, fill=0)
	if (logm) fn <- "logMod2" else fn <- "Mod"
	im.fft <- fftshift(fft(im))
	plot.cmat(im.fft, fn=fn, gamma=gamma)
	cat("Click on the desired sidelobe peak\n")
	peak <- locator(n=1, type="p", col="red")
	cat("Click on background filter size\n")
	edge <- locator(n=1, type="n")
	hw <- round(sqrt((edge$x)^2+(edge$y)^2))
	symbols(0, 0, circles=hw, inches=FALSE, add=TRUE, fg="red")
	return(list(sl=c(round(peak$x), round(peak$y)), filter=hw))
}

## simple utility returns Euclidean length of a vector

hypot <- function(x) sqrt(crossprod(x))

## Zernike moments

zmoments <- function(zcoef, maxorder=14) {
    zcoef <- zcoef[-(1:3)]
    zlist <- makezlist(4, maxorder)
    nz <- length(zlist$n)
    sumstats <- NULL
    i <- 1
    repeat {
        if (i > nz) break
            if (zlist$m[i] == 0) {
                sumstats <- rbind(sumstats, c(zlist$n[i], zlist$m[i], zcoef[i]))
                i <- i+1
            }
            else {
                sumstats <- rbind(sumstats, c(zlist$n[i], zlist$m[i], hypot(zcoef[i:(i+1)])))
                i <- i+2
            }
    }
    sumstats <- data.frame(sumstats)
    names(sumstats) <- c("n", "m", "value")
    return(sumstats)
}

## these two functions provide rudimentary project management. The first adds
## Zernike coefficients and rotation angles from one or more fits to a matrix.
## The second separates polished in from instrumental aberrations (if possible)

addfit <- function(..., th=0, zcm=NULL, theta=numeric(0)) {
    fits <- list(...)
    nt <- length(fits)
    if (length(th)==1 && nt>1) th=rep(th, nt)
    theta <- c(theta, th*pi/180)
    nz <- length(fits[[1]]$zcoef.net)
    for (i in 1:nt) {
        zcm <- cbind(zcm, fits[[i]]$zcoef.net[4:nz])
    }
    list(zcm=zcm, theta=theta)
}

separate.wf <- function(zcm, theta, maxorder=14) {

    nt <- length(theta)
    zlist <- makezlist(4, maxorder)
    nz <- length(zlist$n)
    zcb <- matrix(0, nz, 4)
    sumstats <- NULL
    cx <- c(rep(1,nt),rep(0,nt))
    cy <- c(rep(0,nt),rep(1,nt))
    i <- 1
    repeat {
        if (i > nz) break
        if (zlist$m[i] == 0) {
            zcb[i,1] <- mean(zcm[i,])
            zcb[i,3] <- sd(zcm[i,])/sqrt(nt)
            sumstats <- rbind(sumstats, c(zlist$n[i], zlist$m[i], zcb[i,1],
                                NA, zcb[i, 3], rep(NA, 4)))
            i <- i+1
        } else {
            y <- c(zcm[i,],zcm[i+1,])
            rx <- c(cos(zlist$m[i]*theta),sin(zlist$m[i]*theta))
            ry <- c(-sin(zlist$m[i]*theta),cos(zlist$m[i]*theta))
            lsm <- lm(y ~ -1+rx+ry+cx+cy)
            cc <- coef(summary(lsm))[,1:2]
            zcb[i:(i+1),1] <- cc[1:2,1]
            zcb[i:(i+1),3] <- cc[1:2,2]
            if (nrow(cc)==4) {
                zcb[i:(i+1),2] <- cc[3:4,1]
                zcb[i:(i+1),4] <- cc[3:4,2]
            }
            lsm <- summary(lsm)
            sumstats <- rbind(sumstats,c(zlist$n[i],zlist$m[i],
                                hypot(zcb[i:(i+1),1]), hypot(zcb[i:(i+1),2]),
                                lsm$sigma, lsm$r.squared,lsm$fstatistic))
            i <- i+2
        }
    }
    zcb[is.na(zcb)] <- 0
    colnames(zcb) <- c("zc_mirror", "zc_inst", "se_zc_mirror", "se_zc_inst")
    colnames(sumstats)[1:7] <- c("n","m","rms_mirror", "rms_inst", "sigma","R2", "F")
    wf.mirror <- pupil.arb(zcoef=zcb[,1],zlist=zlist)
    wf.inst <- pupil.arb(zcoef=zcb[,2], zlist=zlist)
    list(zcb=data.frame(zcb),sumstats=data.frame(sumstats),
        wf.mirror=wf.mirror, wf.inst=wf.inst)
}


library(dplyr)
library(readr)
library(tidyr)
library(caret)
library(caTools)
library(caretEnsemble)

data_train <- read.csv('./data/processed/processed_train.csv')
data_test <- read.csv('./data/processed/processed_test.csv')
data_pred <- read.csv('./data/processed/processed_pred.csv')
data_clean <- read.csv('./data/clean/clean_train_predict.csv')

# combining the train data
data <- bind_rows(data_train, data_test)

# splitting the cleaned data
data_clean_missing <- filter(data_clean, predict == 1)
data_clean_nomissing <- filter(data_clean, predict == 0)

# Create custom indices
my_folds <- createMultiFolds(y = data$brand, k = 10, times = 3)

# Create reusable trainControl object: myControl
fitControl <- trainControl(
    summaryFunction = twoClassSummary,
    classProbs = TRUE,
    verboseIter = TRUE,
    savePredictions = 'final',
    index = my_folds
)

target <- 'brand'
predictors <- names(data)[!names(data) %in% target]

fit_c5 <- train(
    data[, predictors],
    data[, target],
    trControl = fitControl,
    method = 'C5.0',
    metric = 'ROC'
)

saveRDS(fit_c5, './models/C5.0_full.rds')


# In this program, we input a number check if the number is positive or negative or zero
num = as.double(readline(prompt="Enter a number: "))
if(num > 0) {
print("Positive number")
} else {
if(num == 0) {
print("Zero")
} else {
print("Negative number")
}
}


#  James Rekow

identifySubgroupsVer1 = function(abdList, rollRange = 0.025){

  #  ARGS: rollRange - the maximum difference in overlap between two DOC points for which the two points
  #                    are still considered close enough that they are included in each others local
  #                    dissimilarity profiles (e.g. in computing rolling mean, etc.)
  #
  #  RETURNS:

  source("subgroupsAbdListCreator.r")
  source("DOCProcedure.r")

  #  default indices of the 2 subgroups created from subgroupsAbdListCreator
  subgroup1Ix = 1:ceiling(M / 2)
  subgroup2Ix = {ceiling(M / 2)+ 1}:M

  #  create abdList with desired number of subgroups
  abdList = subgroupsAbdListCreator(M = M, numSubgroups = numSubgroups, N = N, iStrength = iStrength,
                                    univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                    maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                    interSmplMult = interSmplMult, lambda = lambda,
                                    returnParams = returnParams, conGraph = conGraph)

  #  compute DOC
  doc = DOCProcedure(abdList)

  #  make DOC a data frame (by default a doc is a named list)
  doc = data.frame(over = doc$x, diss = doc$y)

  computeInfoWeight = function(docPoint){

    #  ARGS: docPoint - vector of the form c(over, diss)
    #
    #  RETURNS: localDissMid - midpoint of local dissimilarities (unweighted, not the same as the mean)

    #  extract overlap and dissimilarity of DOC point
    over = docPoint[1]
    diss = docPoint[2]

    #  return 0 if something goes wrong
    if(!is.numeric(over) || !is.numeric(diss)){
      return(0)
    } #  end if

    #  don't count DOC points that have low overlap but 0 dissimilarity, these have 0 diss because they
    #  only share a single species
    if(diss < 0.005){
      if(over < 0.7){
        return(0)
      } #  end if
    } #  end if

    #  identify data frame row indices of DOC points with similar overlap
    similarOver = abs(doc[[1]] - over) < rollRange

    #  create vector of dissimilarities of all DOC points with similar overlap to input docPoint
    localDiss = doc[[2]][similarOver]

    #  compute the midpoint of the local dissimilarities
    localDissMid = 0.5 * {max(localDiss) + min(localDiss)}

    #  compute weighted value whose sign corresponds to whether or not the samples corresponding to the DOC
    #  point are in the same or different subgroups (- same, + different) and whose absolute value
    #  corresponds to how much weight is given to the info from the given DOC point
    infoWeight = diss - localDissMid

    return(infoWeight)

  } #  end computeInfoWeight function

  #  compute info weight for each DOC point in data frame
  infoWeight = apply(doc, 1, computeInfoWeight)

  #  add infoWeight as a column to doc data frame
  doc$infoWeight = infoWeight

  #infoMat = matrix(rep(0, M * M), nrow = M, ncol = M)
  infoMat = matrix(rep(-1, M * M), nrow = M, ncol = M)
  infoMat[lower.tri(infoMat, diag = FALSE)] = infoWeight
  infoMat = t(infoMat)
  infoMat[lower.tri(infoMat, diag = FALSE)] = infoWeight

  kmr = kmeans(x = infoMat, centers = 2, iter.max = 1000, nstart = 100)$cluster

  subgroup1Guess = (1:M)[kmr == kmr[1]]

  return(subgroup1Guess)

} #  end identifySubgroupsTest3 function


sl <- locale("sl", decimal_mark=",", grouping_mark=".")

letnice <- c(2010: 2019)
tipi <- c("Zdraviliške občine","Gorske občine","Obmorske občine","Ljubljana",
        "Mestne občine","Ostale občine")

# Prenocitve po vrstah obcin

prenocitve.vrste.obcin <- function(){
  uvoz <- read_csv2("podatki/Prenocitve_vrste_obcin.csv",
                    locale=locale(encoding="Windows-1250"),
                    col_names=c("Tip", letnice))
  uvoz <- uvoz[-c(1,2),]
  uvoz[, 1] <- tipi
  uvoz <- pivot_longer(uvoz, -Tip, names_to = "Leto", values_to = "Stevilo") %>%
    arrange(Leto)
  uvoz$Leto <- as.numeric(uvoz$Leto)
  uvoz$Stevilo <- as.numeric(uvoz$Stevilo)
  uvoz %>% data.frame()

  return(uvoz)
}

prenocitve.tipi <- prenocitve.vrste.obcin()
prenocitve.tipi.mio <- prenocitve.tipi %>% mutate(Stevilo = Stevilo / 1000000)

# Prihodi po obcinah

obcine <- function(datoteka, leto=2019){
  uvoz <- read_csv2(datoteka, locale=locale(encoding="Windows-1250"),
                              col_names=c("Obcina", "Leto", "Stevilo"))
  uvoz <- uvoz[-c(1,2),]
  uvoz$Leto <- paste(leto)
  uvoz$Stevilo <- parse_number(uvoz$Stevilo)
  uvoz[is.na(uvoz)] <- 0
  uvoz %>% data.frame()
  uvoz$Obcina[100] <- "Mežica"

  return(uvoz)
}

obcine_prihodi_2019 <- obcine("podatki/prihodi_po_obcinah_2019.csv")
obcine_prihodi_2018 <- obcine("podatki/prihodi_po_obcinah_2018.csv", 2018)
obcine_prihodi <- rbind(obcine_prihodi_2018, obcine_prihodi_2019)

# Stevilo vseh gostov

url <- "https://sl.wikipedia.org/wiki/Turizem_v_Sloveniji"

vsi.gosti <- function(){
  gosti <- read_html(url) %>%
    html_nodes(xpath="//table[@class='wikitable plainrowheaders']") %>%
    .[[1]] %>% html_table(fill=TRUE)
  gosti <- gosti[-c(2, 5)]
  gosti <- gosti[-c(5), ]
  colnames(gosti) <- c("Leto", "Tuji", "Domači", "Skupaj")
  gosti <- pivot_longer(gosti, -Leto,
                             names_to = "Tip", values_to = "Stevilo")
  gosti <- gosti[, c("Tip", "Leto", "Stevilo")]
  gosti$Stevilo <- gsub("\\.","", gosti$Stevilo)
  gosti$Stevilo <- as.numeric(gosti$Stevilo)
  gosti$Leto <- as.numeric(gosti$Leto)
  gosti %>% data.frame()
  gosti <- arrange(gosti, Tip)

  return(gosti)
}

vsi.gosti <-vsi.gosti()

# Stevilo vseh prenocitev

vse.prenocitve <- function(){
  prenocitve <- read_html(url) %>%
    html_nodes(xpath="//table[@class='wikitable plainrowheaders']") %>%
    .[[5]] %>% html_table(fill=TRUE)
  prenocitve <- prenocitve[-c(2, 5)]
  prenocitve <- prenocitve[-c(5), ]
  colnames(prenocitve) <- c("Leto", "Tuji", "Domaci", "Skupaj")
  prenocitve <- pivot_longer(prenocitve, -Leto,
                             names_to = "Tip", values_to = "Stevilo")
  prenocitve <- prenocitve[, c("Tip", "Leto", "Stevilo")]
  prenocitve$Stevilo <- gsub("\\.","", prenocitve$Stevilo)
  prenocitve$Stevilo <- as.numeric(prenocitve$Stevilo)
  prenocitve$Leto <- as.numeric(prenocitve$Leto)
  prenocitve <- arrange(prenocitve, Tip)

  return(prenocitve)
}

vse.prenocitve <- vse.prenocitve()

# Kapacitete vrste obcin

kapacitete.vrste.obcin <- function(){
  uvoz <- read_csv2("podatki/kapacitete_vrste_obcin.csv",
                    locale=locale(encoding="Windows-1250"),
                    col_names=c("Tip", letnice))
  uvoz <- uvoz[-c(1,2),]
  uvoz[, 1] <- tipi
  uvoz <- pivot_longer(uvoz, -Tip, names_to = "Leto", values_to = "Stevilo")
  uvoz$Leto <- as.numeric(uvoz$Leto)
  uvoz$Stevilo <- as.numeric(uvoz$Stevilo)
  uvoz %>% data.frame()

  return(uvoz)
}

kapacitete.vrste.obcin <- kapacitete.vrste.obcin()


################################################
## STEP 6. Data integration
#################################################
# Data integration step where batch effect is corrected through data integration methods such as "Seurat V3".
# The data integration step include the normalization and the PCA analysis.

# NEED TO DISCUSS: functio to compute default parameters

############ NEED TO CHECK CONFIG SCHEMA

#   "dataIntegration": {
#       "dataIntegration": {
#           "method": "seuratv4",
#           "methodSettings": {
#               "seuratv4": {
#                   "numGenes": 2000,
#                   "normalisation": "logNormalise"
#               }
#           }
#       },
#       "dimensionalityReduction": {
#           "method": "rpca",  --> NOT USE!
#           "numPCs": 30,
#           "excludeGeneCategories": []
#       }
#   },

dataIntegration <- function(scdata, config) {

    # Check wheter the filter is set to true or false
    if (as.logical(toupper(config$enabled))){
        # So far we only support Seurat V3
        scdata.integrated <- run_dataIntegration(scdata, config)
            # Compute explained variance for the plot2
        eigValues = (scdata.integrated@reductions$pca@stdev)^2  ## EigenValues
        varExplained = eigValues / sum(eigValues)

        # As a short solution, we are going to store an intermediate slot for the numPCs, since this parameter is required when performing
        # the computeEmdedding. The main reason to do not have in the config.configureEmbedding is that this parameter does not change in the configureEmbedding step.
        scdata.integrated@misc[["numPCs"]] <- config$dimensionalityReduction$numPCs
    }

    else
        scdata.integrated <- scdata

    # For now config is not updated, since there is not new changes
    # config <- ...

    # the result object will have to conform to this format: {data, config, plotData : {plot1, plot2}}
    result <- list(
        data = scdata.integrated,
        config = config,
        plotData = list(
            # Plot1 --> embedding plot by UMAP
            plot1 = list(x=scdata.integrated@reductions$umap@cell.embeddings[, 1], y=scdata.integrated@reductions$umap@cell.embeddings[, 1]),
            plot2 = list(proportion_variance_explained = varExplained, nPCs = 1:50)
        )
    )

    return(result)

}

# This function covers
#   - Integrate the data using the variable "type" (in case of data integration method is selected) and normalize using LogNormalize method.
#   - Compute PCA analysis
#   - To visualize the results of the batch effect, an UMAP with default setting has been made.
# Seurat V3 pipeline (see for other methods: https://satijalab.org/seurat/archive/v3.0/integration.html)
run_dataIntegration <- function(scdata, config){

    method <- config$dataIntegration$method
    nfeatures <- config$dataIntegration$methodSettings[[method]]$numGenes
    normalisation <- config$dataIntegration$methodSettings[[method]]$normalisation

    # Q: Should be the numPCs input for the RunPCA? Since we are looking into the explained variance I suggest to RunPCA with 50 and only
    # use this parameter for the data integration purpose.
    numPCs <- config$dimensionalityReduction$numPCs

    #HARDCODE
    # We require just to get an overview of the data-integration
    umap_min_distance <- 0.3
    umap_distance_metric <- "euclidean"

    # temporary to make sure we don't run integration if unisample
    nsamples <- length(unique(scdata$samples))

    # Currently, we only support Seurat V4 pipeline for the multisample integration
    if(nsamples > 1 && method=="seuratv4"){
        data.split <- SplitObject(scdata, split.by = "type")
        for (i in 1:length(data.split)) {
            data.split[[i]] <- NormalizeData(data.split[[i]], normalization.method = normalisation, verbose = F)
            data.split[[i]] <- FindVariableFeatures(data.split[[i]], selection.method = "vst", nfeatures = nfeatures, verbose = FALSE)
        }
        data.anchors <- FindIntegrationAnchors(object.list = data.split, dims = 1:numPCs, verbose = FALSE)
        scdata <- IntegrateData(anchorset = data.anchors, dims = 1:numPCs)
        DefaultAssay(scdata) <- "integrated"
    }else{
        print('Only one sample detected.')
        # Else, we are in unisample experiment and we only need to normalize
        scdata <- Seurat::NormalizeData(scdata, normalization.method = normalisation, verbose = F)
        scdata <-Seurat::FindVariableFeatures(scdata, selection.method = "vst", nfeatures = nfeatures, verbose = F)
    }

    # Scale in order to compute PCA
    scdata <- Seurat::ScaleData(scdata, verbose = F)

    # HARDCODE numPCs to 50
    scdata <- Seurat::RunPCA(scdata, npcs = 50, features = VariableFeatures(object=scdata), verbose=FALSE)

    # Compute embedding with default setting to get an overview of the performance of the bath correction
    scdata <- RunUMAP(scdata, reduction='pca', dims = 1:numPCs, verbose = F, umap.method = "uwot-learn", min.dist = umap_min_distance, metric = umap_distance_metric)

    return(scdata)
}


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Reeder"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Colors
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

# Bar graph of inferred support bins

# We need to name our vector of factors and lables so everything colors properly
myList <- c("springgreen4","darkolivegreen3","gray55","goldenrod1","orange")
names(myList) <- c("Very Strong for Tox","Strong for Tox","Ambiguous","Strong for Sclero","Very Strong for Sclero")
myColors <- c("Very Strong for Tox","Strong for Tox","Ambiguous","Strong for Sclero","Very Strong for Sclero")
names(myColors) <- c("springgreen4","darkolivegreen3","gray55","goldenrod1","orange")

title <- "Loci binned by 2ln(BF) values"
legend_title <- "Interpretation of support"
xlabs <- c("10 and over ", "6 to 10", "6 to -6", "-6 to -10", "-10 and under")
xlablab <- '2ln(BF) values'
ytic <- c(seq(0,40,5))
df <- TvS_BFsupport
xval <- TvS_BFsupport$TvS_support
yval <- TvS_BFsupport$counts

BF_bar <- ggplot(data=df, aes(x=xval,y=yval)) +
  geom_bar(aes(color = xval, fill = xval),
           stat = "identity", position = position_dodge()) +
  theme_classic() +
  theme(plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14),
        legend.title = element_text(size = 12),
        legend.text = element_text(size = 10)) +
  scale_color_manual(values=myList, guide=FALSE) +
  labs(y="Number of Loci",x=xlablab)  +
  scale_y_continuous(breaks = ytic) +
  scale_fill_manual(values=myList,
                    name=legend_title,
                    limits = myColors) +
  scale_x_discrete(labels=xlabs,drop = FALSE) +
  ggtitle(paste(dataset,"\n",title,sep=""))
BF_bar

title.g <- paste("Loci binned by dGLS values", sep='')
legend_title.g <- "Interpretation of support"
xlabs.g <- c("0.5 and over ", "0.1 to 0.5", "0.1 to -0.1", "-0.1 to -0.5", "-0.5 and under")
xlablab.g <- 'dGLS values'
ytic.g <- c(seq(0,45,5))
df.g <- TvS_GLsupport
xval.g <- TvS_GLsupport$TvS_support
yval.g <- TvS_GLsupport$counts

GL_bar <- ggplot(data=df.g, aes(x=xval.g,y=yval.g)) +
  geom_bar(aes(color = xval.g, fill = xval.g),
           stat = "identity", position = position_dodge()) +
  theme_classic() +
  theme(plot.title = element_text(hjust = 0.5, size=16),
        axis.text = element_text(size=10, color="black"),
        text = element_text(size=14),
        legend.title = element_text(size = 12),
        legend.text = element_text(size = 10)) +
  scale_color_manual(values=myList, guide=FALSE) +
  labs(y="Number of Loci",x=xlablab.g)  +
  scale_y_continuous(breaks = ytic.g) +
  scale_fill_manual(values=myList,
                    name=legend_title.g,
                    limits = myColors) +
  scale_x_discrete(labels=xlabs.g,drop = FALSE) +
  ggtitle(title.g)

GL_bar

graph_combined <- ggarrange(BF, GL, ncol=1, nrow=2, legend="bottom", align="v",common.legend = TRUE)
graph_combined
# Write to file
# change axis text to 24 element texts to 30
ggsave(paste(dataset,"_support.pdf",sep=""), plot=graph_combined,width = 6, height = 9.5, units = "in", device = 'pdf',bg = "transparent")


library(data.table)

# assumes data files data/{snow|temperature}_{1,2,3}.csv
variables = c("snow", "temperature")
variable_codes = c("snd_lwe", "tas")
locations = c("snezka", "palava", "komorni_hurka")
data = NULL
for (variable in variables) {
  data_variable = NULL
  for (index in 1:3) {
    data_location = read.csv(paste0("data/", variable, "_", index, ".csv"))
    for (column in c("realization", "lat", "lon")) {
      data_location[[column]] = NULL
    }
    data_location$location = as.factor(locations[index])
    data_location$time = as.Date(data_location$time)
    if (variable == "temperature") {
      data_location$tas = data_location$tas - 273.15
    }
    if (is.null(data_variable)) {
      data_variable = data_location
    } else {
      data_variable = rbind(data_variable, data_location)
    }
  }
  if (is.null(data)) {
    data = data_variable
  } else {
    data = cbind(data, data_variable)
  }
}
data = as.data.table(data)
data = melt(data, id.vars = c("time", "location"), measure.vars = variable_codes)

data_to_plot = data[location == "snezka" & variable == "snd_lwe"]
ggplot(data_to_plot, aes(x = time, y = value)) + geom_line()


# There are some config parameters that depends on the data it-self. In this file we are going to create the functions
# that allow us to compute the best config parameter for Data Processing in the numGenesVsNumUmis step.

numGenesVsNumUmis_config <- function(scdata, config){

    # Sensible values are based on the funciton "gene.vs.molecule.cell.filter" from the pagoda2 package
    p.level <-  min(0.001, 1/ncol(scdata))
    # update config
    config$filterSettings$regressionTypeSettings[[config$filterSettings$regressionType]]$p.level <- p.level

    return(config)
}


#'
#'
#'MIT License

#'Copyright (c) 2016 Julian Gilyard
#'Permission is hereby granted, free of charge, to any person obtaining a copy
#'of this software and associated documentation files (the "Software"), to deal
#'in the Software without restriction, including without limitation the rights
#'to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
#'copies of the Software, and to permit persons to whom the Software is
#'furnished to do so, subject to the following conditions:
#'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.

library(ggplot2); library(caret)
setwd("C:/Users/Julian Gilyard/Documents/London Presentations")
C_Data <- read.csv("TRYZAR_1Y.csv")
N_Val <- -100000000 #amount of Brazlian Real's Invested
L_Time <- 45 # length of window
L_Time_Min <- 30
L_Time_Max <- 60
E_Vector <- C_Data[2]

P_ret <- vector(length = nrow(E_Vector) - L_Time)
iter <- (nrow(E_Vector) - L_Time)

P_ret_Min <- vector(length = nrow(E_Vector) - L_Time_Min)
iter_Min <- (nrow(E_Vector) - L_Time_Min)

P_ret_Max <- vector(length = nrow(E_Vector) - L_Time_Max)
iter_Max <- (nrow(E_Vector) - L_Time_Max)

for (i in 1:iter -1)
{
  t_len <-nrow(E_Vector)
  P_ret[i] <- (E_Vector[t_len - i -L_Time ,] - E_Vector[t_len -i,])
  P_ret[i] <- P_ret[i]/E_Vector[t_len -i -L_Time,] * N_Val
}

for (i in 1:iter_Min -1)
{
  t_len <-nrow(E_Vector)
  P_ret_Min[i] <- (E_Vector[t_len - i -L_Time_Min ,] - E_Vector[t_len -i,])
  P_ret_Min[i] <- P_ret_Min[i]/E_Vector[t_len -i -L_Time_Min,] * N_Val
}

for (i in 1:iter_Max -1)
{
  t_len <-nrow(E_Vector)
  P_ret_Max[i] <- (E_Vector[t_len - i -L_Time_Max ,] - E_Vector[t_len -i,])
  P_ret_Max[i] <- P_ret_Max[i]/E_Vector[t_len -i -L_Time_Max,] * N_Val
}

summary(P_ret)
min_loss_1 <-match(min(P_ret),P_ret)
min_loss_1 <- nrow(E_Vector) - min_loss_1
max_profit_1 <-match(max(P_ret),P_ret)
max_profit_1 <- nrow(E_Vector) - max_profit_1
min(P_ret)
min_loss_1
max(P_ret)
max_profit_1

summary(P_ret_Max)
min_loss_2 <-match(min(P_ret_Max),P_ret_Max)
min_loss_2 <- nrow(E_Vector) - min_loss_2
max_profit_2 <-match(max(P_ret_Max),P_ret_Max)
max_profit_2 <- nrow(E_Vector) - max_profit_2
min(P_ret_Max)
min_loss_2
max(P_ret_Max)
max_profit_2

summary(P_ret_Min)
min_loss_3 <-match(min(P_ret_Min),P_ret_Min)
min_loss_3 <- nrow(E_Vector) - min_loss_3
max_profit_3 <-match(max(P_ret_Min),P_ret_Min)
max_profit_3 <- nrow(E_Vector) - max_profit_3
min(P_ret_Min)
min_loss_3
max(P_ret_Min)
max_profit_3

p <- ggplot(as.data.frame(P_ret), aes(x=P_ret)) +geom_density(fill="cadetblue1") + scale_y_continuous(labels = scales::percent)+ scale_x_continuous(labels = scales::dollar, limits=c(min(P_ret)*3, max(P_ret)*1.5))+ labs(x=" Short TRYZAR Return on Portfolio for 45 Day Long Moving Window", y="Observation Frequency")
p_Min <- ggplot(as.data.frame(P_ret_Min), aes(x=P_ret_Min)) +geom_density(fill="mistyrose1") + scale_y_continuous(labels = scales::percent)+ scale_x_continuous(labels = scales::dollar, limits=c(min(P_ret_Min)*3, max(P_ret_Min)*1.5))+ labs(x=" Short TRYZAR Return on Portfolio for 30 Day Long Moving Window", y="Observation Frequency")
p_Max <- ggplot(as.data.frame(P_ret_Max), aes(x=P_ret_Max)) +geom_density(fill="slategray1") + scale_y_continuous(labels = scales::percent)+ scale_x_continuous(labels = scales::dollar, limits=c(min(P_ret_Max)*3, max(P_ret_Max)*1.5))+ labs(x="Short TRYZAR Return on Portfolio for 60 Day Long Moving Window", y="Observation Frequency")

#ggplot(as.data.frame(P_ret), aes(x=P_ret)) +geom_density() + xlim(min(P_ret)*3, max(P_ret)*1.5)\
p + geom_vline(aes(xintercept=mean(P_ret)),
               color="blue", linetype="dashed", size=1)
p_Min + geom_vline(aes(xintercept=mean(P_ret_Min)),
                   color="red", linetype="dashed", size=1)
p_Max + geom_vline(aes(xintercept=mean(P_ret_Max)),
                   color="black", linetype="dashed", size=1)


#  See the class definitions and constructors with, e.g.
getClass("pixmapIndexed", package=pixmap)
pixmapIndexed

# Image with all one colour
plot(p1 <- pixmapIndexed(matrix(0, nrow=3, ncol=4), col="red"))

# Image with one pixel specified
cols <- rep("blue", 12); cols[7] <- "red"
plot(p2 <- pixmapIndexed(matrix(1:12, nrow=3, ncol=4), col=cols))

# Retrieve colour of a pixel
getcol <- function(pm, i, j)
{
   pmcol <- pm@col
   dim(pmcol) <- dim(pm@index)
   pmcol[i,j]
}
getcol(p2, 3, 4)  #red


runSpace <- function(t, combs = c("3TC",  "AZT",  "NFV"), Rscale = 10,
	    		write = FALSE, dirn = NULL, Ne = Ne, rseed ){

#For each potential virus in N
#multinomially sample from the 8 potential compartments
#    rseed <- sample(1:10000, 1)

    set.seed(rseed)

    ord <- expand.grid(A = c(1, 0), B = c(1, 0), C = c(1, 0))
    or <- ord %>% mutate(geno = paste0(A, B, C)) %>%
        mutate(geno = factor(geno, levels =
                                 c("000",
                                   "100", "010", "001",
                                   "110", "101", "011",
                                   "111" ))) %>%
                                       arrange(geno)

    or <- (or %>% mutate(f = 0) %>%
            mutate(f = ifelse(geno == "000", 0.01,
                       ifelse(geno == "110", 0.03,
                       ifelse(geno == "111", 1, f)))))

    probs <- or$f

    allvals <-  Ne * probs

    sancSize <- allvals[1]

    toTrack <- tbl_df(expand.grid(A = c(1, 0), B = c(1, 0), C = c(1, 0), comp = c("0", "A", "B", "C", "AB", "AC", "BC", "ABC")))
    initNs <- bind_cols( comp = c("0", "A", "B", "C", "AB", "AC", "BC", "ABC"), N = allvals)

    #Compute epsilon values:
    druginf <- return_druginf()

    #These are fitness costs
    mutinf <- return_mutinf()

    druginf <- list(druginf$`3TC`,
                    druginf$`D4T`,
                    druginf$`NFV`,
                    druginf$`LPV`)

#    names(druginf) <- c('3TC', 'D4T', 'NFV')
#    names(druginf) <- c('3TC', 'D4T', 'LPV')
    names(druginf) <- c('3TC', 'D4T', 'NFV', 'LPV')

    druginf[['3TC']] <- c(druginf[['3TC']], csf_ratio = ((0.05 + 1.14)/2)/((4.3 + 8.7)/2) )
    druginf[['D4T']] <- c(druginf[['D4T']], csf_ratio = ((0.2 + 0.36)/2)/((3.3 + 6.4)/2) )
    druginf[['NFV']] <- c(druginf[['NFV']], csf_ratio = ((0 + 0.012)/2)/((5.6 + 8.45)/2) )
    druginf[['LPV']] <- c(druginf[['LPV']], csf_ratio = 0.003) #((16.75))/((67945)) )

    drugEps <- foreach(drug = names(druginf), .combine = "rbind")%do%{

        R_00 <- 1

        di <- druginf[[drug]]

    #This is ugly, but whatever for now
        IC_50 <- di[which(names(di) == "IC_50")]
        hl <- di[which(names(di) == "hl")]
        m <- di[which(names(di) == "slope")]
        C_max <- di[which(names(di) == "c_max")]
        dosing <- di[which(names(di) == "dosing")]
        csf_ratio <- di[which(names(di) == "csf_ratio")]

        mi <- mutinf[[drug]]
        s <- mi[which(names(mi) == "s")]
        mu <- mi[which(names(mi) == "mu")]
        rho <- mi[which(names(mi) == "rho")]
        sigma <- mi[which(names(mi) == "sigma")]

        decay_int <- function(t, hl, C_max){
            -hl * C_max * 2^(-t/hl)/log(2) -  -hl * C_max * 2^(-0/hl)/log(2)
        }

        #Integrate over one dosage period
        av_concentration <- decay_int(24/dosing, hl, C_max)/(24/dosing)

        D <- lseq(10^-3, 10^5, length.out = 18)

        computeRs <- tbl_df( expand.grid( c(0, 1), c(av_concentration, av_concentration * csf_ratio, 0)))
        names(computeRs) <- c("mut", "conc")

        computeRs <- computeRs %>% mutate(comp = c("ABC", "ABC", "AB", "AB", "0", "0" ))

        computeRs %>% mutate( R = (1 - mut * s)/(1 + (conc/(IC_50 * (1 - mut*(1 - rho))))^(m * (1 + mut * (sigma)))), drug = drug)

    }

    comb_match <- tibble(combs)
    names(comb_match) <- "drug"

#Under this entry, let's just have it so that the first thing is A, the second thing is B
#etc...
    ord.drugs <- left_join(comb_match, drugEps, by = "drug")

    eps <- as.numeric(ord.drugs$R)

    A_eps <- (eps[1])
    B_eps <- (eps[2])
    C_eps <- (eps[3])

#Where did I get these computations?
    A_s<- mutinf[[combs[1]]]['s']
    B_s<- mutinf[[combs[2]]]['s']
    C_s<- mutinf[[combs[3]]]['s']
#I need to compute these the same way I do in the time sims

    relMuts <- c(mutinf[[combs[1]]]['mu'],
                 mutinf[[combs[2]]]['mu'],
                 mutinf[[combs[3]]]['mu'])

   #migration and death rates
    death <- 1

    cullNs <- initNs %>% rename(cullN = N)

    toTrack <- toTrack %>% mutate(comp = paste(comp))

    drugInfToMerge <- drugEps %>% filter(is.element(drug, combs)) %>%
                              mutate(drug = ifelse(drug == "3TC", "A",
                              ifelse(drug == "D4T", "B", "C"))) %>%
                                  mutate(R.A = ifelse(drug == "A", R, 1),
                              R.B = ifelse(drug == "B", R, 1),
                              R.C = ifelse(drug == "C", R, 1)) %>%
                                  spread( drug, mut)

   tmp_p <-  left_join(left_join(left_join(left_join(toTrack, initNs),
              drugInfToMerge %>% select(comp, A, R.A), by = c('comp', 'A')),
              drugInfToMerge %>% select(comp, B, R.B), by = c('comp', 'B')),
              drugInfToMerge %>% select(comp, C, R.C), by = c('comp', 'C')) %>%
         mutate(N = ifelse((A == 0 & B == 0 & C == 0 & comp == "0"), N, 0)) %>%
         mutate(R = Rscale * R.A * R.B * R.C) %>%
                  mutate(ind = 1:n()) %>%
                  group_by(comp) %>%
                  mutate(numtype = cur_group_id()) %>% ungroup() %>%
                  mutate(geno = paste0(A, B, C)) %>% group_by(geno) %>%
                  mutate(numgeno = cur_group_id()) %>% ungroup() %>%
                      mutate(R = ifelse(is.na(R), 0, R))

    plasma_inds <- which(tmp_p$comp == "ABC")

#Ok, so, tmp_p tracks each of the 8 genotypes in each of the 8 compartments. Good

    tautot <- 0

    R <- tmp_p$R
    N <- tmp_p$N

    types <- as.matrix(tmp_p %>% dplyr::select(A, B, C,  numtype, numgeno, ind))
    denom <- nrow(tmp_p)

    ordType <- unique(tmp_p$numtype)

   indList <- foreach(i = 1:8)%do%{
       which(types[,'numtype'] == i)
   }

    cullNs <- cullNs %>% group_by(comp) %>%
    	   mutate(numtype = cur_group_id()) %>% ungroup() %>%
#    	   arrange(factor(numtype, levels = ordType))
        arrange(numtype)

   cn.mat <- c(as.matrix(cullNs[,'cullN']))

   initNs <- left_join(tmp_p %>% select(comp, numtype) %>% unique(),
                       initNs, by = "comp") %>%
             arrange(factor(numtype, levels = ordType))

    migPs <- c(initNs$N)/sum(initNs$N)
    migPs[migPs > 0] <- 1/3

    daymarker <- 0

#Our dataframe is
    datSto <- matrix(data = rep(NA, denom * 28*12*10 * 3 + 64 * 3), ncol = 3)

    k <- 1

    newday <- 1

    while(k < t & !stopCondition_space(daymarker, N, plasma_inds, types, newday)){

        newday <- 0

        #These computations need to be done each time, because N is changing
        Rtot <- R*N
        d <- death*N
        mig <- mrate*N

        alphas <- cumsum(c(Rtot, d, mig))
        if(max(alphas) == 0){
            print(N)
        }
        tautot <- tautot + rexp(1, max(alphas))
        alphas <- alphas/max(alphas)

        indToDec <- min(which(runif(1, 0, 1) < alphas)) - 1
#eventType gives us the k
        eventType <- floor(indToDec/denom - .0000000001)
#remainder gives us the i,j
        remainder <- indToDec %% denom + 1 #(eventType > 0)

    #Division
        if(eventType == 0){

            toMut <- runif(3) < relMuts
            if(sum(toMut) > 0){

                toFlip <- types[remainder,]
                indToFlip <- which(toMut > 0) #sample(1:3, 1)
                toFlip[indToFlip] <- 1 - toFlip[indToFlip]

                addInd <- which((types[,1] == toFlip[1] &
                                     (types[,2] == toFlip[2] &
                                      types[,3] == toFlip[3])) &
                                      types[,4] == toFlip[4])

                N[addInd] <- N[addInd] + 1

            }else{

                N[remainder] <- N[remainder] + 1

            }

        #Death
        }else if(eventType == 1){

            N[remainder] <- N[remainder] - 1

    #Migration
        }else if(eventType == 2){

            drawNewComp <- (remainder %% 8 + 8 * sample(0:7 + (remainder == 8), 1, prob = migPs))

            while(drawNewComp == remainder){
                 drawNewComp <- (remainder %% 8 + 8 * sample(0:7 + (remainder == 8), 1, prob = migPs))
            }

            N[remainder] <- N[remainder] -1
            N[drawNewComp] <- N[drawNewComp] + 1

        }

        #Could we make this a faster step by testing the most common culling?
        if(N[8] > sancSize){
            toCull <- 1

        }else{

            psize <- unlist(lapply(indList, function(x){sum(N[x]) }))
            toCull <- which(cn.mat - psize  < 0)

        }

        if(length(toCull) > 0){
            relInds <-  indList[[toCull]]
            N[relInds] <- N[relInds] -  rmultinom(1, 1, N[relInds])

        }

        if(floor(tautot)  >= daymarker){

            daymarker <- daymarker + 1

            newday <- 1

            datSto[((denom * daymarker) + 1):(denom*(daymarker + 1)),] <- cbind(N, daymarker, tautot)

	    if(write == TRUE & daymarker %% 28 == 0 ){

	        print(paste0("Recording Day ",daymarker))
                write.table(cbind(N, k, daymarker), dirn,
                        quote = FALSE, sep = ",",
                        row.names = FALSE, col.names = FALSE, append = TRUE)
                }
        }

        k <- k + 1

    }

    colnames(datSto) <- c("N", "k", "tautot")
    datSto <- tbl_df(datSto)
    runEvs <- datSto %>% filter(!is.na(N))

}

stopCondition_space <- function(daymarker, N, plasma_inds, types, newday){

    if(newday == 1){

    #10 years
        if(daymarker >= (7*4*12*10)){
            return(TRUE)
	}

    #every 3 months
        if(daymarker %% (7*4*3) == 0 & daymarker > 0 ){

            #Note - here I have population size > 200, but I check for the more restrictive
            #150 condition that we report in the main text elsewhere

            if(sum(N[plasma_inds]) >= 200){

                return(TRUE)
            }
            return(FALSE)
        }
    }

    return(FALSE)

}

##############################################
################ Code to run #################
##############################################

ncores <- as.numeric(Sys.getenv('SLURM_CPUS_ON_NODE'))
registerDoParallel(ncores)

dirp <-  "../dat/space_model/"
system(paste0("mkdir ", dirp))

ind <- 1
mrate <-0.1
combs <- c("3TC",  "D4T",  "NFV")
R00 <- 10

stringToPrint <- paste(paste0(combs, collapse = "-"),
                       R00,
                       ind, sep  = "_")

foreach(i = 1:20)%dopar%{

    foreach(iter = 1:75)%do%{

      Ne <- floor(10^rnorm(1, 5.2, .5))
      while(Ne < 10^4 | Ne > 10^6){
          Ne <- floor(10^rnorm(1, 5.2, .5))
      }
      rseed <- sample(1:100000, 1)
      toWrite <-  paste0(dirp, "fast_",stringToPrint, "_m",mrate, "_Ne", Ne, "_seed",rseed,".csv")

      dat<-runSpace(500000000000, combs, Rscale = 10, write = FALSE,
              dirn = toWrite, Ne = Ne, rseed = rseed)

      write.table(dat, toWrite,
                        quote = FALSE, sep = ",",
                        row.names = FALSE, col.names = FALSE, append = TRUE)

  }
}

#This tests the case of a narrower population size distribution
dirp <-  "../dat/space_model_narrow/"
system(paste0("mkdir ", dirp))

stringToPrint <- paste(paste0(combs, collapse = "-"),
                       R00,
                       ind, sep  = "_")

foreach(i = 1:20)%dopar%{
    foreach(iter = 1:75)%do%{

      Ne <- floor(10^rnorm(1, 5.2, .05))
      rseed <- sample(1:100000, 1)

      toWrite <-  paste0(dirp, "fast_",stringToPrint, "_m",mrate, "_Ne", Ne, "_seed",rseed,".csv")

      dat<-runSpace(500000000000, combs, Rscale = 10, write = FALSE,
              dirn = toWrite, Ne = Ne, rseed = rseed)

      write.table(dat, toWrite,
                        quote = FALSE, sep = ",",
                        row.names = FALSE, col.names = FALSE, append = TRUE)

  }
}


# A function that takes a DNAseq and generates mutations
# The goal is to get a set of sequences to check the ability of
# classifying algorithms to detect variants either generated by PCR
# or naturally occuring variants that had not been sequenced yet

# When we downloaded the genbak data, we used the ape format (from insect)
# The function should allow for either that format or the
# character string from seqinr

mutation <- function(sequence = NULL, format = "bin", n.mutations = NA, prob.mutation = NA){

  require(tidyverse)
  require(insect)

  lapply(sequence[1], unique)[[1]] -> options.for.mutations

  if (is.na(n.mutations) & is.na(prob.mutation)| !is.na(n.mutations) & !is.na(prob.mutation)){
    return(print("Error: please enter one and only one of these: a number of mutations, or the probability of mutation"))
  }

  if (format == "bin"){

    lapply(sequence, length) -> l.input

    # in case we want a fixed number of mutations

    if (!is.na(n.mutations)){

     # select the spots to be mutated

    spots <- map(l.input, ~ sample(1:.x, n.mutations, replace = F))

     # replace the value

    output <- map2(sequence, spots, function(.x,.y) {
        .x[.y] <- map_raw(.x[.y],  function(.z) {
        options.for.mutations [!options.for.mutations %in% .z] %>%
          sample(1)
      } )

    return(.x)
      })
   class(output) <- "DNAbin"
      return(output)

     }

  }
}


## Step 2 Get predictor data for aoi ####

### Prepares predictors (crops, masks) and puts all into stack for SDM

sourceProtection

setwd("")
dir()

library(sf)
options(sf_max.plot=1)
library(raster)

# sirgas for BR
sirgas <- "+proj=poly +lat_0=0 +lon_0=-54 +x_0=5000000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
wgs <- "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0" # as in arcgis

# set temp path for raster somewhere where it won't be deleted after cluster clozses
# rasterOptions()
# rast_tmp <- "C:/CD_C/raster_tmp"
# rasterOptions(tmpdir = rast_tmp)
# rasterOptions()
# can wipe this after session

## Get occurrecne and aoi data
load("gis/occ_aoi.rdata")
rm(bl.sirgas)

# make rough wgs extent to crop with
# get wgs extended to crop
r <- raster(msk.aoi)
wgs.aoi <- extent(projectExtent(extend(r, 10), wgs))
wgs.aoi
rm(r)

### Get new predictors and old with proper extent

## 1 World clim ####
getwd()
plot(msk.aoi)
# writeRaster(msk.aoi, filename = "gis/r_sirg/msk_aoi.tif", datatype = "INT1U", overwrite = T)
#

getwd()
# get files
dir("../../GIS_info/Clim/wrldclm")
wc.fn <- list.files("../../GIS_info/Clim/wrldclm", pattern = "\\.tif$", full.names = T)

wc.stck <- stack(wc.fn)
proj4string(wc.stck)

# crop
wc.stck <- crop(wc.stck, y = wgs.aoi)
wc.stck
#plot(wc.stck)

beginCluster()
wc.sir <- projectRaster(wc.stck, to = msk.aoi, method = "bilinear")
endCluster()

names(wc.sir)
names(wc.sir) <- gsub(" ", "0", sprintf("bio%02s", 1:19))

wc.sir$bio01
plot(wc.sir$bio01)

## mask to projected aoi
wc.sir <- mask(wc.sir, msk.aoi) #
plot(wc.sir$bio01)

wc.sir$bio01

plot(wc.sir[[1:10]])
plot(wc.sir[[11:19]])

# check in memory
sapply(1:nlayers(wc.sir), function(x) inMemory(wc.sir[[x]]))

# # readinto memory
# wc.sir <- readAll(wc.sir)
wc.sir

# clean up
rm(wc.stck)
## SAVE as single file...
writeRaster(wc.sir, filename = "gis/r_sir/wc.tif", bylayer = F)
wc.names <- names(wc.sir)

### 2. DHI #####
## Do same with DHI layers
## see https://www.sciencedirect.com/science/article/pii/S0034425718305625

## Downloaded from http://silvis.forest.wisc.edu/data/dhis/

dir("../../GIS_Info/cover/DHI", pattern = "\\.tif$")
dhi.fn <- list.files("../../GIS_Info/cover/DHI", pattern = "f\\.tif$", full.names = T)
# just combined layers 2003-2014
dhi.fn

# can't stack them all as they have different extents... (for some reason...)
dhi.rList <- lapply(dhi.fn, stack) # use stack as these are multilayer rasters
dhi.rList

dhi.crp.rList <- lapply(dhi.rList, crop, y = wgs.aoi)

beginCluster()
dhi.sirg <- lapply(dhi.crp.rList, projectRaster, to = msk.aoi, method = "bilinear")
endCluster()

dhi.sirg.crp <- lapply(dhi.sirg, crop, y = msk.aoi)
dhi.sirg.msk <- lapply(dhi.sirg.crp, mask, mask = msk.aoi)
dhi.sir <- stack(dhi.sirg.msk)

dhi.sir
names(dhi.sir)
names(dhi.sir) <- unlist(lapply(c("evi", "gpp", "lai", "ndvi"), paste, c("cum", "min", "sea"), sep ="_"))
plot(dhi.sir)

sapply(1:nlayers(dhi.sir), function(x) inMemory(dhi.sir[[x]]))

writeRaster(dhi.sir, filename = "gis/r_sir/dhi.tif", bylayer = F)
dhi.names <- names(dhi.sir)

#clean
rm(dhi.sirg, dhi.crp.rList, dhi.fn, dhi.rList, dhi.sirg.crp, dhi.sirg.msk)

### 3. SRTM #####

# get raster SRTM data
cty <- c("PRY", "BRA", "ARG")
srtm <- list()

for(i in seq_along(cty)){

  tmp <- raster::getData("alt", country = cty[i], path = "gis/wgs", level = 1)
  srtm[[i]] <- tmp
  rm(tmp)
}

rm(cty, i)

srtm
lapply(srtm, plot)

plot(msk.aoi)
plot(st_geometry(cty0.sir), add = T)

# project each country
beginCluster()
srtm.sir <- lapply(srtm, projectRaster, to = msk.aoi, method = "bilinear")
endCluster()

lapply(srtm.sir, plot)

## merge (make sure NAs are not taken in first layer)
# add arguments
# OK - overlap is TRUE by default
srtm.mos <- do.call(merge, srtm.sir)

dem.sir <- crop(srtm.mos, msk.aoi)
dem.sir <- mask(dem.sir, msk.aoi)

plot(dem.sir, asp = 1)
plot(st_geometry(cty0.sir), add = T, col = NA)

terr.sir <- terrain(dem.sir, opt = c("slope", "aspect", "TPI", "TRI", "roughness"), units = "degrees")

terr.sir <- addLayer(terr.sir, dem.sir)
names(terr.sir)
names(terr.sir)[6] <- "dem"

terr.sir[[1]] # in memory

names(pred)
terr.sir <- dropLayer(pred, 7:37)

writeRaster(terr.sir, filename = "gis/r_sir/terr.tif", bylayer = F)
terr.names <- names(terr.sir)

# save all.
rm(srtm.mos, srtm, srtm.sir, dem.sir)

## 4. Create stack of all predictors ####

## Line them all up...
compareRaster(terr.sir, dhi.sir, wc.sir, orig = T)

predStack <- stack(terr.sir, dhi.sir, wc.sir)
predStack

# save as single file
writeRaster(predStack, filename = "gis/r_sir/predStack.tif", bylayer = F, overwrite = T)
pred.names <- names(predStack)
pred.names
save(pred.names, wc.names, dhi.names, terr.names, file = "gis/r_sir/predNames.rdata")