require(ncdf4)

###########
## Read in warming (all calculations)
##########

# read in monthly warming rcp26
infile <- nc_open('data/cmip5/d20161206_1632_19653.nc') # deltas for each month, 2081-2100 minus 1986-2005
	lstwarm26 <- ncvar_get(infile, 'diff') # lst warming  x  x 12 (last is months)
	dim(lstwarm26)
	dimnames(lstwarm26) <- list(lon=1:144, lat=1:72, mo3=1:12)
	dimnames(lstwarm26)[[1]] <- infile$var[['diff']]$dim[[1]]$vals # add lon
	dimnames(lstwarm26)[[2]] <- infile$var[['diff']]$dim[[2]]$vals # add lat
	nc_close(infile)
	lstwarm26 <- lstwarm26[,dim(lstwarm26)[2]:1,]

infile <- nc_open('data/cmip5/d20161206_1630_11885.nc') # deltas for each month, 2081-2100 minus 1986-2005
	sstwarm26 <- ncvar_get(infile, 'diff') # sst warming 288 x 144 x 12 (last is months)
	dim(sstwarm26)
	dimnames(sstwarm26) <- list(lon=1:288, lat=1:144, mo3=1:12) # dummy dimnames for lat and lon
	dimnames(sstwarm26)[[1]] <- infile$var[['diff']]$dim[[1]]$vals # add lon
	dimnames(sstwarm26)[[2]] <- infile$var[['diff']]$dim[[2]]$vals # add lat
	nc_close(infile)
	sstwarm26 <- sstwarm26[,dim(sstwarm26)[2]:1,] # rearrange

# read in monthly warming rcp85
infile <- nc_open('data/cmip5/d20161127_1456_12434.nc') # deltas for each month, 2081-2100 minus 1986-2005
	lstwarm85 <- ncvar_get(infile, 'diff') # lst warming  x  x 12 (last is months)
	dim(lstwarm85)
	dimnames(lstwarm85) <- list(lon=1:144, lat=1:72, mo3=1:12)
	dimnames(lstwarm85)[[1]] <- infile$var[['diff']]$dim[[1]]$vals # add lon
	dimnames(lstwarm85)[[2]] <- infile$var[['diff']]$dim[[2]]$vals # add lat
	nc_close(infile)
	lstwarm85 <- lstwarm85[,dim(lstwarm85)[2]:1,]

infile <- nc_open('data/cmip5/d20161127_1011_30742.nc') # deltas for each month, 2081-2100 minus 1986-2005
	sstwarm85 <- ncvar_get(infile, 'diff') # sst warming 288 x 144 x 12 (last is months)
	dim(sstwarm85)
	dimnames(sstwarm85) <- list(lon=1:288, lat=1:144, mo3=1:12) # dummy dimnames for lat and lon
	dimnames(sstwarm85)[[1]] <- infile$var[['diff']]$dim[[1]]$vals # add lon
	dimnames(sstwarm85)[[2]] <- infile$var[['diff']]$dim[[2]]$vals # add lat
	nc_close(infile)
	sstwarm85 <- sstwarm85[,dim(sstwarm85)[2]:1,] # rearrange

################
## For annual mean
################

# read in climatologies for annual mean
load('temp/lstclimatology.rdata') # lstclim
load('temp/sstclimatology.rdata') # sstclim

# calculate warming
	lstwarm26ann <- t(apply(lstwarm26, MARGIN=c(1,2), FUN=mean, na.rm=TRUE))
	lstwarm85ann <- t(apply(lstwarm85, MARGIN=c(1,2), FUN=mean, na.rm=TRUE))
	sstwarm26ann <- t(apply(sstwarm26, MARGIN=c(1,2), FUN=mean, na.rm=TRUE))
	sstwarm85ann <- t(apply(sstwarm85, MARGIN=c(1,2), FUN=mean, na.rm=TRUE))

# interpolate warming to 0.5x0.5
	# create new grid
	ngrd <- expand.grid(lat=as.numeric(rownames(lstclim)), lon=as.numeric(colnames(lstclim)))
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	rast <- raster(lstwarm26ann, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		lstwarm26ann05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

			# par(mfrow=c(1,2))
			# image(lstwarm26ann)
			# image(lstwarm26ann05)

	rast <- raster(lstwarm85ann, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		lstwarm85ann05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- raster(sstwarm26ann, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm26ann05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- raster(sstwarm85ann, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm85ann05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

# calculate future temperatures
	dim(lstclim)
	dim(lstwarm26ann05) # match: good

	par(mfrow=c(1,2)) # make sure they are aligned
	image(lstclim)
	image(lstwarm26ann05)

	lstfut26ann <- lstclim + lstwarm26ann05
	sstfut26ann <- sstclim + sstwarm26ann05

	lstfut85ann <- lstclim + lstwarm85ann05
	sstfut85ann <- sstclim + sstwarm85ann05

# plot the present temperature maps
	par(mfrow=c(2,1))
	image(t(lstclimn)[,nrow(lstclimn):1])
	image(t(sstclimn)[,nrow(sstclimn):1])

# plot the future temperature maps
	par(mfrow=c(2,1))
	image(t(lstfut85ann)[,nrow(lstfut85ann):1])
	image(t(sstfut85ann)[,nrow(sstfut85ann):1])

# write out
save(lstfut26ann, file='temp/lstfut26ann.rdata')
save(sstfut26ann, file='temp/sstfut26ann.rdata')
save(lstfut85ann, file='temp/lstfut85ann.rdata')
save(sstfut85ann, file='temp/sstfut85ann.rdata')

#####################
## For mean summer
#####################

# read in climatologies for summer mean
load('temp/lstclimatology_warm3.rdata') # lstclimwarm3
load('temp/sstclimatology_warm3.rdata') # sstclimwarm3

# calculate warming
	# lst
	lstwarm26sumN <- apply(lstwarm26[,,6:8], MARGIN=c(1,2), FUN=mean) # delta for northern hemisphere summer
	lstwarm26sumS <- apply(lstwarm26[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # delta for southern hemisphere summer
	lstwarm26sum <- t(cbind(lstwarm26sumN[,as.character(seq(88.75,1.25,by=-2.5))], lstwarm26sumS[,as.character(seq(-1.25,-88.75,by=-2.5))]))

	lstwarm85sumN <- apply(lstwarm85[,,6:8], MARGIN=c(1,2), FUN=mean) # delta for northern hemisphere summer
	lstwarm85sumS <- apply(lstwarm85[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # delta for southern hemisphere summer
	lstwarm85sum <- t(cbind(lstwarm85sumN[,as.character(seq(88.75,1.25,by=-2.5))], lstwarm85sumS[,as.character(seq(-1.25,-88.75,by=-2.5))]))

	# sst
	sstwarm26sumN <- apply(sstwarm26[,,6:8], MARGIN=c(1,2), FUN=mean) # delta for northern hemisphere summer
	sstwarm26sumS <- apply(sstwarm26[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # delta for southern hemisphere summer
	sstwarm26sum <- t(cbind(sstwarm26sumN[,as.character(seq(89.375,0.625,by=-1.25))], sstwarm26sumS[,as.character(seq(-0.625,-89.375,by=-1.25))]))

	sstwarm85sumN <- apply(sstwarm85[,,6:8], MARGIN=c(1,2), FUN=mean) # delta for northern hemisphere summer
	sstwarm85sumS <- apply(sstwarm85[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # delta for southern hemisphere summer
	sstwarm85sum <- t(cbind(sstwarm85sumN[,as.character(seq(89.375,0.625,by=-1.25))], sstwarm85sumS[,as.character(seq(-0.625,-89.375,by=-1.25))]))

	# clean up
	rm(sstwarm26sumN, sstwarm26sumS, lstwarm26sumN, lstwarm26sumS, sstwarm85sumN, sstwarm85sumS, lstwarm85sumN, lstwarm85sumS)

# interpolate warming to 0.5x0.5
	# create new grid
	ngrd <- expand.grid(lat=as.numeric(rownames(lstclimwarm3)), lon=as.numeric(colnames(lstclimwarm3)))
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	rast <- raster(lstwarm26sum, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		lstwarm26sum05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

			# par(mfrow=c(1,2))
			# image(lstwarm26ann)
			# image(lstwarm26ann05)

	rast <- raster(lstwarm85sum, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		lstwarm85sum05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- raster(sstwarm26sum, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm26sum05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- raster(sstwarm85sum, xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm85sum05 <- as.matrix(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

# calculate future temperatures
	dim(lstclimwarm3)
	dim(lstwarm26sum05)

	par(mfrow=c(1,2)) # make sure they are aligned
	image(lstclimwarm3)
	image(lstwarm26sum05)

	lstfut26sum <- lstclimwarm3 + lstwarm26sum05 # for summer mean
	sstfut26sum <- sstclimwarm3 + sstwarm26sum05

	lstfut85sum <- lstclimwarm3 + lstwarm85sum05 # for summer mean
	sstfut85sum <- sstclimwarm3 + sstwarm85sum05

# plot the present temperature maps
	par(mfrow=c(2,1))
	image(t(lstclimwarm3)[,nrow(lstclimwarm3):1])
	image(t(sstclimwarm3)[,nrow(sstclimwarm3):1])

# plot the future temperature maps
	par(mfrow=c(2,1))
	image(t(lstfut85sum)[,nrow(lstfut85sum):1], main='rcp85')
	image(t(sstfut85sum)[,nrow(sstfut85sum):1], main='rcp85')

# write out
save(lstfut26sum, file='temp/lstfut26sum.rdata')
save(sstfut26sum, file='temp/sstfut26sum.rdata')
save(lstfut85sum, file='temp/lstfut85sum.rdata')
save(sstfut85sum, file='temp/sstfut85sum.rdata')

#####################
## For warmest month
#####################

# read in climatologies for all months
load('temp/sstclimatology_bymonth.rdata') # sstclimbymo
load('temp/lstclimatology_bymonth.rdata') # lstclimbymo

# interpolate warming for each month to 0.5x0.5
	# create new grid
	ngrd <- expand.grid(lat=as.numeric(rownames(lstclim)), lon=as.numeric(colnames(lstclim)))
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	# interpolate: raster query approach with points
	# have to exchange axes for lstwarm26
	rast <- brick(aperm(lstwarm26, c(2,1,3)), xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		rast2 <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss))
		lstwarm26.05 <- as.array(rast2)

			# par(mfrow=c(1,2))
			# image(lstwarm26[,,1])
			# image(lstwarm26.05[,,1]) # should be rotated

	rast <- brick(aperm(lstwarm85, c(2,1,3)), xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		lstwarm85.05 <- as.array(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- brick(aperm(sstwarm26, c(2,1,3)), xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm26.05 <- as.array(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

	rast <- brick(aperm(sstwarm85, c(2,1,3)), xmn=1.25, xmx=358.75, ymn=-88.75, ymx=88.75, crs='+proj=longlat +datum=WGS84') # make a raster object
		newvalss <- extract(rast, ngrd.sp, method='bilinear')
		sstwarm85.05 <- as.array(rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss)))

# check alignment
	dim(lstclimbymo)
	dim(sstclimbymo)
	dim(lstwarm26.05)
	dim(lstwarm85.05)
	dim(sstwarm26.05)
	dim(sstwarm85.05)

	par(mfrow=c(1,2)) # check for alignment
	image(lstclimbymo[,,2])
	image(lstwarm26.05[,,2])

	par(mfrow=c(1,2)) # check for alignment
	image(lstclimbymo[,,2])
	image(lstwarm85.05[,,2])

	par(mfrow=c(1,2)) # check for alignment
	image(sstclimbymo[,,2])
	image(sstwarm26.05[,,2])

	par(mfrow=c(1,2)) # check for alignment
	image(sstclimbymo[,,2])
	image(sstwarm85.05[,,2])

# calculate future temperatures for each month
	lstfut26bymo <- lstclimbymo + lstwarm26.05
	sstfut26bymo <- sstclimbymo + sstwarm26.05

	lstfut85bymo <- lstclimbymo + lstwarm85.05
	sstfut85bymo <- sstclimbymo + sstwarm85.05

# plot the present and future temperature maps
	# January
	zliml = range(c(lstclimbymon[,,1], lstfut85bymo[,,1]), na.rm=TRUE)
	zlimo = range(c(sstclimbymon[,,1], sstfut85bymo[,,1]), na.rm=TRUE)
	par(mfrow=c(3,2))
	image(lstclimbymo[,,1], zlim=zliml)
	image(sstclimbymo[,,1], zlim=zlimo)
	image(lstwarm85.05[,,1])
	image(sstwarm85.05[,,1])
	image(lstfut85bymo[,,1], main='rcp85 jan', zlim=zliml)
	image(sstfut85bymo[,,1], main='rcp85 jan', zlim=zlimo)

	# July
	zliml = range(c(lstclimbymo[,,7], lstfut85bymo[,,7]), na.rm=TRUE)
	zlimo = range(c(sstclimbymo[,,7], sstfut85bymo[,,7]), na.rm=TRUE)
	par(mfrow=c(3,2))
	image(lstclimbymo[,,7], zlim=zliml)
	image(sstclimbymo[,,7], zlim=zlimo)
	image(lstwarm85.05[,,7])
	image(sstwarm85.05[,,7])
	image(lstfut85bymo[,,7], main='rcp85 jul', zlim=zliml)
	image(sstfut85bymo[,,7], main='rcp85 jul', zlim=zlimo)

# calculate the warmest month
lstfut26warmestmo <- apply(lstfut26bymo, MARGIN=c(1,2), FUN=max)
sstfut26warmestmo <- apply(sstfut26bymo, MARGIN=c(1,2), FUN=max)
lstfut85warmestmo <- apply(lstfut85bymo, MARGIN=c(1,2), FUN=max)
sstfut85warmestmo <- apply(sstfut85bymo, MARGIN=c(1,2), FUN=max)

# plot the future temperature maps
	par(mfrow=c(2,1))
	image(t(lstfut85warmestmo)[,nrow(lstfut85warmestmo):1], main='rcp85')
	image(t(sstfut85warmestmo)[,nrow(sstfut85warmestmo):1], main='rcp85')

# write out
save(lstfut26warmestmo, file='temp/lstfut26warmestmo.rdata')
save(sstfut26warmestmo, file='temp/sstfut26warmestmo.rdata')
save(lstfut85warmestmo, file='temp/lstfut85warmestmo.rdata')
save(sstfut85warmestmo, file='temp/sstfut85warmestmo.rdata')


require(tidyverse)
require(foreach)
require(cowplot)
require(RColorBrewer)
require(seqinr)
library(ape)

source('initial_processing.r')
source('call_mutations.r')

source('determine_first_mutation.r')
source('process_kaplan_meier_curves.r')
source('CalculatingTargetSize_MutRate.R')
source('test_first_mutation.r')
source('plot_figure_2.r')


## Setup R error handling to go to stderr
options(show.error.messages = F,
        error = function() {
            cat(geterrmessage(), file = stderr())
            q("no", 1, F)
        }
)
warnings()

library(RColorBrewer)
library(lattice)
library(latticeExtra)
library(grid)
library(gridExtra)
library(optparse)

option_list <- list(
    make_option("--h_dataframe", type = "character",
                help = "path to h-signature dataframe"),
    make_option("--z_dataframe", type = "character",
                help = "path to z-signature dataframe"),
    make_option("--plot_method", type = "character",
                help = "How  data should be plotted (global or lattice)"),
    make_option("--pdf", type = "character", help = "path to the pdf file with plots"),
    make_option("--title", type = "character", help = "Graph Title")
    )
parser <- OptionParser(usage = "%prog [options] file", option_list = option_list)
args <- parse_args(parser)

# data frames implementation
h_dataframe <- read.delim(args$h_dataframe, header = F)
colnames(h_dataframe) <- c("chrom", "overlap", "sig", "z-score")
h_dataframe$sig <- h_dataframe$sig * 100  # to get probs in %
z_dataframe <- read.delim(args$z_dataframe, header = F)
colnames(z_dataframe) <- c("chrom", "overlap", "sig", "z-score")

# functions
    globalgraph <- function() {
        pdf(args$pdf)
        par(mfrow = c(2, 2), oma = c(0, 0, 3, 0))
        plot(z_dataframe[z_dataframe$chrom == "all_chromosomes", c(2, 3)],
             type = "h", main = "Numbers of pairs", cex.main = 1, xlab = "overlap (nt)",
             ylab = "Numbers of pairs", col = "darkslateblue", lwd = 4)

        plot(z_dataframe[z_dataframe$chrom == "all_chromosomes", c(2, 4)],
             type = "l", main = "Number of pairs Z-scores", cex.main = 1, xlab = "overlap (nt)",
             ylab = "z-score", pch = 19, cex = 0.2, col = "darkslateblue", lwd = 2)

        plot(h_dataframe[h_dataframe$chrom == "all_chromosomes", c(2, 3)],
             type = "l", main = "Overlap probabilities", cex.main = 1,
             xlab = "overlap (nt)",
             ylab = "Probability [%]", ylim = c(0, 50), pch = 19,
             col = "darkslateblue", lwd = 2)

        plot(h_dataframe[h_dataframe$chrom == "all_chromosomes", c(2, 4)],
             type = "l", main = "Overlap Probability Z-scores", cex.main = 1,
             xlab = "overlap (nt)", ylab = "z-score", pch = 19, cex = 0.2,
             col = "darkslateblue", lwd = 2)
        mtext(args$title, outer = TRUE, cex = 1)
        dev.off()
    }

    treillisgraph <- function(df, ...) {
          pdf(args$pdf, paper = "special", height = 11.69, width = 6)
          p <- xyplot(sig ~ overlap | factor(method, levels = unique(method)) + chrom,
                   data = df,
                   type = "l",
                   col = "darkblue",
                   cex = 0.5,
                   scales = list(y = list(tick.number = 4, relation = "free", cex = 0.6,
                                          rot = 0),
                                 x = list(cex = 0.6, alternating = FALSE)),
                   xlab = "Overlap",
                   ylab = "signature (Nbr of pairs / Overlap prob.)",
                   main = args$title,
                   par.strip.text = list(cex = .5),
                   pch = 19, lwd = 2,
                   as.table = TRUE,
                   layout = c(2, 12),
                   newpage = T,
                   ...)
           plot(p)
           dev.off()
    }

# main

if (args$plot_method == "global") {
    globalgraph()
}

if (args$plot_method == "lattice") {
    # rearrange dataframes
    h_sig <- h_dataframe[, c(1, 2, 3)]
    h_sig <- cbind(rep("Overlap Prob (%)", length(h_sig[, 1])), h_sig)
    colnames(h_sig) <- c("method", "chrom", "overlap", "sig")
    z_pairs <- z_dataframe[, c(1, 2, 3)]
    z_pairs <- cbind(rep("Nbr of pairs", length(z_pairs[, 1])), z_pairs)
    colnames(z_pairs) <- c("method", "chrom", "overlap", "sig")
    lattice_df <- rbind(z_pairs, h_sig)
    par_settings_treillis <- list(strip.background = list(
            col = c("lightblue", "lightgreen")))
    treillisgraph(lattice_df, par.settings = par_settings_treillis)
}


#RevHelper Model

#loading the library
library(randomForest)
library(caTools)
library(e1071)
library(caret)

#load the model data
data=read.table(file="path/to/modeldata-training-and-testing.txt", header=TRUE)
#show a summary if needed
#summary(data)

#replacing the NA values
cleandata=na.omit(data)
summary(cleandata)

#initialize the performance measures
sumAcc=0
sumPosPrec=0
sumPosRec=0
sumNegPrec=0
sumNegRec=0
sumImp=0

for(i in 200:209){

#setting seed points to ensure different randomization in each run
set.seed(i)

#shuffling the data
sdata=cleandata[sample(nrow(cleandata), nrow(cleandata)), ]

#divide the dataset into training and test set
n=nrow(sdata)
trainIndex = sample(1:n, size = round(0.65*n), replace=FALSE)
train=sdata[trainIndex,]
test=sdata[-trainIndex,]

#summary of train and test data if needed.
#summary(train)
#summary(test)

#developing the RevHelper-RF fit
fit <- randomForest(as.factor(className) ~

                    #all features considered
                    #.,

                    #textual features only
                    #  ReadingEase+ReadingEase.NL. +StopwordRatio+StopKeyRatio+
                    #  QuestionRatio+ CodeElementRatio+ConceptualSimilarity

                    #developer experience based features only
                    #AuthorCommitsFile+ CommittedTwice + TotalAuthoredCommits+ ReviewingTwice +ReviewedCommitsFile +	TotalReviewedCommits
                    #+ ReviewedPRs +ExtLibSimilarity

                    #optimal set of features
                    ConceptualSimilarity
                    +
                    ReviewedCommitsFile + AuthorCommitsFile +ExtLibSimilarity +
                    TotalReviewedCommits+ ReviewedPRs+StopwordRatio,

                    data=train,
                    importance=TRUE,
                    ntree=2000)

imp=importance(fit)
sumImp =sumImp + imp

#prediction model
Prediction <- predict(fit, test)

#calculate accuracy
cm=confusionMatrix(data=Prediction,
                   reference=test$class,
                   positive='u')

#show the confusion metrics if needed.
#print(cm)

#accumulating performance data from each run
sumAcc = sumAcc+  cm$overall['Accuracy']
sumPosPrec=sumPosPrec+ cm$byClass['Pos Pred Value']
sumPosRec=sumPosRec + cm$byClass['Sensitivity']
sumNegPrec=sumNegPrec + cm$byClass['Neg Pred Value']
sumNegRec=sumNegRec + cm$byClass['Specificity']

#showing performance from each run
print(c(cm$byClass['Pos Pred Value'],cm$byClass['Sensitivity'],cm$byClass['Neg Pred Value'],cm$byClass['Specificity'],cm$overall['Accuracy']) )

}

#showing average performance for 10 runs
print(sumPosPrec/10)
print(sumPosRec/10)
print(sumNegPrec/10)
print(sumNegRec/10)
print(sumAcc/10)

#showing average feature importance
myImp=sumImp/10
print(myImp)


library(dplyr)
library(RColorBrewer)
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,
		   req = cumsum(tasks_requested)/time) %>%
	summarize(norm = last(thp/req))
data = data.frame(data)
data$app_id = factor(
					 data$app_id,
					 levels = c(3, 4, 5, 1, 2),
					 labels = c("iPerf", "Air Quality", "Roof", "Traffic", "Parking"))
data$alpha = factor(data$alpha, levels = c(100, 1, 0, -1), labels = c("Mobius\n(Max-Min)", "Mobius\n(Prop. Fair)", "Max\nThroughput", "Dedicated\nDrones"))
data = subset(data, app_id != -1)

colors = brewer.pal(n = 5, name = 'Dark2')
colors = c(colors[3], colors[4], colors[5], colors[1], colors[2])

p = ggplot(data, aes(x = alpha, y = 100 * norm, fill = app_id)) +
	geom_col(position = "dodge", color = "black") +
	scale_fill_manual(values = colors) +

	# formatting
	theme(
		  legend.position = "top", legend.box = "vertical", legend.margin = margin(),
		  legend.box.margin=margin(-4,-4,-7,-7),
		  legend.text = element_text(size = 10),
		  axis.title.x = element_blank()
	) +
	ylim(c(0, NA)) +
	ylab("Tasks\nCompleted (%)") +
	labs(fill = "", shape = "")
ggsave(args[2], p, width = 5, height = 1.5, units = 'in')


# Processes the family age file and a family species richness file to merge them into one table.
# The species richness estimates per family and subfamily were obtained from the Angiosperm Phylogeny Website.
# The code plots mean family ages against species richness.
# Continues with R objects generated in previous steps.
# Uses additional files.
richness_file <- "SPP.RICHNESS.csv" #### File in data folder

resB<-read.table(paste(ruta_write,"2.Ages_complete.csv",sep=""),sep=",",header=T)
rich<-read.table(richness_file,heade=T,sep=",")
rich_ord<-rich[which(rich$Family==""),]
resB$Order_richness<-rich_ord[match(resB$Order,rich_ord$Order),"Spp_richness"]
rich_fams<-rich[which(rich$Subfamily==""),]
rich_fams<-rich_fams[which(rich_fams$Family!=""),]
resB$Family_richness<-rich_fams[match(resB$Family,rich_fams$Family),"Spp_richness"]
rich_subfams<-rich[which(rich$Subfamily!=""),]
resB$Subfamily_richness<-rich_subfams[match(resB$Subfamily,rich_subfams$Subfamily),"Spp_richness"]
### Families with suspect crown nodes
non<-which(rownames(resB) %in% c( "Aphloiaceae","Brunelliaceae","Cynomoriaceae",
                                  "Daphniphyllaceae", "Mayacaceae",
                                  "Mitrastemonaceae","Oncothecaceae"))
resB[non,"CG_age_Acal"]<-NA; resB[non,"CG_minHPD"]<-NA; resB[non,"CG_maxHPD"]<-NA
resB$Total_Richness <- rep(NA,dim(resB)[1])
for (i in 1:dim(resB)[1]){
  if(!is.na(resB$Subfamily_richness[i])){resB$Total_Richness[i] <- resB$Subfamily_richness[i];next}
  if(!is.na(resB$Family_richness[i])){resB$Total_Richness[i] <- resB$Family_richness[i];next}
  resB$Total_Richness[i] <- resB$Order_richness[i]}
out.group <- which(resB$Order%in%c("Pinales","Gnetales","Ginkgoales","Cycadales"))
resB <- resB[-out.group,]
orders <- 1:64
fams <- 65:500
subfams <- 501:dim(resB)[1]
resB$Fuse <- resB$SG_age_Acal - resB$CG_age_Acal
resB_fams <- resB[fams,]

sum(resB[fams,"Total_Richness"],na.rm = T)
par(mfrow = c(1, 1), pty = "s")
pdf(paste(ruta_write,"1.Temporal_distirbution_ages.pdf",sep=""))
ages <- resB_fams[which(!is.na(resB_fams[,c("CG_age_Acal")])),c("CG_age_Acal","SG_age_Acal")]
ages <- ages[order((ages$SG_age_Acal-ages$CG_age_Acal)),]
plot(ages$CG_age_Acal,cex=0.3,pch=19,ylim=c(0,150),type="n",xaxt="n",xlab="Families ranked by fuse period",
     ylab="Million years")
for (i in 1:length(ages$CG_age_Acal)){
  segments(x0 = i,x1 = i, y0 = 0, y1= ages$SG_age_Acal[i]-ages$CG_age_Acal[i],
           col=adjustcolor("black",alpha.f = 0.7),lwd=2)
}
title("Fuse period (stem to crown age)")
abline(h=mean(ages$SG_age_Acal-ages$CG_age_Acal),col="red",lwd=3,lty=3)
cat(mean(ages$SG_age_Acal-ages$CG_age_Acal),"\n")
hist(ages$SG_age_Acal-ages$CG_age_Acal,xlim=c(0,220),xlab="Fuse period (stem to crown age)",ylab="No. of families",main="",breaks=c(seq(0,220,10)))
ages[which(ages$SG_age_Acal-ages$CG_age_Acal > 120),]
ages[which(ages$SG_age_Acal-ages$CG_age_Acal < 10),]

full_SG <- c()
for (i in 1:nrow(resB_fams)){
  cat(i,"\r")
  if(is.na(resB_fams$SG_age_Acal[i])) next
  full_SG <- c(full_SG,seq(round(resB_fams$SG_maxHPD[i],1),round(resB_fams$SG_minHPD[i],0.5)))
}
cat("DONE ------")
full_CG <- c()
for (i in 1:nrow(resB_fams)){
  cat(i,"\r")
  if(is.na(resB_fams$CG_age_Acal[i])) next
  full_CG <- c(full_CG,seq(round(resB_fams$CG_maxHPD[i],1),round(resB_fams$CG_minHPD[i],0.5)))
}
cat("DONE ------")

hist(na.omit(resB_fams$SG_age_Acal),breaks=seq(0,250,10),freq=F,ylim=c(0,0.018),border="red",col=NULL,main="Family ages (95HPD)",xlab="million years ago")
hist(na.omit(resB_fams$CG_age_Acal),breaks=seq(0,250,10),freq=F,add=T,border="blue",col=NULL)
lines(density(full_SG,bw=5),col="red")
lines(density(full_CG,bw=5),col="blue")
dev.off()

periods <- data.frame("Stem (number)"=rep(NA,4),"Stem (percent)"=rep(NA,4),"Crown (number)"=rep(NA,4),"Crown (percent)"=rep(NA,4),
        row.names = c("Cenozoic","Cretaceous","Jurassic","Prior to first fossil"))
periods[1,3] <- length(which(resB_fams$CG_age_Acal < 66))
periods[1,4] <- round((length(which(resB_fams$CG_age_Acal < 66)) / length(which(!is.na(resB_fams$CG_age_Acal)))) * 100,1)
periods[2,3] <- length(which(resB_fams$CG_age_Acal >= 66 & resB_fams$CG_age_Acal < 145))
periods[2,4] <- round((length(which(resB_fams$CG_age_Acal >= 66 & resB_fams$CG_age_Acal < 145)) / length(which(!is.na(resB_fams$CG_age_Acal)))) * 100,1)
periods[3,3] <- length(which(resB_fams$CG_age_Acal >= 145))
periods[3,4] <- round((length(which(resB_fams$CG_age_Acal >= 145)) / length(which(!is.na(resB_fams$CG_age_Acal)))) * 100,1)
periods[4,3] <- length(which(resB_fams$CG_age_Acal >= 136))
periods[4,4] <- round((length(which(resB_fams$CG_age_Acal >= 136)) / length(which(!is.na(resB_fams$CG_age_Acal)))) * 100,1)
periods[1,1] <- length(which(resB_fams$SG_age_Acal < 66))
periods[1,2] <- round((length(which(resB_fams$SG_age_Acal < 66)) / length(which(!is.na(resB_fams$SG_age_Acal)))) * 100,1)
periods[2,1] <- length(which(resB_fams$SG_age_Acal >= 66 & resB_fams$SG_age_Acal < 145))
periods[2,2] <- round((length(which(resB_fams$SG_age_Acal >= 66 & resB_fams$SG_age_Acal < 145)) / length(which(!is.na(resB_fams$SG_age_Acal)))) * 100,1)
periods[3,1] <- length(which(resB_fams$SG_age_Acal >= 145))
periods[3,2] <- round((length(which(resB_fams$SG_age_Acal >= 145)) / length(which(!is.na(resB_fams$SG_age_Acal)))) * 100,1)
periods[4,1] <- length(which(resB_fams$SG_age_Acal >= 136))
periods[4,2] <- round((length(which(resB_fams$SG_age_Acal >= 136)) / length(which(!is.na(resB_fams$SG_age_Acal)))) * 100,1)
sink(paste(ruta_write,"3.Numbers_by_period.txt",sep=""))
periods
sink()

pdf(paste(ruta_write,"6.ARCs.pdf",sep=""),useDingbats = F)
par(mfrow = c(1, 1), pty = "s")
Data<-data.frame(Order=1:dim(resB_fams)[1],z=log(resB_fams$Total_Richness))
Data<-Data[order(Data$z),]
k=20
breaks <- getJenksBreaks(Data$z,k)
cols_breaks <- (colorRampPalette(c("yellow","gold","tomato2","red4"))(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
plot(resB_fams$Fuse,log(resB_fams$Total_Richness),pch=21,cex=log(resB_fams$Total_Richness)*0.5,xlab="Fuse period (My)"
     ,ylab="Species Richness (log)",bg=orderedcolors)
abline(lm(log(resB_fams$Total_Richness)~resB_fams$Fuse),lwd=3,lty=3,col="black")
summ_lm <- summary(lm(log(resB_fams$Total_Richness)~resB_fams$Fuse))
legend("bottomright",inset=0.03,legend=paste("b = ",round(summ_lm$coefficients[2,1],2),";","F = ",round(summ_lm$fstatistic[1],2),";",
                                             "p-val = ",round(summ_lm$coefficients[2,4],2),";","R2* = ",round(summ_lm$adj.r.squared,3),sep=""))
dev.off()


library(ggplot2)
library(scales)
library(ggpubr)
library(bayesplot)
library(matrixStats)
library(cowplot)
library(svglite)
args <- commandArgs(trailingOnly = TRUE)
filename <- args[1]

load(paste0("results/", filename))

alpha = data.frame(as.matrix(out$alpha))
plot_labels <- c("School Closure",
                 "Self Isolation",
                 "Public Events",
                 "First Intervention",
                 "Lockdown", 'Social distancing')
colnames(alpha) = plot_labels
first.intervention = alpha[,c(1,2,3,5,6)] + alpha[,4]
data1 = mcmc_intervals_data(first.intervention,prob=.95,transformation=function(x) 1-exp(-x),point_est="mean")
data1$type = "First Intervention"

data2 = mcmc_intervals_data(alpha[,c(1,2,3,5,6)],  prob = .95,transformation=function(x) 1-exp(-x),point_est="mean")
data2$type = "Later Intervention"
# data = rbind(rbind(data2[6,],data1),data2[1:5,])
data = rbind(data1,data2[1:5,])
colQuantiles(data.matrix(first.intervention),probs=c(.025,.975))

#data$type[1] = "First Intervention"

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

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

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

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

data$parameter = factor(as.character(data$parameter),levels=plot_labels[order(plot_labels)[6:1]])
# data = data[order(-data$m),]
p = ggplot(data) +theme_pubr() +  geom_point(aes(x=m,y=parameter,colour=type),position = position_dodge(-.5)) +
  geom_linerange(aes(xmin=ll,xmax=hh,y=parameter,colour=type),
                 position = position_dodge(-.5)) +
  scale_x_continuous(breaks=seq(0,1,.25),labels = c("0%\n(no effect on transmissibility)",
                                                    "25%","50%","75%","100%\n(ends transmissibility)"),
                     expand=c(0.005,0.005),expression(paste("Relative % reduction in  ",R[t])))  +
  scale_colour_manual(name = "", #labels = c("50%", "95%"),
                      values = c(("coral4"), ("seagreen"))) +

  geom_vline(xintercept=1,colour="darkgray") +
  scale_y_discrete("Governmental intervention\n") +
  #geom_vline(xintercept=0,colour="darkgray") +
  theme(plot.margin = margin(0, 2, 0, .5, "cm"))
#+ guides(fill=guide_legend(nrow=2))
p
ggsave(filename = "results/covars-alpha-reduction.png",
       p,height=4,width=8)
dir.create("web/figures/desktop/", showWarnings = FALSE, recursive = TRUE)
dir.create("web/figures/mobile/", showWarnings = FALSE, recursive = TRUE)
save_plot(filename = paste0("web/figures/desktop/",  "covars-alpha-reduction.svg"),
          p, base_height = 4, base_asp = 1.618 * 2 * 8/12)
save_plot(filename = paste0("web/figures/mobile/", "covars-alpha-reduction.svg"),
          p, base_height = 4, base_asp = 1.1)


#' fits_index
#'
#' Calculate Fighter Index of Thermal Stress FITS.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @param wind numeric Windspeed in meters per second.
#' @param pair numeric Air pressure in hPa.
#' @return fits index
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references Nunneley SH, Stribley F, 1979, Fighter index of thermal stress FITS  guidance for hot-weather aircraft operations.Aviat Space Environ Med 50, 639 42.
#' @export
#'

fits_index=function(t,rh,wind=0.2,pair=1010) {

                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$assign("pair", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=fits_index(t[i],rh[i],wind[0],pair[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


'
The file "analysis.r" firstly checks whether the manipulations manipulate altruistic motivation vs. obeying social norm motivation in our experiment.
Secondly, this file computes the interactive effect of consumers gift-giving motivations and their perception of whether indulgence is moral or immoral on consumers self-indulgence.
Finally, we test the mediating role of happiness in the relatonship between gift-giving motivations and self-indulgence.

'

rm(list=ls())
options(digits=3)

source("project_paths.r")
library(foreign, lib=PATH_OUT_LIBRARY_R)
library(mediation, lib=PATH_OUT_LIBRARY_R)
library(sandwich, lib=PATH_OUT_LIBRARY_R)

delete_outlier <- read.table(
     file=paste(PATH_OUT_DATA, "delete_outlier.txt", sep = "/"),
     header = TRUE
)

sink(paste(PATH_OUT_ANALYSIS,"analysis_results.txt",sep="/"))
####################MANIPULATION CHECK############################
#####CHECK THE MANIPULATION OF ALTRUISTIC MOTIVATION#####
altruism_check<-aov(altruism_ave~Condition,data=delete_outlier)
summary(altruism_check)
print(model.tables(altruism_check,"means"),digits=3)

#####CHECK THE MANIPULATION OF SOCIAL NORM MOTIVATION#####
sn_check<-aov(sn_ave~Condition,data=delete_outlier)
summary(sn_check)
print(model.tables(sn_check,"means"),digits=3)

#################REGRESSION##################
center_appropriateness<-delete_outlier$appropriateness-mean(delete_outlier$appropriateness)
delete_outlier<-data.frame(delete_outlier,center_appropriateness)
#####CHECK THE INTERACTION EFFECT OF GIFT-GIVING MOTIVATION AND PERCEPTION OF MORALITY ON SELF-INDULGENCE#####
inter_effect<-lm(brand_ave~Altruism*center_appropriateness,data=delete_outlier)
summary(inter_effect)
inter_effect$coefficients
#####CHECK THE INFLUENCE OF PERCEPTION OF MORALITY ON SELF-INDULGENCE FOR PARTICIPANTS WITH AN ALTRUISTIC MOTIVATION#####
delete_outlier_al<-delete_outlier[delete_outlier$Condition==1,]
rate_al<-lm(brand_ave~center_appropriateness,data=delete_outlier_al)
summary(rate_al)
rate_al$coefficients
#####CHECK THE INFLUENCE OF PERCEPTION OF MORALILTY ON SELF-INDULGENCE FOR PARTICIPANTS WITH A SOCIAL NORM MOTIVATION#####
delete_outlier_sn<-delete_outlier[delete_outlier$Condition==3,]
rate_sn<-lm(brand_ave~center_appropriateness,data=delete_outlier_sn)
summary(rate_sn)

#########MEDIATION, CHECK WHETHER HAPPINESS IS THE POTETIAL MEDIATOR#############
model.m<-lm(happiness~Altruism,data=delete_outlier)
model.y<-lm(brand_ave~Altruism+happiness,data=delete_outlier)
m<-mediate(model.m,model.y,sims=10000,treat="Altruism",mediator="happiness")
summary(m)
sink()


#' Perform SVA confounder analysis
#'
#' Perform SVA confounder analysis and association tests between the Surrogate
#' Variables of the given input values and the phenotype data.
#'
#' This function performs a series of association tests between the Surrogate
#' Variables of the input values and the provided phenotype data.
#'
#' If a RGChannelSet is given, it can also compute the association with the
#' control probes. This implementation uses Linear models.
#'
#' @param values A matrix containing the data to analyze. Rows represent
#'   variables and columns samples.
#' @param pdata A data.frame containing the phenotype information for the
#'   samples.
#' @param main_formula A formula describing the main model of interest.
#' @param null_formula A formula describing the null model of interest.
#' @param vfilter The number of most variable rows to use in order to
#'   estimate the number of surrogate variables.
#' @param rgset If not NULL, compute association with control probes data
#'   contained in the provided RGChannelSet.
#' @return A list containing the number of Surrogate Variables (num_sv), the
#'   results of the confounding analysis tests (significance), and the Surrogate
#'   Variables obtained by SVA (surrogates).
#' @importFrom sva num.sv sva
#' @export
sva_analysis = function(values, pdata, main_formula, null_formula = NULL,
                        vfilter = NULL, rgset = NULL) {

  if (!is.null(vfilter)) {
    vfilter = min(vfilter, nrow(values))
  }

  mod = model.matrix(main_formula, data = pdata)
  mod0 = NULL

  if (!is.null(null_formula)) {
    mod0 = model.matrix(null_formula, data = pdata)
  }

  num_sv = num.sv(values, mod = mod, vfilter = vfilter)

  if (num_sv == 0) {
    stop(paste(
      'Number of estimated surrogate variables is zero.',
      'Check model and/or dataset.'
    ))
  }

  svs = sva(values, mod = mod, mod0 = mod0, n.sv = num_sv)

  sv_names = paste0('SV-', 1:(svs[['n.sv']]))
  sv_names = factor(sv_names, levels = sv_names)

  if (num_sv == 1) {
    message(
      paste('If there is only a surrogate variable, the output from sva()',
            'is not ok, as it does not use the drop=FALSE parameter.',
            'Converting the surrogate variable back to a matrix.')
    )
    svs[['sv']] = matrix(svs[['sv']], ncol = 1)
  }

  significance_data = compute_significance_data(svs[['sv']], pdata, sv_names)

  sig_data_rgset = NULL

  if (!is.null(rgset)) {
    data_control_values = get_control_variables(rgset)
    var_names = colnames(data_control_values)
    names(var_names) = var_names
    sig_data_rgset = compute_significance_data_var_names(
      svs[['sv']],
      data_control_values,
      sv_names,
      var_names
    )
    significance_data = rbind(significance_data, sig_data_rgset)

    significance_data[['Variable']] = factor(
      significance_data[['Variable']],
      levels = unique(significance_data[['Variable']])
    )
  }

  colnames(svs[['sv']]) = gsub('-', '_', sv_names)

  result = list(
    num_sv = num_sv,
    mod0 = mod0,
    mod = mod,
    significance = significance_data,
    significance_control = sig_data_rgset,
    surrogates = svs[['sv']]
  )

  class(result) = append(class(result), 'SVAAnalysis')
  return(result)
}


library(a5udes)
library(dplyr)
library(sf)
library(tidygraph)
library(ggraph)
library(igraph)
library(progress)
library(furrr)

CE=osmdata::getbb(place_name='Ceará', format_out = "sf_polygon") %>% slice(1)

res_geom=allocate_reservoir_to_river(river_geometry)
reservoir_geometry=build_reservoir_topology(res_geom)
save(reservoir_geometry,file='data/reservoir_geometry.RData')reservoir_tidygraph

reservoir_graph = reservoir_geometry %>%
  st_set_geometry(NULL) %>%
  dplyr::select(id_jrc,res_down) %>%
  filter(res_down>0) %>%
  rename(to=id_jrc,from=res_down) %>%
  as_tbl_graph
save(reservoir_graph,file='data/reservoir_graph.RData')

# reservoir_tidygraph %>% morph(to_local_neighborhood,2,order=1) %>%
#   crystallise %>% .$graph %>% .[[1]] %>%
#   ggraph(.)+geom_node_label(aes(label=name))+geom_edge_bend0()
#
# reservoir_tidygraph %>% activate(nodes) %>% as_tibble %>% nrow

#
# res_geom_df=reservoir_geometry %>%
#   st_set_geometry(NULL) %>%
#   dplyr::select(id_jrc,area_max,SUB_AREA,`distance to river`,`nearest river`,`UP_CELLS`) %>%
#   mutate(name=as.character(id_jrc))
#
# res_tidy=reservoir_tidygraph %>%
#   left_join(res_geom_df)
#
# ## not a tree! forest!! need to loop over trees first
#
#
#
# g=res_tidy %>%
#   mutate(rank=map_dfs_back_int(node_is_root(),unreachable=TRUE,.f=function(node,rank,...) {
#     return(rank)
#   }))
#
# g
#
#
# neigh = g %>% activate(nodes) %>%
#   arrange(desc(rank)) %>%
#   mutate(neighborhood =   local_members(order = 1,mode='out',mindist=1)) %>%
#   as_tibble
#
# neigh %>% head
#
# contrib=vector(mode='list',length=nrow(neigh))
#
# # for(i in seq(1,nrow(neigh))) {
#
#   if(neigh$`distance to river`[i]>0){
#     contrib[[i]]=neigh$area_max[i]*0.3664
#   } else {
#     riv_l=filter(river_geometry,ARCID==neigh$`nearest river`[i])
#
#
#   }
#
#
#   # }
# riv_l=res_geom[1,] %>% pull()
# res_geom[1,]


library(ggplot2)

ha <- read.table("all_lines_family_stats_6-30_ha_over2pc.tsv",comment.char="",header=F,sep="\t")
names(ha) <- c("ID","Line","Oil","Superfamily","Family","PA")

## superfamily summary
ggplot(ha1, aes(x=reorder(ID, PA, sum), y=PA, fill=Superfamily)) +
	    geom_bar(stat="summary", fun.y=sum,color="black") +
	    theme_bw() +
	    theme(axis.text.x=element_blank(),
	    axis.ticks.x=element_blank(),
	    axis.title.x=element_text(size=16),
	    axis.title.y=element_text(size=16),
	    axis.text.y=element_text(size=14)) +
	    ylab("Genome abundance [%]") +
	    xlab("Line")

## family summary
ggplot(ha1, aes(x=reorder(ID, PA, sum), y=PA, fill=Family)) +
	    geom_bar(stat="identity",color="black") +
	    theme_bw() +
	    theme(axis.text.x=element_blank(),
	    axis.ticks.x=element_blank(),
	    axis.title.x=element_text(size=16),
	    axis.title.y=element_text(size=16),
	    axis.text.y=element_text(size=14)) +
	    ylab("Genome abundance [%]") +
	    xlab("Line")


library(tidyverse)

lut_zms <- read_csv("../datos/util/zonas_metropolitanas_2015.csv")
zm_pobs <- lut_zms %>%
  group_by(CVE_ZM) %>%
  summarise(pob = sum(POB_2015),
            NOM_ZM = unique(NOM_ZM)) %>%
  ungroup()
zm_pobs

selected_zms <- lut_zms %>%
  filter(CVE_ZM != "09.01") %>%
  group_by(CVE_ZM, CVE_ENT) %>%
  summarise(pob = sum(POB_2015),
            NOM_ENT = unique(NOM_ENT),
            CVE_ENT = unique(CVE_ENT),
            NOM_ZM = unique(NOM_ZM),
            CVE_ZM = unique(CVE_ZM)) %>%
  ungroup() %>%
  split(.$CVE_ZM) %>%
  map_dfr(function(d){
    d %>%
      mutate(pob_prop = pob / sum(pob)) %>%
      arrange(desc(pob)) %>%
      head(1)
  }) %>%
  select(-pob) %>%
  left_join(zm_pobs, by = c("CVE_ZM", "NOM_ZM")) %>%
  # print(n = 100) %>%
  split(.$CVE_ENT) %>%
  map_dfr(function(d){
    d %>%
      arrange(desc(pob)) %>%
      head(1)
  }) %>%
  # print(n = 100) %>%
  bind_rows(tibble(CVE_ZM = "09.01",
                   CVE_ENT = "09",
                   NOM_ENT = "Ciudad de México",
                   NOM_ZM = "Valle de México")) %>%
  select(-pob_prop, -pob) %>%
  print(n = 100)

lut_zms %>%
  select(CVE_ZM, NOM_ZM, CVE_MUN, NOM_MUN) %>%
  inner_join(selected_zms, by = c("CVE_ZM", "NOM_ZM")) %>%
  write_csv("selected_zms.csv")


##### PLOT HEATMAP OF TWEETS GATHERED #######

library(ggplot2)
library(maps)
library(fiftystater)
library(maps)

## Read the dataset collected and stored from reverse.r
data <- read.csv("../data_collected/statesFrequency")
data<- subset(data, select = -c(X)) #removing column named X
setwd("../Scripts")
alpha = sort(table(data), decreasing = TRUE)
data("fifty_states")

checker <- data.frame(state.name)
colnames(checker) <- c("state")
rownames <- rownames(alpha)
rownames(alpha) <- NULL
alpha <- data.frame(cbind(rownames,alpha))
colnames(alpha) <- c("state", "count")

pointer = 1
## Code to filter and keep only the 50 - us states(48 continental + Hawaii + Alaska)
## Discards all non-us locations
for (i in 1:nrow(alpha))
{
  for (j in 1:nrow(checker))
  {
    if (as.character(alpha$state[i])==as.character(checker$state[j]))
    {
      if (pointer == 1)
      {
        temp = alpha[i,]
        pointer = 2
        next

      }
      if (pointer == 2)
      {
        temp = rbind(temp,alpha[i,])
      }
    }
  }
}

## Plotting HEATMAP
temp$count<-as.numeric(levels(temp$count))[temp$count]
temp$state <- unlist(as.list(tolower(temp$state)))

p <- ggplot(temp, aes(map_id = state)) +
  geom_map(aes(fill = count), map = fifty_states, color = "black") +
  expand_limits(x = fifty_states$long, y = fifty_states$lat) +
  coord_map() +
  scale_fill_gradient2(low="green", mid="yellow", high="red3", midpoint = mean(temp$count), guides(fill = "Number of Tweets"), limits=c(0,max(temp$count)+100), breaks=c(0,50,100,150,200,250,300,350,400,450,500,550,600,650,700,750,800,850,900,950,1000)) +
  guides(fill = guide_colorbar(barwidth = 1.5, barheight = 25)) +
  scale_x_continuous(breaks = NULL) +
  scale_y_continuous(breaks = NULL) +
  labs(x = "", y = "") +
  ggtitle("2017-18 Influenza Season Week 4 ending Jan 27, 2018") +
  theme(legend.position = "right",
        plot.title = element_text(family = "Helvetica Neue", color="#666666", face="bold", size=12, hjust=0))

print(p + ggtitle("HeatMap of Tweets on Influenza in USA"))

# add border boxes to AK/HI
p + fifty_states_inset_boxes()


# These features are motivated by faron's idea.
# Road-2-0.4+
# https://www.kaggle.com/mmueller/bosch-production-line-performance/road-2-0-4/code

#------------------------------
# library
#------------------------------

library(data.table)
library(magrittr)
library(dtplyr)
library(dplyr)

#------------------------------
# main
#------------------------------

data_dir <- file.path("..", "..", "dataset")
input_dir <- file.path("..", "..", "input")

tic <- proc.time()

# load data --------------------

train_numeric_pach <- file.path(data_dir, "train_numeric.csv")
train_id <- fread(train_numeric_pach, data.table=FALSE, select="Id") %>% use_series(Id)

test_numeric_path <- file.path(data_dir, "test_numeric.csv")
test_id <- fread(test_numeric_path, data.table=FALSE, select="Id") %>% use_series(Id)

train_date_path <- file.path(input_dir, "train_date_features.csv")
train_date <- fread(train_date_path, data.table=FALSE, select=c("Id", "date_min"))

test_date_path <- file.path(input_dir, "test_date_features.csv")
test_date <- fread(test_date_path, data.table=FALSE, select=c("Id", "date_min"))

# joint data --------------------

joint_date <- rbind(train_date, test_date)

joint_id <- data.frame("Id" = c(train_id, test_id))
joint_id <- left_join(joint_id, joint_date, by="Id")

# generate faron features --------------------

joint_id$faron_feature_01 <- c(1, diff(joint_id$Id))
joint_id$faron_feature_02 <- c(rev(diff(rev(joint_id$Id))), -1)

joint_id <- joint_id %>% arrange(date_min, Id)

joint_id$faron_feature_03 <- c(1, diff(joint_id$Id))
joint_id$faron_feature_04 <- c(rev(diff(rev(joint_id$Id))), -1)

joint_id$date_min <- NULL

# save result --------------------

train <- data.frame("Id"=train_id) %>% left_join(joint_id, by="Id")
write.table(train, file.path(input_dir, "train_id_features.csv"), row.names=FALSE, quote=FALSE, sep=",")

test <- data.frame("Id"=test_id) %>% left_join(joint_id, by="Id")
write.table(test, file.path(input_dir, "test_id_features.csv"), row.names=FALSE, quote=FALSE, sep=",")

train$faron_feature_02[nrow(train)] <- -1
test$faron_feature_01[1] <- 1

# display computational time --------------------

cat("==> Display computational time\n")
calc <- proc.time() - tic
print(calc)


'
Создать несколько векторов разных типов и длины и написать
с ними три формулы с использованием логических операций.
Объяснить полученный результат, добавив в скрипт комментарии
'

vector1 <- c("string1", "string2", "string3")
vector2 <- c(1,26,4,4,76,43)
vector3 <- c(TRUE, FALSE, TRUE)
vector4 <- c(3i, 53.4i, 4i)

result1 <- vector2 & vector3
result1 <- vector2 && vector3
result3 <- vector2 | vector4
result4 <- vector3 || vector4

#Будет ошибка
result2 <- vector1 & vector2


not_all_na <- function(x) any(!is.na(x))

uvozi.hdi.csv <- function(tabela, stolpci, skip, max) {
  uvoz <- read_csv(tabela,
                    locale = locale(encoding="utf-8"),
                    col_names = stolpci,
                    skip = skip,
                    n_max = max,
                    na = c("", " ", "-", ".."))
  uvoz <- uvoz %>% select_if(not_all_na) %>%
    select(-"HDI Rank (2018)") %>%
    pivot_longer(!Drzava, names_to="Leto", values_to="Stevilo")

  uvoz$Leto <- as.numeric(uvoz$Leto)
  uvoz <- uvoz %>% filter(uvoz$Leto >= 1998)

  uvoz$Drzava <- str_replace(uvoz$Drzava, " *\\(.*?\\) *", "")
  return(uvoz)
}

## 1. tabela (HDI)
st.hdi <- c("HDI Rank (2018)", "Drzava", 1990:2018)
HDI_drzave_leta <- uvozi.hdi.csv("podatki/HDI_countries_years.csv", st.hdi, 2, 195)

# Funkcija za uvoz csv (Indeksi za leto 2018)
uvozi.csv <- function(tabela, stolpci, skip, max) {
  uvoz <- read_csv(tabela,
                   locale = locale(encoding="utf-8"),
                   col_names = stolpci,
                   skip = skip,
                   n_max = max,
                   na = c("", " ", "-", ".."))
  uvoz <- uvoz %>% select_if(not_all_na) %>%
    select(-"HDI Rank (2018)") %>%
    pivot_longer(!Drzava, names_to="Leto", values_to="Indeks")

  uvoz$Leto <- as.numeric(uvoz$Leto)
  uvoz <- uvoz %>%
    filter(uvoz$Leto == 2018) %>%
    select(-"Leto")

  uvoz$Drzava <- str_replace(uvoz$Drzava, " *\\(.*?\\) *", "")
  return(uvoz)
}

## 2. tabela (Education Index)
st.ei <- c("HDI Rank (2018)","Drzava","1990","","1991","","1992","","1993","","1994","","1995","","1996","","1997","","1998","","1999","","2000","","2001","","2002","","2003","","2004","","2005","","2006","","2007","","2008","","2009","","2010","","2011","","2012","","2013","","2014","","2015","","2016","","2017","","2018","")
izobrazba <- uvozi.csv("podatki/education_index.csv", st.ei, 2, 189) %>%
  rename("Indeks_izobrazbe" = "Indeks")

## 3. tabela (Life Expectancy Index)
st.lei <- c("HDI Rank (2018)","Drzava","1990","","1991","","1992","","1993","","1994","","1995","","1996","","1997","","1998","","1999","","2000","","2001","","2002","","2003","","2004","","2005","","2006","","2007","","2008","","2009","","2010","","2011","","2012","","2013","","2014","","2015","","2016","","2017","","2018","")
zivljenje <- uvozi.csv("podatki/life_expectancy_index.csv", st.lei, 2, 189) %>%
  rename("Indeks_zivljenja" = "Indeks")

## 4. tabela (Income Index)
st.ii <- c("HDI Rank (2018)","Drzava","1990","","1991","","1992","","1993","","1994","","1995","","1996","","1997","","1998","","1999","","2000","","2001","","2002","","2003","","2004","","2005","","2006","","2007","","2008","","2009","","2010","","2011","","2012","","2013","","2014","","2015","","2016","","2017","","2018","")
prihodek <- uvozi.csv("podatki/income_index.csv", st.ii, 2, 191) %>%
  rename("Indeks_prihodka" = "Indeks")

## 5. tabela (Coefficient of human inequality)
st.ineq <- c("HDI Rank (2018)","Drzava","2010","","2011","","2012","","2013","","2014","","2015","","2016","","2017","","2018","")
neenakost <- uvozi.csv("podatki/coefficient_of_human_inequality.csv", st.ineq, 2, 189) %>%
  rename("Koeficient" = "Indeks")

### nov stolpec - Indeks neenakosti
neenakost$"Indeks_neenakosti" <- round(1 - ((neenakost$Koeficient - min(neenakost$Koeficient, na.rm = TRUE))/(max(neenakost$Koeficient, na.rm = TRUE) - min(neenakost$Koeficient, na.rm = TRUE))), digits = 3)

neenakost[neenakost$Drzava == "Comoros",]$Indeks_neenakosti <- 0.01

# Funkcija za uvoz datoteke 'co2 emissions'
uvozi.co2.csv <- function(tabela, stolpci, skip, max) {
  uvoz <- read_csv(tabela,
                   locale = locale(encoding="utf-8"),
                   col_names = stolpci,
                   skip = skip,
                   n_max = max,
                   na = c("", " ", "-", ".."))
  uvoz <- uvoz %>% select(-"Code")

  uvoz$Leto <- as.numeric(uvoz$Leto)
  uvoz <- uvoz %>%
    filter(uvoz$Leto == 2018) %>%
    select(-"Leto")
  return(uvoz)
}

## 6. tabela (CO2 Emissions)
st.co2 <- c("Drzava", "Code", "Leto", "CO2_izpust_per_capita")
izpusti <- uvozi.co2.csv("podatki/co2_emissions_per_capita.csv", st.co2, 1, Inf)

### nov stolpec - Ekološki indeks
izpusti$"Ekoloski_indeks" <- round(1 - ((izpusti$"CO2_izpust_per_capita" - min(izpusti$"CO2_izpust_per_capita", na.rm = TRUE))/(max(izpusti$"CO2_izpust_per_capita", na.rm = TRUE) - min(izpusti$"CO2_izpust_per_capita", na.rm = TRUE))), digits = 3)

izpusti[izpusti$Drzava == "Qatar",]$"Ekoloski_indeks" <- 0.01

# Funkcija za uvoz datoteke WHO-COVID-19-global-data
uvozi.who.csv <- function(tabela, stolpci, skip, max) {
  uvoz <- read_csv(tabela,
                   locale = locale(encoding="utf-8"),
                   col_names = stolpci,
                   skip = skip,
                   n_max = max,
                   na = c("", " ", "-", ".."))
  uvoz <- uvoz %>%
    select("Drzava", "Stevilo_primerov_na_milijon")
  uvoz$Drzava <- str_replace(uvoz$Drzava, " *\\(.*?\\) *", "")
  return(uvoz)
}

## 7. tabela (COVID data)
st.cov <- c("Drzava","WHO_Region" ,"Stevilo_primerov" ,"Stevilo_primerov_na_milijon" ,"Cases_in_last_7_days","Cases_in_last_24_hours","Deaths-cumulative_total","Deaths_per_1_million_population","Deaths_in_last_7_days","Deaths_in_last_24_hours","Transmission_Classification")
covid <- uvozi.who.csv("podatki/WHO-COVID-19-global-data.csv", st.cov, 2, Inf) %>% drop_na()

covid$"Indeks_COVID" <- round((1 - ((covid$"Stevilo_primerov_na_milijon" - min(covid$"Stevilo_primerov_na_milijon", na.rm = TRUE)) / (max(covid$"Stevilo_primerov_na_milijon", na.rm = TRUE) - min(covid$"Stevilo_primerov_na_milijon", na.rm = TRUE)))), digits = 5)

covid[covid$Drzava == "Andorra",]$"Indeks_COVID" <- 0.01

### Nekatera imena moramo ročno popraviti, da se bodo tabele ujemale
izpusti[izpusti$Drzava == "Brunei",]$Drzava <- "Brunei Darussalam"
izpusti[izpusti$Drzava == "Cape Verde",]$Drzava <- "Cabo Verde"
izpusti[izpusti$Drzava == "Cote d'Ivoire",]$Drzava <- "Côte d'Ivoire"
izpusti[izpusti$Drzava == "Czech Republic",]$Drzava <- "Czechia"
izpusti[izpusti$Drzava == "Russia",]$Drzava <- "Russian Federation"
izpusti[izpusti$Drzava == "Syria",]$Drzava <- "Syrian Arab Republic"
izpusti[izpusti$Drzava == "Vietnam",]$Drzava <- "Viet Nam"
covid[covid$Drzava == "Kosovo[1]",]$Drzava <- "Kosovo"
covid[covid$Drzava == "occupied Palestinian territory, including east Jerusalem",]$Drzava <- "Palestine, State of"
izpusti[izpusti$Drzava == "Palestine",]$Drzava <- "Palestine, State of"
covid[covid$Drzava == "Republic of Korea",]$Drzava <- "Korea"
izpusti[izpusti$Drzava == "South Korea",]$Drzava <- "Korea"
covid[covid$Drzava == "Republic of Moldova",]$Drzava <- "Moldova"
covid[covid$Drzava == "The United Kingdom",]$Drzava <- "United Kingdom"
covid[covid$Drzava == "United Republic of Tanzania",]$Drzava <- "Tanzania"
covid[covid$Drzava == "United States of America",]$Drzava <- "United States"
izpusti[izpusti$Drzava == "Timor",]$Drzava <- "Timor-Leste"

## 8. tabela (Združimo tabele z indeksi izobrazbe, življenja, prihodka, neenakosti, izpustov in COVIDa)
nov.hdi <- left_join(izobrazba, zivljenje, by='Drzava') %>%
  left_join(., prihodek, by='Drzava') %>%
  left_join(., neenakost, by="Drzava") %>%
  left_join(., izpusti, by="Drzava") %>%
  left_join(., covid, by="Drzava") %>%
  select("Drzava", "Indeks_izobrazbe", "Indeks_zivljenja", "Indeks_prihodka", "Indeks_neenakosti", "Ekoloski_indeks", "Indeks_COVID")

### nova stolpca za star in nov HDI
nov.hdi$"Stari_HDI" <- round((nov.hdi$`Indeks_izobrazbe` * nov.hdi$`Indeks_zivljenja` * nov.hdi$`Indeks_prihodka`) ** (1/3), digits = 3)
nov.hdi$"Novi_HDI" <- round((nov.hdi$`Indeks_izobrazbe` * nov.hdi$`Indeks_zivljenja` * nov.hdi$`Indeks_prihodka` * nov.hdi$`Indeks_neenakosti` * nov.hdi$`Ekoloski_indeks` * nov.hdi$`Indeks_COVID`) ** (1/6), digits = 3)

### Popravimo, kjer je za isto državo več vrstic
### Filtriramo glede na novi HDI, kar sicer povzroči izbris držav, ki tega podatka nimajo, vendar bomo v nadaljevanju tako ali tako analizirali le tiste države, ki imajo vse podatke
nov.hdi <- nov.hdi %>%
  group_by(Drzava) %>%
  filter(Novi_HDI == max(Novi_HDI)) %>%
  distinct

## 9. tabela (Tabelo nov.hdi prečistimo in spravimo v tidy data)
nov.hdi.tidy <- nov.hdi %>% pivot_longer(c(-Drzava), names_to="Indeks", values_to="Vrednost")

### Sem potrebovala pri COVID tabeli, ko nisem uporabila stolpca 'število primerov na milijon prebivalcev', je pa to koda za uvoz iz html-ja
###   # Uvoz iz HTML (Prebivalstvo)
###   uvozi.html <- function() {
###     url <- "https://en.wikipedia.org/wiki/List_of_countries_and_dependencies_by_population"
###     stran <- read_html(url) %>% html_table(fill = TRUE)
###     uvoz <- stran[[1]]
###     uvoz <- uvoz %>%
###       rename("Drzava" = "Country(or dependent territory)") %>%
###       rename("Prebivalstvo" = "Population") %>%
###       select("Drzava", "Prebivalstvo")
###
###     uvoz$Drzava <- str_replace(uvoz$Drzava, " *\\(.*?\\) *", "")
###     uvoz$Drzava <- str_replace(uvoz$Drzava, " *\\[.*?\\] *", "")
###
###     uvoz$Prebivalstvo <- as.numeric(gsub(",", "", uvoz$Prebivalstvo))
###     return(uvoz)
###   }
###
###   ## tabela (Prebivalstvo po državah)
###   prebivalstvo <- uvozi.html()


#' Identify intervals in a genome not covered by a query.
#'
#' @param x [ivl_df]
#' @param genome [ivl_df]
#'
#' @family single set operations
#'
#' @return [ivl_df]
#'
#' @examples
#' x <- tibble::tribble(
#'   ~chrom, ~start, ~end,
#'   'chr1', 0,      10,
#'   'chr1', 75,     100
#' )
#'
#' genome <- tibble::tribble(
#'   ~chrom, ~size,
#'   'chr1', 200
#' )
#'
#' bed_glyph(bed_complement(x, genome))
#'
#' genome <- tibble::tribble(
#'    ~chrom,  ~size,
#'    'chr1',  500,
#'    'chr2',  600,
#'    'chr3',  800
#' )
#'
#' x <- tibble::tribble(
#'    ~chrom, ~start, ~end,
#'    'chr1', 100,    300,
#'    'chr1', 200,    400,
#'    'chr2', 0,      100,
#'    'chr2', 200,    400,
#'    'chr3', 500,    600
#' )
#'
#' # intervals not covered by x
#' bed_complement(x, genome)
#'
#' @export
bed_complement <- function(x, genome) {
  x <- check_interval(x)
  genome <- check_genome(genome)

  res <- bed_merge(x)

  # non-overlapping chroms
  chroms_no_overlaps <- anti_join(genome, res, by = "chrom")
  chroms_no_overlaps <- mutate(chroms_no_overlaps, start = 0)
  chroms_no_overlaps <- select(chroms_no_overlaps, chrom, start, end = size)

  # remove rows from x that are not in genome
  res <- semi_join(res, genome, by = "chrom")

  res <- group_by(res, chrom)

  res <- complement_impl(res, genome)

  res <- bind_rows(res, as_tibble(chroms_no_overlaps))
  res <- bed_sort(res)

  res
}


#writes_separate potentials files(of selected size)
rm(list=ls())

black_pearl<-list.files("K:\\Project_Data_Sagar\\my_truth\\recruit_truth\\")
altis<-as.numeric(substr(black_pearl,10,12))        #only numbers indicating no of AA residues in each files

#>100
length(which(altis>110 & altis<120))  #---> 1110
length(which(altis>120 & altis<130))  #907
length(which(altis>130 & altis<140))  #728
length(which(altis>90 & altis<100))   #1546
.
length(which(altis>=100 & altis<=110))  #2199
length(which(altis>=110 & altis<=120))  # 1313
length(which(altis>=100 & altis<=120)) # 3422   ---->

length(which(altis>=110 & altis<=115))  #756
length(which(altis>=115 & altis<=120))  #728

length(which(altis>=400 & altis<=500)) #533
length(which(altis>=500 & altis<=600)) #153
length(which(altis>=200 & altis<=300)) #2759 ------>
length(which(altis>=300 & altis<=400))  #1342

length(which(altis>100 & altis<200)) #9001

shekarya<-black_pearl[which(altis>=100 & altis<=110)]  #taking requied

#writing only requied files
for(atireki in shekarya){
metadata<-substr(atireki,1,8) #file name
file.copy(paste("K:\\Project_Data_Sagar\\my_truth\\recruit_truth\\",atireki,sep=""), paste("K:\\Project_Data_Sagar\\my_truth\\sangram_clipso\\",metadata,".txt",sep="") )
}


library(shiny)
library(cv2r)
library(ggplot2)
library(bioacoustics)
library(data.table)

if ( cv2_available() ) {
    ui <- fluidPage(fluidRow(
        actionButton(inputId = "snap", label = "Take"),
        actionButton(inputId = "snap2", label = "Take2"),
        actionButton(inputId = "plot_audio", label = "Audio")),
        fluidRow(
          column(3,inputCv2Cam("capture",
                               auto_send_audio = T, audio = T)),
          column(3,cv2Output(outputId = "zoom")),
          column(3,cv2Output(outputId = "border"))
    ),
    fluidRow(column(12, plotOutput(outputId = "envelop", height = 200))),
    fluidRow(column(12, plotOutput(outputId = "fullplot_veryhigh", height = 200))),
    fluidRow(column(12, plotOutput(outputId = "fullplot_high", height = 200))),
    fluidRow(column(12, plotOutput(outputId = "fullplot_low", height = 200)))
    )

    server <- function(input, output, session) {

        full_data <- numeric(0)

        observeEvent(input$capture_audio, {

            l_data_sel <- input$capture_audio

            cat(length(full_data), "\n")
            full_data <<- c(full_data, l_data_sel)
        })

        observeEvent(input$plot_audio, {
            l_data_sel <- full_data
            full_data <<- numeric(0)

            .GlobalEnv$l_data_sel <- l_data_sel
            #plot.Wav(tuneR::Wave(left = l_data_sel, right =  l_data_sel, bit=16, samp.rate=44100))

            l_plot <- data.table(
              time = seq_along(l_data_sel)/44100,
              amplitude = l_data_sel,
              envelope = abs(l_data_sel)
              )

            output$envelop <- renderPlot({
                ggplot(l_plot[sample.int(nrow(l_plot), 1000),] ) +
                    geom_line(aes(x=time, y=envelope )) +
                    theme_minimal() + stat_smooth(aes(x=time, y=envelope ))
            })

            output$fullplot_veryhigh <- renderPlot({
              spectro(tuneR::Wave(left = l_data_sel, bit=16, samp.rate=44100),
                      flim = c(3000, 10000),
                      FFT_size = 512  )
            })

            output$fullplot_high <- renderPlot({
              spectro(tuneR::Wave(left = l_data_sel, bit=16, samp.rate=44100),
                    flim = c(1000, 3000),
                    FFT_size = 1024  )
              })

            output$fullplot_low <- renderPlot({
              spectro(tuneR::Wave(left = l_data_sel, bit=16, samp.rate=44100),
                      flim = c(0, 1000),
                      FFT_size = 2048  )
            })

        })

        observeEvent(input$snap, {
          inputCv2CamSnap(session, "capture")
        })

        observeEvent(input$snap2, {
          inputCv2CamSnap(session, "capture", top = 100, left = 100, width = 200, height = 100)
        })

        output$zoom <- renderCv2({
          if ( !is.null(input$capture)) input$capture[5:200,5:200]
        })

        output$border <- renderCv2({
            imshow(mat = cv2r$Canny(input$capture, 10L, 50L) )
        })
    }

    if (interactive()) {
      shinyApp(ui, server)
    }

}


#Get summary a set of .rds files in a directory
#Get list of all .rds files
filenames = list.files(pattern="*\\.rds$")
#Load them all into a list of dataframes
data = lapply(filenames,readRDS)
#Collapse dataframes into one dataframe
data = do.call("rbind",data)
print(data)
print(summary(data))


#!/usr/bin/env Rscript
#
# Extract means and HPD intervals for PGE, PVE, and n_gamma. Works
# on just one file.
#

library(coda)
library(data.table)

argv = commandArgs(trailingOnly=TRUE)

thin = as.numeric(argv[2])
infile = argv[1]
infile_log = argv[3]

make_vec = function() numeric(1)
stats = data.frame('run'=make_vec(),
                   'pve_95_l'=make_vec(),
                   'pve_95_h'=make_vec(),
                   'pve_mean'=make_vec(),
                   'pge_95_l'=make_vec(),
                   'pge_95_h'=make_vec(),
                   'pge_mean'=make_vec(),
                   'ng_95_l'=make_vec(),
                   'ng_95_h'=make_vec(),
                   'ng_mean'=make_vec(),
                   'lmm_pve'=make_vec())

if(grepl('\\.gz$', infile)) {
    x = fread(paste('zcat', infile))
} else {
    x = fread(infile)
}

mcmc_data = as.mcmc(x, start=1, end=thin*nrow(x),
                    thin=thin)
hpd_95 = HPDinterval(mcmc_data, 0.95)
means = colMeans(x)

stats[1, 'pve_95_l'] = hpd_95['pve', 'lower']
stats[1, 'pve_95_h'] = hpd_95['pve', 'upper']
stats[1, 'pge_95_l'] = hpd_95['pge', 'lower']
stats[1, 'pge_95_h'] = hpd_95['pge', 'upper']
stats[1, 'ng_95_l'] = hpd_95['n_gamma', 'lower']
stats[1, 'ng_95_h'] = hpd_95['n_gamma', 'upper']
stats[1, 'pve_mean'] = means['pve']
stats[1, 'pge_mean'] = means['pge']
stats[1, 'ng_mean'] = means['n_gamma']
stats[1, 'run'] = 1

l = scan(infile_log, what='character', sep='\n', quiet=TRUE)
stats[1, 'lmm_pve'] = as.numeric(gsub('.+= ', '', l[grepl('pve', l)][1]))

write.table(stats, file=stdout(), sep='\t', col.names=TRUE,
            row.names=FALSE, quote=FALSE)


suppressPackageStartupMessages(library(optparse, warn.conflicts=F, quietly=T))

option_list <- list(
  make_option(c("-t", "--treatment"),
              type="character",
              default=NA,
              help="Treatment BigWig file"),
  make_option(c("-c", "--control"),
              type="character",
              default=NA,
              help="Control BigWig file"),
  make_option(c("-o", "--output"),
              type="character",
              default=NA,
              help="Name of output BigWig file"),
  make_option(c("-w", "--window"),
              type="integer",
              default=101,
              help="Sliding window size"),
  make_option(c("-l", "--transform"),
              type="character",
              default="log2",
              help="Transform to apply to enrichment values (log2 or linear)"),
  make_option(c("--min"),
              type="integer",
              default=-2,
              help="Floor for enrichment values (after transform)"),
  make_option(c("--max"),
              type="integer",
              default=NA,
              help="Ceiling for enrichment values (after transform)"),
  make_option(c("-f", "--filter"),
              type="character",
              default=NA,
              help="Expression to filter out chromosomes")
  )

# OPTION PROCESSING

opt <- parse_args(OptionParser(option_list=option_list))

if(is.na(opt$treatment)) {
  message("No treatment file specified.")
  q(status=1)
}

if(is.na(opt$control)) {
  message("No control file specified.")
  q(status=1)
}

if(is.na(opt$output)) {
  message("No output name specified.")
  q(status=1)
}

if(! opt$transform %in% c("log2", "linear")) {
  message("Transform type must be either 'log2' or 'linear'")
  q(status=1)
}

suppressPackageStartupMessages(library(GenomicRanges, warn.conflicts=F))
suppressPackageStartupMessages(library(rtracklayer, warn.conflicts=F))

# COMMON FUNCTIONS

total_signal_rlelist <- function(cvg) {
  stopifnot(is(cvg, "RleList"))
  sum(as.numeric(sum(cvg)))
}

filter_chrs <- function(cov, match_expression="H|M|U|_") {
  exclude.chrs <- grep(match_expression, names(cov))
  if(length(exclude.chrs) > 0) cov <- cov[-exclude.chrs]
  cov
}

single_value_rlelist <- function(value, lengths) {
  RleList(lapply(lengths, function(i) Rle(rep(value, times=i))))
}

message("Loading: ", opt$treatment)
ip.cov <- import(opt$treatment, as="RleList")
message("Loading: ", opt$control)
bg.cov <- import(opt$control, as="RleList")

common.chrs <- intersect(names(ip.cov), names(bg.cov))
ip.cov <- ip.cov[common.chrs]
bg.cov <- bg.cov[common.chrs]

if(!is.na(opt$filter)) {
  ip.cov <- filter_chrs(ip.cov, opt$filter)
  bg.cov <- filter_chrs(bg.cov, opt$filter)
}

# START

message("Processing treatment...")
ip.cov <- runsum(ip.cov, opt$window, endrule="constant")
ip.ts  <- total_signal_rlelist(ip.cov)

message("Processing control...")
bg.cov <- runsum(bg.cov, opt$window, endrule="constant")
bg.ts  <- total_signal_rlelist(bg.cov)

message("Calculating enrichments...")

transform_function <- get(ifelse(opt$transform == "log2", "log2", "identity"))
e.cov <- transform_function((ip.cov / ip.ts) / (bg.cov / bg.ts))

if(!is.na(opt$max)) {
  message("Ceiling: ", opt$max)
  e.cov <- pmin(e.cov, single_value_rlelist(opt$max, elementLengths(e.cov)))
}

if(!is.na(opt$min)) {
  message("Floor: ", opt$min)
  e.cov <- pmax(e.cov, single_value_rlelist(opt$min, elementLengths(e.cov)))
}

message("Removing non-finite values...")
e.gr <- as(e.cov, "GRanges")
e.gr <- e.gr[is.finite(e.gr$score)]
e.gr$score <- round(e.gr$score, 2)
e.cov <- coverage(e.gr, weight="score")

message("Saving: ", opt$output)
export(e.cov, opt$output, format="BigWig")


#UPDATED August 5, 2021

number_of_threads <- as.numeric(readLines("THREADS"))

alleles = list()
frequencies = list()

for (j in 1:nloci) {
	locicolumns = grepl(paste(locinames[j],"",sep=""),colnames(data))
	raw_alleles = c(as.matrix(data[,locicolumns]))
	raw_alleles[raw_alleles == "NA"] = NA
	raw_alleles[raw_alleles == 0] = NA
	alleles[[j]] = unique(raw_alleles[!is.na(raw_alleles)])
	frequencies[[j]] = sapply(alleles[[j]], function(x) sum(raw_alleles == x,na.rm=TRUE))
	frequencies[[j]] = frequencies[[j]] / sum(frequencies[[j]])
}

observeddatamatrix = list()
for (j in 1:nloci) {
	locus = locinames[j]
	locicolumns = grepl(paste(locus,"",sep=""),colnames(data))
	oldalleles = as.vector(data[,locicolumns])
	oldalleles [oldalleles == "NA"] = NA
	oldalleles [oldalleles == 0] = NA
	if (length(dim(oldalleles)[2]) == 0) {
		oldalleles = matrix(oldalleles,length(oldalleles),1)
	}
	observeddatamatrix[[j]] = oldalleles
}

m <<- rep(1,nloci)

H_nu = sapply(1:nloci, function (j) -sum(frequencies[[j]] * logb(frequencies[[j]],2)))

sub_per_locus = function(isolate1,isolate2,j) {
		v1 = observeddatamatrix[[j]][isolate1,]
		v1 = v1[!is.na(v1)]
		p1 = frequencies[[j]][match(v1,alleles[[j]])]
		v2 = observeddatamatrix[[j]][isolate2,]
		v2 = v2[!is.na(v2)]
		p2 = frequencies[[j]][match(v2,alleles[[j]])]

		if (ploidy[j] > 1) {
			x = length(unique(v1)) + length(unique(v2))
			n = min(length(unique(v1)),length(unique(v2)))
			w = x * (n > 1) + 4 * (n == 1) * (x == 2) + (1+x) * (n== 1) *  (x > 2)
			jj = 2 * (m[j] == 1) + m[j] * (m[j] > 1)
			y = length(intersect(v1,v2))
			z = 3 * (((2*(n == 1) + 1 * (y == 1) * (x > 2)))==3) + 2 * (y *(n>1)*(jj>=y)+jj*(n > 1)* (y > jj) + jj * (n==1) * (x==2) * (y==1))
			delta_nu_raw = w * (y == 0) + 2 * jj * (y > 0) + sum(sapply(jj:(2*jj), function (ii) -ii*(z == ii)))

			shared_alleles = intersect(v1 , v2)
			if (length(shared_alleles) > 0) {
				temp_shared = sapply(1:nids, function (x) sum(shared_alleles %in% as.matrix(observeddatamatrix[[j]][x,])))
				notmissing = sapply(1:nids, function (x) sum(!is.na(observeddatamatrix[[j]][x,])))

				P_nu = (sum(temp_shared == length(shared_alleles)) / sum(notmissing != 0))^2
			} else {
				P_nu = 1
			}
			k = 1 * (y == 0) + P_nu * (y > 0)
			delta_nu = H_nu[j] * ( delta_nu_raw * (delta_nu_raw > 0) + P_nu * (delta_nu_raw == 0))*k
			delta = delta_nu
		} else {
			delta_ex_raw = 0
			x = length(unique(v1)) + length(unique(v2))
			y = length(intersect(v1,v2))
			delta_ex_raw = 2*x*(y == 0)
			shared_alleles = intersect(v1 , v2)
			if (length(shared_alleles) > 0) {
				temp_shared = sapply(1:nids, function (x) sum(shared_alleles %in% as.matrix(observeddatamatrix[[j]][x,])))
				notmissing = sapply(1:nids, function (x) sum(!is.na(observeddatamatrix[[j]][x,])))
				P_ex = (sum(temp_shared == length(shared_alleles)) / sum(notmissing != 0))^2
			} else {
				P_ex = 1
			}
			k = 1 * (y == 0) + P_ex * (y > 0)
			delta_ex = H_nu[j] * ( delta_ex_raw * (delta_ex_raw > 0) + P_ex * (delta_ex_raw == 0))*k
			delta = delta_ex
		}
		if (sum(!is.na(v1)) == 0 | sum(!is.na(v2)) == 0) { delta = NA }
		delta
}

pairwisedistance_heuristic = function(isolate1,isolate2){
	print(((isolate2-1)*nids+isolate1)/ (nids*nids))
	delta = sapply(1:nloci, function (x) sub_per_locus(isolate1,isolate2,x))
	c(delta,sum(delta))
}

allpossiblepairs = expand.grid(1:nids,1:nids)
allpossiblepairs = unique(allpossiblepairs[allpossiblepairs[,1] <= allpossiblepairs[,2],])
pairwisedistancevector = do.call(cbind,mclapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistance_heuristic(allpossiblepairs[x,1],allpossiblepairs[x,2]),mc.cores=number_of_threads))

pairwisedistancematrix_components = list()
for (j in 1:(nloci+1)) {
	pairwisedistancematrix_temp = matrix(NA,nids,nids)
	sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix_temp[allpossiblepairs[x,1],allpossiblepairs[x,2]] <<- pairwisedistancevector[j,x])
	sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix_temp[allpossiblepairs[x,2],allpossiblepairs[x,1]] <<- pairwisedistancevector[j,x])
	pairwisedistancematrix_components[[j]] = pairwisedistancematrix_temp
}

#### impute missing values
pairwisedistancematrix_components_imputed = pairwisedistancematrix_components
whichna = which(rowSums(is.na(pairwisedistancematrix_components[[nloci+1]])) == nids)

imputemissing = function(isolate1) {
	missingloci = which(sapply(1:nloci, function (j) sum(!is.na(observeddatamatrix[[j]][isolate1,]))) == 0)
	nonmissingloci = (1:nloci)[-missingloci]
	matchingsamples = which(rowSums(rbind(sapply(nonmissingloci, function (j) sapply(1:nids, function (x) (setequal(observeddatamatrix[[j]][x,],observeddatamatrix[[j]][isolate1,]))))))==length(nonmissingloci))
	matchingsamples = setdiff( matchingsamples , whichna)
	for (j in missingloci ) {
		if (length(matchingsamples) > 0) {
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed[[j]][isolate1,x] <<- mean(pairwisedistancematrix_components[[j]][x,matchingsamples],na.rm=TRUE))
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed[[j]][x,isolate1] <<- mean(pairwisedistancematrix_components[[j]][x,matchingsamples],na.rm=TRUE))
			pairwisedistancematrix_components_imputed[[j]][isolate1,isolate1] <<- mean(diag(pairwisedistancematrix_components_imputed[[j]])[matchingsamples],na.rm=TRUE)
		} else {
			pairwisedistancematrix_components_imputed[[j]][isolate1,] <<-mean(pairwisedistancematrix_components[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed[[j]][,isolate1] <<-mean(pairwisedistancematrix_components[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed[[j]][isolate1,isolate1] <<-mean(diag(pairwisedistancematrix_components_imputed[[j]]),na.rm=TRUE)
		}
	}
}
sapply(whichna, imputemissing)

temppairwisedistancematrix = matrix(0,nids,nids)
for (j in 1:(nloci)) {
	temppairwisedistancematrix = temppairwisedistancematrix + pairwisedistancematrix_components_imputed[[j]]
}
whichna2 = which(rowSums(is.na(temppairwisedistancematrix )) != 0)

pairwisedistancematrix_components_imputed_secondpass = pairwisedistancematrix_components_imputed

imputemissing_secondpass = function(isolate1) {
	missingloci = which(sapply(1:nloci, function (j) sum(!is.na(observeddatamatrix[[j]][isolate1,]))) == 0)
	nonmissingloci = (1:nloci)[-missingloci]
	matchingsamples = which(rowSums(rbind(sapply(nonmissingloci, function (j) sapply(1:nids, function (x) (setequal(observeddatamatrix[[j]][x,],observeddatamatrix[[j]][isolate1,]))))))==length(nonmissingloci))
	matchingsamples = setdiff( matchingsamples , whichna)
	for (j in missingloci ) {
		if (length(matchingsamples) > 0) {
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,x] <<- mean(pairwisedistancematrix_components_imputed[[j]][x,matchingsamples],na.rm=TRUE))
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed_secondpass[[j]][x,isolate1] <<- mean(pairwisedistancematrix_components_imputed[[j]][x,matchingsamples],na.rm=TRUE))
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,isolate1] <<- mean(diag(pairwisedistancematrix_components_imputed[[j]])[matchingsamples],na.rm=TRUE)
		} else {
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,] <<-mean(pairwisedistancematrix_components_imputed[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed_secondpass[[j]][,isolate1] <<-mean(pairwisedistancematrix_components_imputed[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,isolate1] <<-mean(diag(pairwisedistancematrix_components_imputed[[j]]),na.rm=TRUE)
		}
	}
}

sapply(whichna2, imputemissing_secondpass)

# calculate final
finalpairwisedistancematrix = matrix(0,nids,nids)
for (j in 1:(nloci)) {
	finalpairwisedistancematrix = finalpairwisedistancematrix + pairwisedistancematrix_components_imputed_secondpass[[j]]
}

colnames(pairwisedistancematrix) = ids
rownames(pairwisedistancematrix) = ids

Heuristic_pairwisedistancematrix = finalpairwisedistancematrix


setwd("D:/Dropbox/Data analyze/Rdocuments/datas")
library(xlsx)
 library(RColorBrewer)

 ##读取t_for的大小
 k1<-read.xlsx("t_for.xls", sheetName = "0.2-2", header = TRUE)
k2<-read.xlsx("t_for.xls", sheetName = "0.3", header = TRUE)
k3<-read.xlsx("t_for.xls", sheetName = "0.4", header = TRUE)
k4<-read.xlsx("t_for.xls", sheetName = "0.5", header = TRUE)

v<-4.66e-13  #弯月面体积大小

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12)   #流量从1.5到180

k<-c(0.2,0.3,0.4,0.5) #占空比

pchc<-c(19,22,23,24)

mycolors<-c("red","blue", "darkgreen", "yellow3")

h<-0.3e-3 #弯月面变形大小

duty<-1-k

#par(mfrow=c(2,2), mar=c(4,2,2,2), oma=c(2,4,2,2))

#######流量1####
plot(k1[,1],  (duty[1]*q[1])/(k1[,1]*k1[,2]^2), log="x", lwd=2, xlab=expression(log(italic(f["v"])) (Hz)), ylab=expression(italic(F)), main="External forces k=0.2 & Q=180nl/min", col=mycolors[1], pch=pchc[1], ylim=c(0,5e-14))

lines(lowess(k1[,1],  (duty[1]*q[1])/(k1[,1]*k1[,2]^2)), col=mycolors[1], lwd=2.5,lty=2)

for(i in 1:3){

points(lowess(k1[,1], (duty[1]*q[i+1])/(k1[,1]*k1[,i+2]^2)),pch=pchc[i+1], lwd=2, col=mycolors[i+1])
lines(lowess(k1[,1], (duty[1]*q[i+1])/(k1[,1]*k1[,i+2]^2)), lwd=2.5, col=mycolors[i+1], lty=2)
}

legend("topright",c("1.5nl/min", "27nl/min","54nl/min","180nl/min"), inset=0.02, col=mycolors, pch=pchc, lwd=2, bty="n")

abline(h= (duty[1]*q[1])/(k1[11,1]*k1[11,2]^2), col="red", lwd=2,lty=3)
abline(h= (duty[1]*q[2])/(k1[11,1]*k1[11,3]^2), col="blue", lwd=2, lty=3)
abline(h= (duty[1]*q[3])/(k1[11,1]*k1[11,4]^2), col="darkgreen", lwd=2,lty=3)
abline(h= (duty[1]*q[4])/(k1[11,1]*k1[11,5]^2), col="yellow3", lty=3,lwd=2)
text(20, 1.5e-14,(duty[1]*q[1])/(k1[11,1]*k1[11,2]^2), col="red", font=2, cex=1)
text(20, 1.8e-14,(duty[1]*q[2])/(k1[11,1]*k1[11,3]^2), ,font=2, col="blue", cex=1)
text(20, 2.1e-14,(duty[1]*q[3])/(k1[11,1]*k1[11,4]^2), ,font=2, col="darkgreen", cex=1)
text(20, 2.4e-14,(duty[1]*q[4])/(k1[11,1]*k1[11,5]^2), ,font=2,col="yellow3", cex=1)


#' Plot deep learning SDM map
#'
#' A function that enables the plotting of deep learning predictions on a map.
#' @param raster_data A raster dataset containing the occurrence data.
#' @param keras_model A trained deep learning model.
#' @param custom_fun A custom predict function.
#' @param map_type A logical indicating if the map should be static or interactive.
#' @return An interactive leaflet map, showing the species distribution.
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # transform benchmarking data into a format suitable for deep learning
#' # if you have previously used a partitioning method you should specify it here
#' benchmarking_data_dl <- prepare_dl_data(input_data = benchmarking_data$df_data,
#'                                        partitioning_type = "default")
#'
#' # perform sanity check on the transformed dataset
#' # for the training set
#' head(benchmarking_data_dl$train_tbl)
#' table(benchmarking_data_dl$y_train_vec)
#'
#' # for the test set
#' head(benchmarking_data_dl$test_tbl)
#' table(benchmarking_data_dl$y_test_vec)
#'
#' # train neural network
#' keras_results <- train_dl(benchmarking_data_dl)
#'
#' # this function is needed for plotting
#' temp_fun <- function(model, input_data) {
#'   input_data <- tibble::as_tibble(input_data)
#'   data <- recipes::bake(benchmarking_data_dl$rec_obj, new_data = input_data)
#'   v <- keras::predict_proba(object = model, x = as.matrix(data))
#'   as.vector(v)
#' }
#'
#' # plot SDM map of neural network predictions
#' # change the map_type argument if you want a dynamic leaflet map
#' plot_dl_map(benchmarking_data$raster_data$climate_variables,
#'            keras_results$model,
#'            custom_fun = temp_fun,
#'            map_type = "static")
#'}
#'@export
plot_dl_map <- function(raster_data, keras_model, custom_fun, map_type = "static") {
    pr <- dismo::predict(raster_data$climate_variables, keras_model, fun = custom_fun)
    if (map_type == "static") {
        raster::plot(pr, main = "DL SDM Map")
    } else if (map_type == "interactive") {
        pal <- leaflet::colorNumeric(c("#ffdbe2", "#fff56b", "#58ff32"), raster::values(pr), na.color = "transparent")
        leaflet::leaflet(data = raster_data$coords_presence) %>%
            leaflet::addTiles() %>%
            leaflet::addRasterImage(pr, colors = pal, opacity = 0.5) %>%
            leaflet::addLegend(title = "Habitat Suitability", pal = pal, values = raster::values(pr), opacity = 1)
    }
}


setwd('C:\\kaggle\\competitions\\hackathon')

library(reshape)
library(plyr)

#Read the data:
TrainingData = read.csv("./upload/TrainingData.csv")
SubmissionZeros = read.csv("./upload/SubmissionZerosExceptNAs.csv")

names(TrainingData)

#Convenient to have a way to refer to target variables:
target_names = names(SubmissionZeros)[6:44]
target_names

#Average over hours
target_means_by_hour_of_day = ddply(TrainingData, "hour", function(df) colMeans(df[,target_names], na.rm = TRUE))
names(SubmissionZeros)

#Create slim submission skeleton for merging onto
submission_hour_means = SubmissionZeros[,1:5]

#Create full set of submissions via merge
submission_hour_means = merge(submission_hour_means, target_means_by_hour_of_day)

#function for putting -1000000's wherever they appear in the sample submission (I'm sorry this is necessary)
replaceNAs = function(submission, sample) {
  submission = submission[,names(sample)]
  stopifnot(mean(names(submission) == names(sample))==1)
  stopifnot(dim(submission) == dim(sample))
  submission = submission[order(submission$rowID),]
  submission[sample == -1000000] = -1000000
  submission
}

submission_hour_means_NAs = replaceNAs(submission_hour_means, SubmissionZeros)
write.csv(submission_hour_means_NAs, "./upload/submission_hour_means.csv", row.names = FALSE)

#Average by hour and chunk:
target_means_by_hour_and_chunkID = ddply(TrainingData, c("chunkID", "hour"), function(df) colMeans(df[,target_names], na.rm = TRUE))
names(SubmissionZeros)
submission_hour_chunk_means = SubmissionZeros[,1:5]

#The first time I did this I didn't use "all.x=TRUE" and my data frame was too short. Good thing I have error checking in "replaceNAs"!
submission_hour_chunk_means = merge(submission_hour_chunk_means, target_means_by_hour_and_chunkID, all.x=TRUE)
submission_hour_chunk_means_NAs = replaceNAs(submission_hour_chunk_means, SubmissionZeros)

#A few hour/chunk combinations seem to have given us NA's (always missing in training data).
#So we'll replace anywhere we have NA's with whatever we would have predicted in the last submission:
submission_hour_chunk_means_NAs[is.na(submission_hour_chunk_means_NAs)] = submission_hour_means_NAs[is.na(submission_hour_chunk_means_NAs)]
summary(submission_hour_chunk_means_NAs)
write.csv(submission_hour_chunk_means_NAs, "./upload/submission_hour_chunk_means.csv", row.names = FALSE)


library(qvalue)
for(i in c(1:22,"X")){
    d = read.table(paste("eqtl.nopermute.chr",i,sep=""), head=F, sep=" ", stringsAsFactors=F)
    d$qvalue = qvalue(d$V12)$qvalues
    write.table(d[which(!is.na(d$qvalue)),], paste("eqtl.nopermute.chr",i,".qvalue",sep=""), quote=F, row.names=F, col.names=T, sep="\t")
}


#!/usr/bin/env Rscript

#===========================================================
# R script for summarizing the results of generalized FitHiC
# Here, two different plots are generated:
# 1) distribution of contact count vs interaction distance for two different sets of interactions (separated by Q value)
# 2) distribution of contact count (as boxplot) for two different sets of interactions (separated by Q value)

# Q threshold is set as 0.01

#Author: Sourya Bhattacharyya
#Vijay-Ay lab, LJI

# usage: Rscript result_summary.r $inpfile
#===========================================================

suppressMessages(library(ggplot2))
suppressMessages(library(data.table))

options(scipen = 10)
options(datatable.fread.datatable=FALSE)

args <- commandArgs(TRUE)

# the 1st file is the file without any q-value based filtering
unfilt.file <- args[1]
inpdir <- dirname(unfilt.file)

# column no having the absolute contact count
contactcol <- as.integer(args[2])

# threshold of Q value which is used for filtering the contacts
QTHR <- as.double(args[3])

outdir <- paste0(inpdir,'/Results')
system(paste('mkdir -p', outdir))

boxplotCCQvalfile <- paste0(outdir,'/','CC_Qval.png')
plotfile <- paste0(outdir,'/','CC_IntDist.png')

if (1) { #((file.exists(boxplotCCQvalfile) == FALSE) | (file.exists(plotfile) == FALSE)) {

	# load the interaction matrix of the unfiltered file
	# Note: this unfiltered interaction file has header information
	unfilt.data <- data.table::fread(unfilt.file, header=T, sep="\t", stringsAsFactors=F)

	# absolute genomic distance data
	if (0) {
		## old code - when genomic distance field was not specified in the output interactions
		gen.dist <- abs(unfilt.data[,5] - unfilt.data[,2])
	} else {
		## new code - genomic distance field is specified
		gen.dist <- unfilt.data$Dist
	}

	# indices corresponding to significant and insignificant interactions
	# get the genomic distance and contact count for the significant interactions (Q value < QTHR)
	idx.qthr.pass <- which(unfilt.data[,ncol(unfilt.data)] < QTHR)
	# get the genomic distance and contact count for the nonsignificant interactions (Q value >= QTHR)
	idx.qthr.fail <- which(unfilt.data[,ncol(unfilt.data)] >= QTHR)

	# we only process and analyze if we have at least 2 success and 2 failure candidates
	if ((length(idx.qthr.pass) > 1) && (length(idx.qthr.fail) > 1)) {

		contactcountcol <- unfilt.data[,contactcol]

		CC.qthr.pass <- contactcountcol[idx.qthr.pass]
		gen.dist.qthr.pass <- gen.dist[idx.qthr.pass]

		CC.qthr.fail <- contactcountcol[idx.qthr.fail]
		gen.dist.qthr.fail <- gen.dist[idx.qthr.fail]

		#===========================================
		# plot the distributions of contact count for two different sets of Q values
		# The first set is the set of significant interactions (Q val < 0.01)
		# The second set is the set of significant interactions (Q val >= 0.01)
		if (file.exists(boxplotCCQvalfile) == FALSE) {
			a <- data.frame(group = paste0("CC_Qval<", QTHR), value = CC.qthr.pass)
			b <- data.frame(group = paste0("CC_Qval>=", QTHR), value = CC.qthr.fail)
			ccQVal <- rbind(a, b)
			#pdf(boxplotCCQvalfile, width=10, height=6)
			currplot <- ggplot(ccQVal, aes(x=group, y=value, fill=group)) + geom_boxplot()
			currplot + ggtitle("Box plot for contact counts - significant vs non-significant interactions")
			ggsave(boxplotCCQvalfile, width=10, height=6)
			#dev.off()
		}
		#===========================================

		# first bind the genomic distance and the contact count information
		# for both Q value sets
		qthr.pass_GenDist_CC <- cbind(gen.dist.qthr.pass, CC.qthr.pass)
		qthr.fail_GenDist_CC <- cbind(gen.dist.qthr.fail, CC.qthr.fail)

		# now sort the data frames according to the genomic distance
		# (first column ascending order)
		# also remove the duplicate entries
		qthr.pass_GenDist_CC_uniq <- unique(qthr.pass_GenDist_CC[ order(qthr.pass_GenDist_CC[,1]), ])
		qthr.fail_GenDist_CC_uniq <- unique(qthr.fail_GenDist_CC[ order(qthr.fail_GenDist_CC[,1]), ])

		# now plot all the elements of the significant (pass) interactions
		# and selectively plot the elements of the non-significant (fail) interactions
		nelem <- length(qthr.pass_GenDist_CC_uniq[,1])

		qval.fail.meanCC <- c()
		AvgIntDist.fail <- c()
		num.qval.fail <- length(qthr.fail_GenDist_CC_uniq[,1])
		nentry <- floor(num.qval.fail / nelem)
		for (i in (1:nelem)) {
			si <- (i - 1) * nentry + 1
			if (i < nelem) {
				ei <- si + nentry - 1
			} else {
				ei <- num.qval.fail
			}
			qval.fail.meanCC[i] <- mean(qthr.fail_GenDist_CC_uniq[si:ei,2])
			AvgIntDist.fail[i] <- mean(qthr.fail_GenDist_CC_uniq[si:ei,1])
		}

		a <- data.frame(group = "Qval<0.01", x = qthr.pass_GenDist_CC_uniq[,1], y = qthr.pass_GenDist_CC_uniq[,2])
		b <- data.frame(group = "Qval>=0.01", x = AvgIntDist.fail, y = qval.fail.meanCC)
		curr_plot <- ggplot(rbind(a,b), aes(x=x, y=y, fill=group, colour=group)) + geom_point(size=0.01) + xlab('Average interaction distance') + ylab('Contact count')
		curr_plot + ggtitle("Interaction distance vs Contact count - both Qvalue classes")
		ggsave(plotfile, width=12, height=8)

	#===========================================
	} else {
		cat(sprintf("\n Either significant or insignificant interactions have count 0 - quit !!"))
	}
}