#  Animate multiple variables of hourly ERA5-Land data on a rotating globe
#  Philip Kraaijenbrink <p.d.a.kraaijenbrink@uu.nl>
#  18 Dec 2020

library(tidyverse)
library(pbapply)
# devtools::install_github('kraaijenbrink/pkrf')
library(pkrf)         # see kraaijenbrink/pkrf on github
library(raster)
library(ggspatial)
library(RStoolbox)
library(snowfall)
rm(list=ls())

# https://video.stackexchange.com/questions/20495/how-do-i-set-up-and-use-ffmpeg-in-windows

# setup -------------------------------------------------------------------

# settings
outroot   = './exports/frames'
overwrite = T
flist     = list.files('./data/varstacks', full=T, patt='.tif$')
# basemap   = brick('./data/basemap_4326.tiff')[[-4]]
plotext   = extent(-6430000, 6430000, -6430000, 6430000)
anisetup  = tibble(
  fn = flist,
  crmp = c('inferno','parula','tempo','magma','precip2',
           'temperature','davos','jet','wtspec','plasma',
           'turku','magma','elevnat1','spectral','globwarm',
           'viridis','bluesice','magma')[1:length(flist)],
  crmp_r = c(F,F,F,F,F,
             F,T,F,F,F,
             T,F,T,T,F,
             F,T,F)[1:length(flist)]
)

# finalize setup ----------------------------------------------------------

if (dir.exists(outroot) & !overwrite){
  stop('output dir already exists')
}else if (!dir.exists(outroot)){
  dir.create(outroot)
}

# estimate variable ranges
sfInit(T, parallel::detectCores()-2, 'SOCK')
sfLibrary(raster)
sfExport('anisetup')
varranges  = sfLapply(anisetup$fn, function(x){
  cellStats(raster(x), function(y, ...){
    quantile(y, probs=c(0.02,0.98), na.rm=T)
  })
})
sfStop()

varranges     = do.call(rbind,varranges)
anisetup$low  = varranges[,1]
anisetup$high = varranges[,2]

# replicate to fit hourly data
n_var         = nrow(anisetup)
anisetup      = anisetup[rep(1:n_var, each=24),]
anisetup$band = rep(1:24, n_var)
anisetup$time = seq(as.POSIXct('2020-01-01', tz='UTC'),
                    by='hours', length.out=nrow(anisetup))
anisetup$ts   = format(anisetup$time, '%Y-%m-%d %H:%M')

# replicate for smoother rotation framerate
anisetup      = anisetup[rep(1:nrow(anisetup),each=3),]
anisetup$lon  = approx(c(1,nrow(anisetup)),c(100,-85), xout=1:nrow(anisetup))$y

# plotting ----------------------------------------------------------------

# function to generate earth outline
circleFun <- function(center=c(0,0), r=1, npoints=360){
  tt <- seq(0, 2*pi, length.out=npoints)
  xx <- center[1] + r * cos(tt)
  yy <- center[2] + r * sin(tt)
  return(tibble(x = xx, y = yy))
}

# function to generate plot for a single frame
makePlot = function(
    fn,
    b           = 1,
    lat         = 0,
    lon         = 0,
    pext        = plotext,
    resolution  = 12000,
    colramp     = 'inferno',
    colramp_rev = F,
    l           = 240,
    h           = 310,
    bordercolor = 'white',
    timestamp   = '2020-01-01 00:00'){

  # reproject era data and basemap
  projdef      = sprintf('+proj=ortho +lon_0=%f +lat_0=%f', lon, lat)
  pdat         = projectRaster(raster(fn,band=b), crs=crs(projdef), res=resolution)
  pdat_pts     = rasterToPoints(pdat) %>% as_tibble %>% rename(z=3)

  # reproject base layer
  # basemap_proj = projectRaster(basemap, crs=crs(projdef), res=resolution)
  # baselayer    = ggRGB(basemap_proj,1,2,3,ggLayer=T)

  # clean up variable name for title
  varname = fn %>%
    str_extract('[0-9]{8}_.*.tif$') %>%
    str_remove('_hourly') %>%
    str_remove('[0-9]{8}_') %>%
    str_remove('.tif$') %>%
    str_replace_all('_',' ') %>%
    str_to_sentence()

  # actual plotting
  ggplot(pdat_pts) +
    # baselayer +
    geom_raster(aes(x,y,fill=z), hjust=0.5, vjust=0.5, alpha=0.75) +
    scale_fill_gradientn(colours=pkrf::ramp(colramp,rev=colramp_rev),
                         limits=c(l,h), oob=scales::squish, name=NULL) +
    geom_path(aes(x,y), data=circleFun(r=pext[2]), colour=bordercolor, size=2.5) +
    coord_sf(expand=F, datum=NULL, xlim=pext[1:2], ylim=pext[1:2]) +
    theme_pk(base_size=14) +
    labs(x=NULL, y=NULL, title=varname, subtitle=timestamp) +
    labs(caption='ERA5-Land (ECMWF)                                                   @philipkraai') +
    theme(plot.background      = element_blank(),
          panel.background     = element_blank(),
          panel.border         = element_blank(),
          axis.line            = element_blank(),
          plot.title           = element_text(margin=margin(b=9), hjust=0.5, face='plain', size=rel(1.3)),
          plot.subtitle        = element_text(margin=margin(b=12), hjust=0.5, face='bold', size=rel(0.9), family='mono'),
          plot.caption         = element_text(margin=margin(0,0,0,0), face='plain', size=rel(0.8)),
          legend.position      = 'none'
    )
}

# export ------------------------------------------------------------------

# export frames in parallel (RAM disk swapping may corrupt images)
invisible(gc())
sfInit(T, min(c(8,parallel::detectCores()-2)), 'SOCK')
sapply(c('raster','ggplot2','stringr','dplyr','raster','ggspatial','RStoolbox','pkrf'),
       sfLibrary, char=T)
sfExportAll()
out = sfLapply(1:nrow(anisetup), function(i){
  p = makePlot(fn=anisetup$fn[i], lat=0, lon=anisetup$lon[i], b=anisetup$band[i],
               resolution=10000, colramp=anisetup$crmp[i], colramp_rev=anisetup$crmp_r[i],
               l=anisetup$low[i], h=anisetup$high[i], timestamp=anisetup$ts[i])
  ggsave(file.path(outroot,sprintf('%04d.png',i)), p, dpi=200, width=15, height=15, units='cm')
  return(NULL)
})
sfStop()


rm(list=ls())
#Sys.setenv("PKG_LIBS"="-lprofiler")
setwd("~/Dropbox/trw")
#Creates data used for tests

#source("~/Dropbox/trw/trw_run.r")
#source("~/Dropbox/trw/trw_fns.r")
source("suff_stats.r")
#source("~/Dropbox/trw/trw_global.r")

#setwd("./Experiments/Data")

libs=c(
  "Matrix",
  "orthopolynom",
  "igraph",
  "Rcpp",
  "inline",
  "RcppArmadillo",
  "parallel",
  "SnowballC",
  "ape",
  "mclust",
  "huge",
  "glasso",
  "abind")
if (sum(!(libs %in% .packages(all.available = TRUE))) > 0) {
  install.packages(libs[!(libs %in% .packages(all.available = TRUE))],
                   repos="http://cran.stat.ucla.edu")
}
for (i in 1:length(libs)) {
  library(libs[i],character.only = TRUE,quietly=TRUE)
}

d=20
n=10000
m=6
edgelist<- get.edgelist( graph.full(d,directed=F) )
g<-   erdos.renyi.game(d/2,.3); g<- g+g
#g<-graph.empty(d)
edgelist<- get.edgelist(g)
clust<- clusters(g)$membership
#edgelist<- get.edgelist( graph.tree(d))
#edgelist<- get.edgelist(graph.empty(d))
#edgelist<- cbind(edgelist[,2],edgelist[,1])
res=64
seq.Out<-seq(from=0,to=1,length.out=res)
weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])

###############

#Generate data
######################
h<-huge.generator(n,d=d,graph="random",prob=2/d)
h$data<-scale(h$data,center=T,scale=T)/10+0.5
#h$data<-qexp(pnorm(h$data),rate=12)
train<-h$data[1:floor(n*.5),]
test<-h$data[ (floor(n*.5)+1) : n,]
#dat<-gauss.mix.sim(400,d=d)

train[1:1000,]<-apply(train[1:1000,],2,function(x){x+rnorm(d)*.08})
train[1001:2000,]<-apply(train[1001:2000,],2,function(x){x+rnorm(d)*.08})

#train[1100:2000,3:4]<-train[1100:2000,3:4]-.3
train[train>1] = .999 ;train[train<0] = .001
######################

cores<-parallel::detectCores()
edge_mean <- edge.means(train, edgelist, m, cores)
node_mean <- node.means(train , m,cores)
#gsl not working on ubuntu
legen.Vec<-legendre_Pl_array(m,2*seq.Out-1)[-1,]
#leg.mat<-legen.Vec%*%t(legen.Vec)
legen.array<-array(dim=c(res,res,m^2))
k=1
for(i in 1:m){
  for(j in 1:m){
    legen.array[,,k]<-tcrossprod(legen.Vec[i,],legen.Vec[j,])
    k=k+1
  }
}
if(dim(edgelist)[1]==0){
  edge_coef<-
    array(dim=c(m,m,0))
}else{
  edge_coef<- sapply(1:dim(edgelist)[1],
                   function(x)matrix(tcrossprod(rnorm(m)*.000^(1:m) , rnorm(m)*.000^(1:m)),m,m),
                   simplify="array")
}
node_coef<- t(sapply(1:d,function(x)rnorm(m)*.00^(1:m)))

Rcpp::sourceCpp("./trw.cpp")

#parallelMatrixSqrt(matrix(10,10,10))

lambda=.1
alpha_start=1

out<-rwrapper(
  edge_coef,
  node_coef,
  edge_mean,
  node_mean,
  edgelist,
  weights,
  legen.Vec,
  legen.array,
  lambda,
  alpha_start
)

par(mfcol=c(2,2))
for(i in 1:4){
  contour((out$edge_den[,,i]),nlevels=20)
  points(train[,(edgelist[i,])],cex=.01)
}

# r<-1:10
# #const_test(r)
#
# microbenchmark::microbenchmark(
#   neg_ll(node_means,edge_means,node_coefs,edge_coefs,weights,
#          edgelist,legen.Vec,legen.array),
#   times=100
# )
#
# microbenchmark(
# a<-beliefprop(edge_coefs,
#               node_coefs,
#               rep(1,dim(edgelist)[1]*2),
#               rbind(edgelist,
#               cbind(edgelist[,2],edgelist[,1])),
#               legen.Vec,
#               legen.array,
#               cores=cores )
# )
# gq=get_quasi(a$edge_den, a$beliefs, edge_means,  node_means, legen.Vec)
# mi=mutual_info(a$edge_den,a$beliefs,edgelist)
# pf=partition_fn(mi$entropy,mi$mutual_info, node_coefs, edge_coefs,gq$vert_quasi,gq$edge_quasi, rep(1,dim(edgelist)[1]))
#
# microbenchmark::microbenchmark(
# neg_ll(node_means,edge_means,node_coefs,edge_coefs,weights,
#        edgelist,legen.Vec,legen.array),
# times=1
# )
#
# microbenchmark::microbenchmark(
#   get_quasi(a$edge_den, a$beliefs, edge_means,  node_means, legen.Vec),
#   get.Quasi(a$beliefs,aperm(a$edge_den,c(3,1,2)), node_means, aperm(edge_means, c(3,1,2))),
#   times=10
# )
#
# microbenchmark::microbenchmark(
#   mutual_info(a$edge_den,a$beliefs,edgelist),
#   mut.info(a$beliefs,a$edge_den,edgelist),
#   times=5
# )
# microbenchmark::microbenchmark(
#   #beliefprop(edge_coefs, node_coefs, rep(1,dim(edgelist)[1]*2), rbind(edgelist, cbind(edgelist[,2],edgelist[,1])), legen.Vec, legen.array,cores=1 ),
#   beliefprop(edge_coefs, node_coefs, rep(1,dim(edgelist)[1]*2), rbind(edgelist, cbind(edgelist[,2],edgelist[,1])), legen.Vec, legen.array,cores=cores ),
#   times=10
# )
#
#
# pdf("dataplot.pdf")
# plot(h)
# dev.off()
# save(file="data.rdata",
#            list=c("d","n","h","train","test", "edge_means","node_means"))


#R script for genomic selection.

#Areas to up-date for a given run are high-lighted by #-------- around comments.

#------------------------------
#Input file formats.
#There are 3 input files:
#(1) Phenotype data. File has column headings. Separate row for each miscanthus genotype. The miscanthus genotype column
#    must have name geno. The columns are broken into 2 sets of contiguous blocks. The first set
#    are information columns, e.g. geno and things like plate_id, order, longitude etc. The second
#    set are the trait phenotype data as BLUPs with the same trait measured in different years having
#    separate columns. The miscanthus genotypes must be in the same order as in the SNP genotype file.
#    The traits must be in the same order as in the H2 file. NA used to mark missing BLUP trait data.
#(2) SNP genotype file. No column headings. One row for each SNP. One column for each miscanthus
#    genotype. SNP genotypes in -1/0/1 (NA) format.
#(3) H2 file. Two columns with headings. The H2 column must be called H2. The other column contains the
#    trait names.
#
#Output file formats.
#There are 4 output files.
#(1) Predictive abilities file. The row and column names give the trait names. There is a row for each trait.
#    There are two blocks of columns. The first block are the mean predictive abilities for each of the traits.
#    The second block are the SDs of the predictive abilities.
#(2) The accuracies file has exactly the same format as the predictive abilities file except the mean
#    and SD of the accuracies are recorded.
#(3) Regression coefficients file.
#(4) Workspace file for R.
#------------------------------

#------------------------------
#Enter details of input files.
#Enter phenotype file name.
pheno_input_name <- "si8_gs_si_blups.csv"

#Number of information columns at start of phenotype file.
blank_cols = 7
#Number of trait phenotype columns in phenotype file entered as 1 to number of traits.
traits<-1:42 # Could also include latitude, longitude, PC1-10

#Enter SNP genotype file name
snp_input_name <- "flora_Sb_liberal_rrblup"

#Enter H2 file name.
h2_input_name <- "si8_gs_si_h2.csv"
#------------------------------

#------------------------------
#Configure the run.
#Number reps. Used so can get useful means and SDs
#of the predictive abilities and accuracies.
reps <-100

#For a given rep and trait the number of folds controls
#the number of miscanthus genotypes trait phenotypes (BLUPs) that are predicted from
#the other miscanthus genotypes data in one go. When the fold is
#10 and there are 138 miscanthus genotypes then 10 blocks of
#phenotype predictions are made. Each block (apart from the last)
#predicts 13 (138/10) genotypes from the others genotypes phenotype (BLUP trait) data.
#Each miscanthus genotypes phenotype data is predicted only once for a given trait on
#a given rep.
folds<-10
#------------------------------

#------------------------------
#Enter details of output files.
#Enter name of predictive abilities file.
predict_output_name <- "si8_gs_si_out_pred.csv"

#Enter name of accuracies file.
accuracy_output_name <- "si8_gs_si_out_acc.csv"

#Enter name of regression coefficients file.
reg_coeff_output_name <- "si8_gs_si_out_coeff.csv"

#Enter name of R workspace file.
work_sp_output_name <- "si8_gs_si_out_ws.RData"
#------------------------------

#------------------------------
#The above information entry is all that is needed to run this script.
#------------------------------

#On ecb will need to install this library for each users account.
library(rrBLUP)

#Load SNP genos
G<-as.matrix(read.table(snp_input_name ,header=F))
G<-t(G)
print(dim(G))

#Load phenotype and H2 data
pheno_data<-data.frame(read.csv(pheno_input_name, header=T))
H2 <- data.frame(read.csv(h2_input_name, header=T))

#Calc kinship matrix using rrBLUP. Missing data are imputed.
K <- A.mat(G)
rownames(K)<-pheno_data$geno

#Create storage 3D arrays for results across reps.
r_yy<- array(NA,c(length(traits),length(traits),reps)) # predictive abilities
r_gg<- array(NA,c(length(traits),length(traits),reps)) # accuracies
coeffs <- array(NA,c(length(traits),2,reps)) # slopes and intercepts of regression

#Loop round the reps
for (repno in 1:reps) {

	print(paste("rep #",repno))

	#For this rep calc the number of miscanthus genotypes predicted in fold.
	pred_n<-floor(nrow(G)/folds)

	blup_pred <- as.matrix(rep(NA,nrow(G)))

	#For this rep the random order the miscanthus genotypes predicted in.
	perm_order<-sample(1:nrow(G))

	#Loop through each trait and predict.
	for (trait in traits) {
				# Pick a trait
				P<-data.frame(pheno_data[,blank_cols+trait])
				colnames(P)<-"pheno"

				traitname <- colnames(pheno_data)[blank_cols+trait]
				print(traitname)

						#Loop round the folds and do the actual predictions.
						for (i in 1:folds) {

							#Select the miscanthus genotypes to predict on this fold using
							#the other genotypes.
							if (i<folds){
								pred_idx<-perm_order[(pred_n*i-(pred_n-1)):(pred_n*i)]
							}else{
								pred_idx<-perm_order[(pred_n*i-(pred_n-1)):(nrow(P))]
							}#End of if

							#Set-up data to make predictions.
							train_idx <- setdiff((1:nrow(P)),pred_idx)
							P_train<-P$pheno
							P_train[pred_idx]<-NA
							d<-data.frame(pheno=P_train,id=pheno_data$geno)

							#rrBLUP function for genotypic prediction based on kinship
							out<-kin.blup(d,pheno="pheno",geno="id",K=K)

							#Cumulative storage of predicted trait values for miscanthus genotypes.
							blup_pred[pred_idx] = out$g[pred_idx]
						}#End of fold loop.

				#Correlate the predicted values with the actual values and store
				#resulting predictive abilities in 3D array at this rep.
				r_yy[trait,,repno] <-  cor(blup_pred,pheno_data[,(blank_cols+1):(blank_cols+length(traits))],use="pairwise.complete.obs")

				#Calculate accuracies and store in 3D array at this rep.
				r_gg[trait,,repno] <-  r_yy[trait,,repno]/sqrt(H2$H2[trait])

				#Store slopes and intercepts of regression in 3D array at this rep
				coeffs[trait,1,repno] <-  coef(lm(P$pheno~blup_pred))[1] # Regression intercepts
				coeffs[trait,2,repno] <-  coef(lm(P$pheno~blup_pred))[2] # Regression slopes
	}#End of trait loop.
}#End of rep loop.

#For each trait-by-trait location find the mean predictive ability and the SD of
#the predictive abilities across all the reps and store ready for output.
r_yy_bar<-apply(r_yy,c(1,2),mean) # Ave r_yy
r_yy_sd<-apply(r_yy,c(1,2),sd)	# SD r_yy
r_yy_summary<-(cbind(r_yy_bar, r_yy_sd))
rownames(r_yy_summary)<-colnames(pheno_data)[(blank_cols+1):(blank_cols+length(traits))]
colnames(r_yy_summary)<-rep(rownames(r_yy_summary),2)

#For each trait-by-trait location find the mean accuracy and the SD of
#the accuracies across all the reps and store ready for output.
r_gg_bar<-apply(r_gg,c(1,2),mean) # Ave r_gg
r_gg_sd<-apply(r_gg,c(1,2),sd)	# SD r_gg
r_gg_summary<-(cbind(r_gg_bar, r_gg_sd))
rownames(r_gg_summary)<-colnames(pheno_data)[(blank_cols+1):(blank_cols+length(traits))]
colnames(r_gg_summary)<-rep(rownames(r_gg_summary),2)

#Means and SDs of the regression coefficients ready for output.
coeffs_bar<-apply(coeffs,c(1,2),mean) # Ave coeffs
coeffs_sd<-apply(coeffs,c(1,2),sd)	# SD coeffs
coeffs_summary<-(cbind(coeffs_bar, coeffs_sd))
rownames(coeffs_summary)<-colnames(pheno_data)[(blank_cols+1):(blank_cols+length(traits))]
colnames(coeffs_summary)<-c('bo','b1','sd_bo','sd_b1')

# Print/save files
write.csv(r_yy_summary, predict_output_name)
write.csv(r_gg_summary, accuracy_output_name)
write.csv(coeffs_summary, reg_coeff_output_name)
rm(G)

print("***********Program run complete***********")
save.image(work_sp_output_name)


#' Expected Value of Information
#'
#' Calculate the expected value of information for box ironbark and woodland
#' management
#'
#' @param data Input and output data as a single data.frame.
#' @param ncores Interger. Number of cpu cores.
#' @param max_eco Numeric. Maximum proportion of the landscape allocatable to
#'        thinning.
#' @param type Character. Type of evoi analysis.
#' @param parameter_list list. When \code{type = "evpxi_list"} a list of
#'        parameter sets must be supplied where the list elements are named
#'        vectors of parameter where the names correspond to the action the
#'        parameter of interest associated with.
#'
#' @importFrom dplyr arrange distinct select_
#' @importFrom parallel mclapply
#' @importFrom tidyr spread_
#' @importFrom stats predict
#' @importFrom earth earth

#' @export

evoi <-
  function(
    data, ncores = 1, max_eco = .2,
    type = c("evpi", "evwoi", "evpxi_list", "evpxi"),
    parameter_list = NULL
  ) {

    type <- match.arg(type)

    with(
      data,
      {
        actions <- unique(action)

        data <-
          lapply(
            actions,
            function(x) {
              data <-
                spread_(
                  data[data[, "action"] == x, ],
                  "parameter",
                  "parameter_value"
                )
              data  <- arrange(data, sample, run)
              data[, setdiff(colnames(data), c("action", "run", "sample"))]
            }
          )

        models <- lapply(data, fit_earth, "outcome")
        parameters <- lapply(data, select_, paste0("-", "outcome"))
        parameters <- lapply(parameters, distinct)
        outcomes <- mapply(predict, models, parameters)
        n_samples <- length(unique(sample))
        colnames(outcomes) <- names(models) <- names(parameters) <- actions

        out <-
          lapply(
            max_eco,
            evoi_,
            outcomes,
            parameters,
            models,
            n_samples,
            actions,
            ncores,
            type,
            parameter_list
          )

        do.call(rbind, out)
      }
    )
  }

o2v <- function(outcomes, max_eco) {
  with(
    as.data.frame(outcomes),
    data.frame(
      NM     = NM,
      HF     = HF,
      EN     = ET * max_eco + NM * (1 - max_eco),
      EH     = ET * max_eco + HF * (1 - max_eco)
    )
  )
}

calc_vwpxi <-
  function(sample, theta, action, parameters, models, max_eco) {
    for (i in seq_along(action)) {
      parameter_action <- getElement(parameters, action[i])
      parameter_action[, theta[i]] <- parameter_action[sample, theta[i]]
      parameters <- within(parameters, assign(action[i], parameter_action))
    }
    outcomes <- mapply(predict, models, parameters)
    colnames(outcomes) <- names(models)
    value <- o2v(outcomes, max_eco)
    mean_value <- colMeans(value)
    ans <- max(mean_value)
    attr(ans, "which.max") <- which.max(mean_value)
    ans
  }

calc_evwpxi <-
  function(theta, action, n_samples, parameters, models, max_eco) {

    results <-
      sapply(
        seq_len(n_samples),
        calc_vwpxi,
        theta,
        action,
        parameters,
        models,
        max_eco
      )

    list(evwpxi = mean(results), vwpxi = results)

  }

calc_evwpxi_ <-
  function(action, n_theta, n_samples, parameters, models, max_eco, ncores) {
    mclapply(
      seq_len(n_theta[[action]]),
      calc_evwpxi,
      action,
      n_samples,
      parameters,
      models,
      max_eco,
      mc.cores = ncores
    )
  }

evoi_ <-
  function(
    max_eco, outcomes, parameters, models, n_samples, actions,
    ncores, type, parameter_list
  ) {

    value <- o2v(outcomes, max_eco)

    evwoi <- max(colMeans(value))

    switch(
      type,

      evpi =
        {
          evwpi <- mean(apply(value, 1, max))

          attr(evwpi, "vwpi") <- apply(value, 1, which.max)

          data.frame(
            parameters = "EVPI",
            max_eco    = max_eco,
            evi        = evwpi - evwoi,
            stringsAsFactors = FALSE
          )
        },

      evwoi =
        data.frame(
          parameters = "EVWOI",
          max_eco    = max_eco,
          evi        = evwoi,
          stringsAsFactors = FALSE
        ),

      evpxi_list =
        {
          evwpxi <-
            mapply(
              calc_evwpxi,
              parameter_list,
              lapply(parameter_list, names),
              MoreArgs =
                list(
                  n_samples  = n_samples,
                  parameters = parameters,
                  models     = models,
                  max_eco    = max_eco
                ),
              SIMPLIFY = FALSE
            )

          ans <-
            data.frame(
              parameters = names(parameter_list),
              max_eco    = max_eco,
              evi        =
                unlist(lapply(evwpxi, getElement, name = "evwpxi")) - evwoi,
              stringsAsFactors = FALSE
            )

          attr(ans, "vwpxi") <- lapply(evwpxi, getElement, name = "vwpxi")

          ans
        },

      evpxi =
        {
          evwpxi <-
            lapply(
              actions,
              calc_evwpxi_,
              lapply(parameters, ncol),
              n_samples,
              parameters,
              models,
              max_eco,
              ncores
            )

          ans <-
            data.frame(
              parameters = unlist(lapply(parameters, names)),
              max_eco    = max_eco,
              evi        =
                unlist(
                  lapply(
                    evwpxi,
                    function(x) lapply(x, getElement, name = "evwpxi")
                  )
                ) - evwoi,
              stringsAsFactors = FALSE
            )

          attr(ans, "vwpxi") <-
            lapply(
              evwpxi,
              function(x) lapply(x, getElement, name = "vwpxi")
            )

          ans

        }
    )
  }

fit_earth <-
  function(x, outcome, ...) {
    earth(
      x      = x[, setdiff(colnames(x), outcome)],
      y      = x[, outcome],
      degree = 5,
      ...
    )
  }


## 17022020 CKR
#Figure 2C
library(vegan)
library(ggsci)
library(tidyr)
library(reshape2)
library(dplyr)
library(ggpubr)
library(stringr)
library(matrixStats)
library(beanplot)

#Canada
CanadaPTR=read.table("../Data/Suppl5_CA.txt",sep="\t",head=T,row.names=1)#read in PTR
CanadaPTR=CanadaPTR[1:(nrow(CanadaPTR)-1),] #remove last row
CanadaPTR[is.na(CanadaPTR)]=0 #change NA to 0
CanadaPTR=CanadaPTR[rowSums(CanadaPTR)!=0,]

#filter for common species
CanadaPTR=CanadaPTR[rowSums(CanadaPTR==0)<(ncol(CanadaPTR)/2),]
CanadaPTR[CanadaPTR<1]=1 #set PTR < 1 to 1 for non-removed species
CanadaPTR=summarise_all(CanadaPTR,median)
CanadaPTR=melt(CanadaPTR)

label = read.table("../Data/TariniLabels_edit.txt",sep="\t",h=T) #read labels
label=filter(label,Country=="CA")
data_C=merge(CanadaPTR,label,by.x="variable",by.y="ID")

SingPTR=read.table("../Data/Suppl5_SG_Final.txt",sep="\t",head=T,row.names=1,check.names=F) #read in PTR
SingPTR=SingPTR[1:(nrow(SingPTR)-1),] #remove last row
SingPTR[is.na(SingPTR)]=0 #change NA to 0
SingPTR=SingPTR[rowSums(SingPTR)!=0,] #remove row with no abundances

#less than 50% of subjects do not have PTR for the species
SingPTR=SingPTR[(rowSums(SingPTR!=0)>(ncol(SingPTR)/2)),]
SingPTR[SingPTR<1]=1
SingPTR=summarise_all(SingPTR,median)
SingPTR=melt(SingPTR)

label = read.table("../Data/TariniLabels_edit.txt",sep="\t",h=T) #read labels
label=filter(label,Country=="SG")
data_S=merge(SingPTR,label,by.x="variable",by.y="ID")

final=rbind(data_C,data_S)%>%select(-variable)
final$Country=as.character(final$Country)
final$Status=as.character(final$Status)

#beanplot
beanplot(value~Status*Country,data=final,side="both",col=list("red","green"),border="white",ll=0, ylim=c(0.9,1.4)
         ,beanlines="median",what = c(FALSE, TRUE, TRUE, FALSE), beanlinewd =0.5)
legend("topleft",fill = c("red", "green"), legend = c("Non-Recoverers", "Recoverers"), cex=0.65)

wilcox.test(filter(final,Status=="NR" & Country=="SG")$value,filter(final,Status=="R" & Country=="SG")$value,alternative="l")
wilcox.test(filter(final,Status=="NR" & Country=="CA")$value,filter(final,Status=="R"& Country=="CA")$value,alternative="l")


suppressMessages(library(plyr))
suppressMessages(library(rmutil))
suppressWarnings(suppressMessages(library(rtracklayer)))
suppressMessages(library(dplyr))

args = commandArgs(trailingOnly = TRUE)
# import rna counts for this sample
rna = read.table(gzfile(args[1]), sep=" ", header=F, stringsAsFactors=F, col.names=c("chr", "start", "ref", "alt", "genotype", "ref.matches", "alt.matches", "errors"))
# import gq data for this sample
use_default_gq = !is.na(as.integer(args[2]))
if (use_default_gq) {
  gq = as.integer(args[2])
} else {
  gq = read.table(gzfile(args[2]), sep="\t", header=F, col.names=c("CHROM", "POS", "REF", "ALT", "GQ"))
}
# import gene info from gencode
genes= as(readGFF(args[3]), "GRanges")
# what is the output directory prefix? note that it should have a trailing slash
output_dir = args[4]

# switch ref and alt counts if genotype is 1|0
rna = transform(rna, ref.matches = ifelse(genotype == "1|0", alt.matches, ref.matches), alt.matches = ifelse(genotype == "1|0", ref.matches, alt.matches))
# create unique rsID column for later merging with gq
rna$rsID = paste0(rna$chr, ":", rna$start, "_", rna$ref, "/", rna$alt)
# remove genotype col, since all rows should be heterozygotes already
rna$genotype = NULL

# process gq data
if (use_default_gq) {
  # calculate the genotype error
  gq = 10^{-(gq/10)}
} else {
  # create rsID column for later merging and get rid of other columns
  gq$rsID = paste0(gq$CHROM, ":", gq$POS, "_", gq$REF, "/", gq$ALT)
  gq$CHROM = NULL
  gq$POS = NULL
  gq$REF = NULL
  gq$ALT = NULL
  # remove any SNPs for which the genotype quality is unknown
  # and then convert it to a numeric type
  gq = gq[gq$GQ != ".",]
  gq$GQ = as.numeric(as.character(gq$GQ))
  # generate the genotype.error column
  gq$genotype.error = 10^{-(gq$GQ/10)}
  # retain only the cols that we need
  gq = gq[c("genotype.error", "rsID")]
}

# process allele specific counts
proc_counts= function(counts, genes){
  # load counts and plot proportions
  counts$N=rowSums(counts[,c("ref.matches","alt.matches")])
  counts$p= counts$ref.matches/counts$N

  # step 1 filter counts
  message("- Removing ", sum(counts$N < 10), " SNPs that have low read counts")
  counts= subset(counts, N >= 10)
  num_old_counts = nrow(counts)
  counts$end= counts$start
  counts= GRanges(counts)

  # step 2 add genes
  hits= findOverlaps(counts, genes, type = "within")
  names(counts) = NULL
  counts= as.data.frame(counts[queryHits(hits)])
  genes= as.data.frame(genes[subjectHits(hits)])
  counts$gene= genes$gene_id
  counts= counts[!duplicated(counts),]
  message("- Removed ", num_old_counts-nrow(counts), " SNPs that don't overlap a gene")
  counts
}

# process rna count data, adding gene information
message("Processing rna counts of ", nrow(rna), " SNPs...")
rna = proc_counts(rna, genes)
# save memory by removing genes. it isn't needed anymore
rm(genes)

# add genotype.error from gq to rna by JOINing on common column rsID
message("Adding genotype error to ", nrow(rna), " RNA SNPs...")
if (use_default_gq) {
  rna$genotype.error = gq
} else {
  rna = inner_join(rna, gq, by="rsID")
  # save memory by removing gq, it isn't needed anymore
  rm(gq)
}

# save the results to csv files
message("Writing ", nrow(rna), " final SNPs to file...\n")
rna_output = paste0(output_dir, "rna.csv")
write.csv(rna, rna_output, row.names = F)
system(paste("gzip", rna_output))

# if we got this far, we were probably successful
quit(status=0)


library(KEGGgraph)
library(igraph)
library(limma)
library(ggplot)

set = "GSE4183"
data(list = set, package = "KEGGdzPathwaysGEO")
sets <- get(set)
#write a function to extract required info into a list
getdataaslist = function(x) {
  x = get(x)
  exp = experimentData(x)
  dataset = exp@name
  disease = notes(exp)$disease
  dat.m = exprs(x)
  ano = pData(x)
  design = notes(exp)$design
  annotation = paste(x@annotation, ".db", sep = "")
  targetGeneSets = notes(exp)$targetGeneSets
  list = list(dataset, disease, dat.m, ano, design, annotation, targetGeneSets)
  names(list) = c("dataset", "disease", "dat.m", "ano", "design", "annotation",
                  "targetGeneSets")
  return(list)
}
dlist = getdataaslist(set)

block = dlist$ano$Block
Block = block
block = factor(Block)
group = dlist$ano$Group
G = factor(group)
force(G)
force(block)
paired = dlist$design == "Paired"
esetm = dlist$dat.m
annotation = dlist$annotation

if (paired) {
  stopifnot(length(block) == length(group))
  stopifnot(all(table(block) == 2))
}

aT1 = filteranot(esetm, group, paired, block, annotation)
esetm = esetm[rownames(esetm) %in% aT1$ID, ]
rownames(esetm) <- aT1$ENTREZID[match(rownames(esetm), aT1$ID)]

topSigNum = dim(esetm)[1]

if (paired) {
  design <- model.matrix(~0 + G + block)
  colnames(design) <- substr(colnames(design), 2, 100)
}
if (!paired) {
  design <- model.matrix(~0 + G)
  colnames(design) <- levels(G)
}
fit <- lmFit(esetm, design)
cont.matrix <- makeContrasts(contrasts = "d-c", levels = design)
fit2 <- contrasts.fit(fit, cont.matrix)
fit2 <- eBayes(fit2)
aT1 <- topTable(fit2, coef = 1, number = topSigNum)
aT1$ID <- rownames(aT1)
head(aT1)

all <-  aT1$ID
all[1:10]

de <- aT1[which(aT1$adj.P.Val<0.05),]
de <- de$ID
if(length(de) < 200){
  top <- aT1[which(aT1$P.Value<0.05),]
  top <- top[which(top$logFC>1.5),]
  de <- top$ID
}
if(length(de) < 200){
  top <- aT1[1:(nrow(aT1)*0.01),]
  de <- top$ID
}
de[1:10]

normalsamples <- dlist$ano[which(dlist$ano$Group=="c"),1]
normal <- esetm[,normalsamples]
cancersamples <- dlist$ano[which(dlist$ano$Group=="d"),1]
cancer <- esetm[,cancersamples]

normal <- t(normal)
colnames(normal) <- as.character(colnames(normal))
normal <- as.data.frame(normal)
head(normal)

cancer <- t(cancer)
colnames(cancer) <- as.character(colnames(cancer))
cancer <- as.data.frame(cancer)
head(cancer)

res <- SPFA(paths=paths,mdir=mdir,de=de,all=all,normal=normal,cancer=cancer)
head(res)

res_per <- SPFA_per(mdir=mdir,pathfilename="hsa04151.xml",normal=normal,cancer=cancer)
res_per


# This is a test/example rd file
# Array of white spheres.  Increasing Ks from left to right.
# Increasing specular exponent from bottom to top.

Display "Surface Properties"  "Screen" "rgbdouble"
Format 640 480
CameraFOV 1.7
CameraEye 0 0 500

Background 0.5 0.5 0.8
Clipping 490 510

WorldBegin

# Lights
FarLight -1 -1 -1  1.0  1.0  1.0  1.0  # Upper right

#Surface Color
Color 1.0 1.0 1.0
Surface "plastic"
Ka 0.0

# Row 0 Bottom
Specular 1.0 1.0 1.0  1

Kd 1.0
Ks 0.0

XformPush
Translate -7.5 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.8333
Ks 0.1667

XformPush
Translate -5.0 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.6667
Ks 0.3333

XformPush
Translate -2.5 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.5
Ks 0.5

XformPush
Translate 0.0 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.3333
Ks 0.6667

XformPush
Translate 2.5 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.1667
Ks 0.8333

XformPush
Translate 5.0 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.0
Ks 1.0

XformPush
Translate 7.5 -5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

# Row 1
Specular 1.0 1.0 1.0  3

Kd 1.0
Ks 0.0

XformPush
Translate -7.5 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.8333
Ks 0.1667

XformPush
Translate -5.0 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.6667
Ks 0.3333

XformPush
Translate -2.5 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.5
Ks 0.5

XformPush
Translate 0.0 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.3333
Ks 0.6667

XformPush
Translate 2.5 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.1667
Ks 0.8333

XformPush
Translate 5.0 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.0
Ks 1.0

XformPush
Translate 7.5 -2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

# Row 2
Specular 1.0 1.0 1.0  10

Kd 1.0
Ks 0.0

XformPush
Translate -7.5 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.8333
Ks 0.1667

XformPush
Translate -5.0 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.6667
Ks 0.3333

XformPush
Translate -2.5 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.5
Ks 0.5

XformPush
Translate 0.0 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.3333
Ks 0.6667

XformPush
Translate 2.5 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.1667
Ks 0.8333

XformPush
Translate 5.0 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.0
Ks 1.0

XformPush
Translate 7.5 0.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

# Row 3
Specular 1.0 1.0 1.0  32

Kd 1.0
Ks 0.0

XformPush
Translate -7.5 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.8333
Ks 0.1667

XformPush
Translate -5.0 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.6667
Ks 0.3333

XformPush
Translate -2.5 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.5
Ks 0.5

XformPush
Translate 0.0 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.3333
Ks 0.6667

XformPush
Translate 2.5 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.1667
Ks 0.8333

XformPush
Translate 5.0 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.0
Ks 1.0

XformPush
Translate 7.5 2.5 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

# Row 4 Top
Specular 1.0 1.0 1.0  100

Kd 1.0
Ks 0.0

XformPush
Translate -7.5 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.8333
Ks 0.1667

XformPush
Translate -5.0 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.6667
Ks 0.3333

XformPush
Translate -2.5 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.5
Ks 0.5

XformPush
Translate 0.0 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.3333
Ks 0.6667

XformPush
Translate 2.5 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.1667
Ks 0.8333

XformPush
Translate 5.0 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

Kd 0.0
Ks 1.0

XformPush
Translate 7.5 5.0 0
Sphere 1.0 -1.0 1.0 360.0
XformPop

WorldEnd


##%######################################################%##
#                                                          #
####             1. Organise PREDICTS data              ####
#                                                          #
##%######################################################%##

# This script takes the PREDICTS dataset and subsets it into insects only.

# clear environment
rm(list = ls())

# load libraries
library(predictsFunctions)
library(StatisticalModels)
library(sf)
library(ggplot2)
library(raster)
library(BioStatR)
library(ggthemes)

# set the data folder
datadir <- "Data/"

# where to save the final dataset
outdir <- "1_PREDICTS_PLUS_VARIABLES/"
if(!dir.exists(outdir)) dir.create(outdir)

# read in the complete PREDICTS dataset
pred.data <- readRDS(paste0(datadir, "/database.rds")) # 3250404 rows

# subset to the insects only
pred.data <- pred.data[(pred.data$Class=="Insecta"),] # 935078

### organise datasets using functions from predictsFunctions package ###

# correct sampling effort
pred.data <- CorrectSamplingEffort(pred.data)

# merge sites: this combines potential subsamples within one site
pred.data <- MergeSites(pred.data) # 826525 rows

# Calculate site level metrics
pred.sites.metrics <- SiteMetrics(pred.data, extra.cols = c("Predominant_land_use", "SSB", "SSBS")) # 7800 rows

# only interested in natural habitats plus cropland, drop other land uses #
# site level data cropland only
# sites.sub <- pred.sites.metrics[!pred.sites.metrics$Predominant_land_use %in% c("Urban", "Pasture", "Cannot decide", "Plantation forest"), ]
# sites.sub.pols <- pred.sites.metrics.pols[!pred.sites.metrics.pols$Predominant_land_use %in% c("Urban", "Pasture", "Cannot decide", "Plantation forest"), ]
# sites.sub.pc <- pred.sites.metrics.pc[!pred.sites.metrics.pc$Predominant_land_use %in% c("Urban", "Pasture", "Cannot decide", "Plantation forest"), ]

# which land uses are we interested in, I have kept plantation in here too
sites.sub <- pred.sites.metrics[!pred.sites.metrics$Predominant_land_use %in% c("Urban", "Pasture", "Cannot decide"), ]

# 5612 rows

# remove sites with NA in lat/long columns
sites.sub <- sites.sub[!is.na(sites.sub$Longitude),  ] # 5606 rows

####  Now the landscape data ####

# Changes made here, just interested in ncrop, field size, pesticide app and
# then percentage of NH, either as a variable to compare, or to look at
# buffering effect.

############################################################
#                                                          #
#       Step 2: Determine the number of crops              #
#                in each grid square                       #
#                                                          #
############################################################

# add in the number of crops for each grid square using the raster generated from the earthstat data
# convert the PREDICTS lat/longs into spatial points

## all insects dataset ##

# get coordinates for sites
sites.sub_xy <- sites.sub[, c("Longitude", "Latitude")]
sites.sub_xy <- SpatialPoints(sites.sub_xy, proj4string = CRS("+init=epsg:4326 +proj=longlat +ellps=WGS84"))

# read in the ncrop raster that was made using the earthstat data
ncrops <- raster(paste0(datadir, "/Earthstat_NCrops_newmethod.tif"))

# get the intersection values, what are the production values for each site?
sites.sub$ncrop <- extract(ncrops, sites.sub_xy, na.rm = FALSE)

# replace NAs with 0
sites.sub[is.na(sites.sub$ncrop), "ncrop"] <- 0 # 5606 rows

##%######################################################%##
#                                                          #
####             Percentage natural habitat             ####
#                                                          #
##%######################################################%##

# using reprojected percentage natural habitat raster based on Hoskins et al 2016:

# Hoskins, A.J., Bush, A., Gilmore, J., Harwood, T., Hudson, L.N., Ware, C., Williams,
# K.J., and Ferrier, S. (2016). Downscaling land-use data to provide global estimates
# of five land-use classes. Ecol. Evol.

# read in the raster
percNH <- raster(paste0(datadir,"/PercentNatural.tif"))

#
percNH <- percNH/10

# extract the dataset info for the PREDICTS sites
sites.sub$percNH <- extract(percNH, sites.sub_xy, na.rm = FALSE)

# how many NAs
nrow(sites.sub[is.na(sites.sub$percNH),]) #3

##%######################################################%##
#                                                          #
####             Pesticide application rate             ####
#                                                          #
##%######################################################%##

# read in the raster
pest_H <- raster(paste0(datadir,"/Pesticide_totalAPR_High.tif"))
pest_L <- raster(paste0(datadir,"/Pesticide_totalAPR_Low.tif"))

# extract the dataset info for the PREDICTS sites
sites.sub$pest_H <- extract(pest_H, sites.sub_xy, na.rm = FALSE)
sites.sub$pest_L <- extract(pest_L, sites.sub_xy, na.rm = FALSE)

# how many NAs
nrow(sites.sub[is.na(sites.sub$pest_H),]) #0
nrow(sites.sub[is.na(sites.sub$pest_L),]) #0

##%######################################################%##
#                                                          #
####                     Field Size                     ####
#                                                          #
##%######################################################%##
# see file "legend items" in data folder for info on coding of data in the raster.

# read in the raster
fields <- raster(paste0(datadir,"/Global Field Sizes/dominant_field_size_categories.tif"))

# extract the info for the predicts sites
sites.sub$fields <- extract(fields, sites.sub_xy, na.rm = FALSE)

# how many NAs
nrow(sites.sub[is.na(sites.sub$fields),]) #0

sites.sub$fields <- as.factor(sites.sub$fields)
plot(sites.sub$fields)

##%######################################################%##
#                                                          #
####                   Tropical sites                   ####
#                                                          #
##%######################################################%##

# get the tropical values
sites.sub$Tropical <- NA

sites.sub[sites.sub$Latitude > -23.44 & sites.sub$Latitude < 23.44, 'Tropical'] <- "Tropical"

# label the remaining as temperate
sites.sub[is.na(sites.sub$Tropical), 'Tropical'] <- "Temperate"

# set as a factor
sites.sub$Tropical <- as.factor(sites.sub$Tropical)
# levels: Temperate Tropical

table(sites.sub$Tropical)

# Temperate  Tropical
# 3481           2125

##%######################################################%##
#                                                          #
####                 Assess the dataset                 ####
#                                                          #
##%######################################################%##

# remove any rows that have NA in the variable columns
summary(is.na(sites.sub))

# remove rows with NAs for any variable of interest
sites.sub <- sites.sub[!is.na(sites.sub$percNH), ] # 3 NAs 5603 rows

# remove those sites that have "Cannot decide" as a use intensity
nrow(sites.sub[sites.sub$Use_intensity == "Cannot decide", ]) # 616
sites.sub <- sites.sub[!sites.sub$Use_intensity == "Cannot decide", ]

# nrows of dataset
nrow(sites.sub) # 4987

##%######################################################%##
#                                                          #
####      checking correlations between variables       ####
#                                                          #
##%######################################################%##

# function to create plot
panel.cor <- function(x, y, ...)
{
  par(usr = c(0, 1, 0, 1))
  txt <- as.character(format(cor(x, y), digits=2))
  text(0.5, 0.5, txt, cex = 2)
}

# save figure
pdf(file = paste0(outdir, "/Correlations_all_variables.pdf"), width =14, height = 9)

# correlations, including all nlandcovers buffers
pairs(sites.sub[ , c(22:26)],
      upper.panel=panel.cor,
      diag.panel = panel.hist,
      main = "",
      cex = 2)

dev.off()

# only high ones are the high and low pesticide (as expected) and NH with field size (-0.42).

# save the untransformed datasets including all variables
save(sites.sub, file = paste0(outdir, "/PREDICTS_dataset_inc_variables_INSECTS.rdata"))

##%######################################################%##
#                                                          #
####                Data transformations                ####
#                                                          #
##%######################################################%##

# subset columns
final.data.trans <- sites.sub

hist(final.data.trans$ncrop)
hist(final.data.trans$pest_H)
hist(final.data.trans$pest_L)
hist(final.data.trans$percNH)

hist(log(final.data.trans$pest_H + 1))
hist(log(final.data.trans$pest_L+ 1))

# log transform some of the continuous variables where they are skewed
# final.data.trans$pest_H_log <-log(final.data.trans$pest_H+1) # there are 0s so +1
# final.data.trans$pest_L_log <-log(final.data.trans$pest_L+1) # there are 0s so +1

# standardise all continuous variables

final.data.trans$percNH_RS <-scale(final.data.trans$percNH)
final.data.trans$ncrop_RS <-scale(final.data.trans$ncrop)
final.data.trans$pest_L_RS <-scale(final.data.trans$pest_L)
final.data.trans$pest_H_RS <-scale(final.data.trans$pest_H)

# get data sections for the scaling info for plotting later
percNH <- final.data.trans$percNH_RS
ncrop <- final.data.trans$ncrop_RS
pest_L<- final.data.trans$pest_L_RS
pest_H <- final.data.trans$pest_H_RS

# save the scaling values for projections
p <- c("percNH", attr(percNH, "scaled:scale"), attr(percNH, "scaled:center"))
n <- c("ncrop", attr(ncrop, "scaled:scale"), attr(ncrop, "scaled:center"))
cl <- c("pest_L", attr(pest_L, "scaled:scale"), attr(pest_L, "scaled:center"))
ch <- c("pest_H", attr(pest_H, "scaled:scale"), attr(pest_H, "scaled:center"))

values <- rbind(p, n, cl, ch)
colnames(values) <- c("variable", "scale", "centre")

#save
write.csv(values, paste0(outdir, "/Scaling_values_INSECTS.csv"), row.names = FALSE)

### organise factor levels ###

# drop unused levels of factors
final.data.trans <- droplevels(final.data.trans)

# set factor levels in the best order
final.data.trans$Use_intensity <- relevel(final.data.trans$Use_intensity, ref = "Minimal use")

# nsites per use intensity
table(final.data.trans$Use_intensity)

# set land use as character variable
final.data.trans$Predominant_land_use <- as.character(final.data.trans$Predominant_land_use)

# combine secondary land uses
final.data.trans$Predominant_land_use <- sub("Mature secondary vegetation", "Secondary vegetation", final.data.trans$Predominant_land_use)
final.data.trans$Predominant_land_use <- sub("Intermediate secondary vegetation", "Secondary vegetation", final.data.trans$Predominant_land_use)
final.data.trans$Predominant_land_use <- sub("Young secondary vegetation", "Secondary vegetation", final.data.trans$Predominant_land_use)
final.data.trans[final.data.trans$Predominant_land_use == "Secondary vegetation (indeterminate age)", 'Predominant_land_use'] <- "Secondary vegetation"

table(final.data.trans$Predominant_land_use)

# set factor levels of predominant land use
final.data.trans$Predominant_land_use <- factor(final.data.trans$Predominant_land_use,
                                                levels=c("Primary vegetation","Secondary vegetation", "Plantation forest", "Cropland"))

# nsites per land use
table(final.data.trans$Predominant_land_use)

pdf(file = paste0(outdir, "/Correlations_final_variables.pdf"), width =9, height = 9)
# correlations of final set of variables - transformed
pairs(final.data.trans[ , c(26:31)],
      upper.panel=panel.cor,
      diag.panel = panel.hist,
      main = "",
      cex.labels = 1.3)

dev.off()

# edit field size names
final.data.trans$fields <- as.character(final.data.trans$fields)
final.data.trans$fields[final.data.trans$fields == "0"] <- "No fields"
final.data.trans$fields[final.data.trans$fields == "3502"] <- "Very large"
final.data.trans$fields[final.data.trans$fields == "3503"] <- "Large"
final.data.trans$fields[final.data.trans$fields == "3504"] <- "Medium"
final.data.trans$fields[final.data.trans$fields == "3505"] <- "Small"
final.data.trans$fields[final.data.trans$fields == "3506"] <- "Very small"

table(final.data.trans$fields)

final.data.trans$fields <- factor(final.data.trans$fields, levels = c("No fields", "Very small", "Small", "Medium", "Large"))

# transform abundance
final.data.trans$logAbun <- log(final.data.trans$Total_abundance + 1)

# save transformed dataset
save(final.data.trans, file = paste0(outdir, "/PREDICTS_dataset_TRANS_INSECTS.rdata"))

##%######################################################%##
#                                                          #
####                 Get data summaries                 ####
#                                                          #
##%######################################################%##

# get the number of studies, sites, etc for the paper

length(unique(final.data.trans$SS)) # 248 studies
nrow(final.data.trans) # 4987 sites

##%######################################################%##
#                                                          #
####            Plot points on a global map             ####
#                                                          #
##%######################################################%##

# extract the PREDICTS points
plot_data <- final.data.trans[, c("SS", "SSBS", "Longitude", "Latitude")]

# look at nsites per study
nsites <- as.matrix(table(plot_data$SS))
nsites <- cbind(rownames(nsites), nsites[,1])

# Get the lat/long per study
lon <- unlist(apply(nsites, MARGIN = 1, FUN = function(x){plot_data[plot_data$SS == x[1], 3][1]}))
lat <- unlist(apply(nsites, MARGIN = 1, FUN = function(x){plot_data[plot_data$SS == x[1], 4][1]}))

nsites <- cbind(nsites, lon, lat)

nsites <- as.data.frame(nsites)

colnames(nsites) <- c("SS", "nsites", "lon", "lat")

nsites$nsites <- as.numeric(as.character(nsites$nsites))
nsites$lon <- as.numeric(as.character(nsites$lon))
nsites$lat <- as.numeric(as.character(nsites$lat))

# plot the raster in ggplot
map.world <- map_data('world')

# plot of predicts sites across biomes including size per n sites
ggplot()+
  geom_map(data=map.world, map=map.world,
           aes(x=long, y=lat, group=group, map_id=region),
           fill= c("#7CCD7C"), colour= "transparent", size=0.2, alpha = 0.5) +
  #geom_sf(data = ecobio,  aes(fill = BIOME), alpha = 1, col = NA) +
  geom_point(data = nsites, aes(x = lon, y = lat, size = nsites), col = c("#0F0F0F"), alpha = 0.5) +
  #geom_polygon(data = wwfbiomes, x = )
  theme(panel.grid.major = element_line(colour = "transparent"),
        panel.background = element_blank(),
        legend.position = "right",
        legend.title = element_blank(),
        legend.key = element_blank(),
        text = element_text(size = 16),
        axis.ticks = element_blank(),
        axis.text = element_blank()) +
  xlab("") +
  ylab("") +
  scale_size_continuous(range = c(0.2, 5), breaks = c(1, 10, 50, 100, 200)) +
  guides(fill=guide_legend(nrow=7,byrow=TRUE), size = guide_legend(nrow = 7, byrow = T))

ggsave(filename = paste0(outdir, "/MAP_Predicts_points_biome_INSECTS.pdf"),
       plot = last_plot(),
       width = 8,
       height = 6)


library(rbi, warn.conflicts=FALSE)
library(rbi.helpers)
library(magrittr, warn.conflicts=FALSE)
suppressPackageStartupMessages(library(tidyverse))
library(pander)
library(lubridate, warn.conflicts=FALSE)

save_file <- function(libbi_data, file_path){
    out <- tryCatch(
      {
        message("Saving rds file.")
        save_libbi(libbi_data, name=file_path)
      },
      error=function(cond){
        message("Save rds failed with error:")
        message(cond)
      },
      finally={
        invisible()
      }
  )
    return(out)
}

# options(echo=TRUE) # if you want see commands in output file
args <- commandArgs(trailingOnly=TRUE)
print(args)
# trailingOnly=TRUE means that only your arguments are returned, check:
print(commandArgs(trailingOnly=FALSE))
#
# end_date should be as.Date(args[1], format='%m-%d')
end_date <- args[1]
state_abbr <- args[2]
iter <- args[3]
epi_model <- args[5]

if (state_abbr == "TN"){
    population <- 6833174
    state <- 'Tennessee'
} else {
    population <- 19453561
    state <- 'New York'
}

print(state_abbr)
print(end_date)
path <- '/home/cades/volume/covid/'

in_file = paste(path, end_date, '/', state, '-covid.txt', sep="")
print(paste("Reading data from ", in_file, sep=""))

v <- read.csv(in_file, sep="\t", header=FALSE) %>%
  rowSums()

y <- data.frame(value=v) %>%
  mutate(time = seq(7, by=7, length.out=n())) %>%
  dplyr::select(time, value)

min_particles <- 5000

input_lst <- list(N=population)
end_time <- max(y$time)
obs_lst <- list(y=y %>% dplyr::filter(time<=end_time))

if (args[4] == 'vary'){
    model_file <- paste(epi_model, "_vary_p.bi", sep='')
} else {
    model_file <- paste(epi_model, "_const_p.bi", sep='')
}

path <- ### your path here ###
model_path <- paste(path, model_file, sep="")
print(paste("Reading model from ", model_path, sep=""))
bi_model <- libbi(model_path)

posterior <- sample(bi_model, end_time=end_time, input=input_lst,
                    obs=obs_lst, nsamples=5000, nparticles=min_particles,
                    proposal='prior', nthreads=32, thin=1) %>%
  adapt_proposal(min=0.125, max=0.4) %>%
  sample(nsamples=50000)

print("Saving Data files.")
save(sample_obs, posterior,  file=paste(path, state_abbr, '_', epi_model, '_', end_date, '-', iter, '.RData', sep=""))
save_file(posterior, name=paste(path, state_abbr, '_', epi_model, '_', end_date, '.RDS', sep=""))

#####  make predictions  ######

print("Making predictions...")

pred_end <- end_time + (7 * 4)
pred_start <- end_time - (4 * 7)
pred_bi <- predict(posterior, start_time=pred_start, end_time=pred_end,
                   output_every=7, target='prediction', nsamples=25000,
                   with=c("transform-obs-to-state"))

print("Saving Data files.")
save(pred_bi, file=paste(path, state_abbr, '_', epi_model, '_preds-onemonth_', epi_model, '_', '.RData', sep=""))
save_file(pred_bi, name=paste(path, state_abbr, '_', epi_model, '_preds-onemonth_', epi_model, '_', end_date, '.RDS', sep=""))


#!/bin/env Rscript
#
# Copyright (c) 2009-2020, Broad Institute, Inc. All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# * Redistributions of source code must retain the above copyright notice, this
#   list of conditions and the following disclaimer.
#
# * Redistributions in binary form must reproduce the above copyright notice,
#   this list of conditions and the following disclaimer in the documentation
#   and/or other materials provided with the distribution.
#
# * Neither the name Broad Institute, Inc. nor the names of its
#   contributors may be used to endorse or promote products derived from
#   this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
library(tools)

args <- commandArgs(TRUE)
if (length(args) < 2) {
    cat("Usage: tranches.r <input> <output_prefix> [TITV] [sensitivity] [suppressLegend]")
    quit(status=1)
}

tranchesFile = args[1]
outputPrefix = args[2]
targetTITV = as.numeric(args[3])
targetSensitivity = as.numeric(args[4])
suppressLegend = !is.na(args[5])

if (is.na(targetTITV)) {
    targetTITV = 2
}

# -----------------------------------------------------------------------------------------------
# Useful general routines
# -----------------------------------------------------------------------------------------------

MIN_FP_RATE = 0.001  # 1 / 1000 is min error rate

titvFPEst <- function(titvExpected, titvObserved) {
    max(min(1 - (titvObserved - 0.5)/(titvExpected - 0.5), 1), MIN_FP_RATE)
}

titvFPEstV <- function(titvExpected, titvs) {
    sapply(titvs, function(x) titvFPEst(titvExpected, x))
}

nTPFP <- function(nVariants, FDR) {
    return(list(TP = nVariants * (1 - FDR/100), FP = nVariants * (FDR/100)))
}

leftShift <- function(x, leftValue = 0) {
    r = rep(leftValue, length(x))
    for (i in 1:(length(x) - 1)) {
        # print(list(i=i))
        r[i] = x[i + 1]
    }
    r
}

# -----------------------------------------------------------------------------------------------
# Tranches plot
# -----------------------------------------------------------------------------------------------
data2 = read.table(tranchesFile, sep = ",", head = T)
# data2 = data2[order(data2$novelTiTv, decreasing = F), ]
# data2 = data2[order(data2$FDRtranche, decreasing=T),]
data2 = data2[order(data2$truthSensitivity, decreasing = T), ]
cols = c("cornflowerblue", "cornflowerblue", "darkorange", "darkorange")
density = c(20, -1, -1, 20)
outfile = paste(outputPrefix, ".pdf", sep = "")
pdf(outfile, height = 5, width = 8)
par(mfrow = 1:2)
par(mar = c(5, 5, 4, 2) + 0.1)
novelTiTv = c(data2$novelTITV, data2$novelTiTv)
alpha = 1 - titvFPEstV(targetTITV, novelTiTv)
# print(alpha)

numGood = round(alpha * data2$numNovel)

# numGood = round(data2$numNovel * (1-data2$targetTruthSensitivity/100))
numBad = data2$numNovel - numGood

numPrevGood = leftShift(numGood, 0)
numNewGood = numGood - numPrevGood
numPrevBad = leftShift(numBad, 0)
numNewBad = numBad - numPrevBad

d = matrix(c(numPrevGood, numNewGood, numNewBad, numPrevBad), 4, byrow = TRUE)
# print(d)
barplot(d/1000, horiz = TRUE, col = cols, space = 0.2, xlab = "Number of Novel Variants (1000s)",
    density = density, cex.axis = 1.25, cex.lab = 1.25)  # , xlim=c(250000,350000))
# abline(v= d[2,dim(d)[2]], lty=2) abline(v= d[1,3], lty=2)
if (!suppressLegend) {
    legend("topright", c("Cumulative TPs", "Tranch-specific TPs", "Tranch-specific FPs",
        "Cumulative FPs"), fill = cols, density = density, bg = "white", cex = 0.8)
}

mtext("Ti/Tv", 2, line = 2.25, at = length(data2$targetTruthSensitivity) * 1.2, las = 1,
    cex = 1)
mtext("truth", 2, line = 0, at = length(data2$targetTruthSensitivity) * 1.2, las = 1,
    cex = 1)
axis(2, line = -1, at = 0.7 + (0:(length(data2$targetTruthSensitivity) - 1)) * 1.2,
    tick = FALSE, labels = data2$targetTruthSensitivity, las = 1, cex.axis = 1)
axis(2, line = 1, at = 0.7 + (0:(length(data2$targetTruthSensitivity) - 1)) * 1.2,
    tick = FALSE, labels = round(novelTiTv, 3), las = 1, cex.axis = 1)

# plot sensitivity vs. specificity
sensitivity = data2$truthSensitivity
if (!is.null(sensitivity)) {
    # specificity = titvFPEstV(targetTITV, novelTiTv)
    specificity = novelTiTv
    plot(sensitivity, specificity, type = "b", col = "cornflowerblue", xlab = "Tranche truth sensitivity",
        ylab = "Specificity (Novel Ti/Tv ratio)")
    abline(h = targetTITV, lty = 2)
    abline(v = targetSensitivity, lty = 2)
    # text(max(sensitivity), targetTITV-0.05, labels='Expected novel Ti/Tv', pos=2)
}

dev.off()

if (exists("compactPDF")) {
    compactPDF(outfile)
}

res <- as.data.frame(t(d))
names(res) <- c("CumTPs", "TranchSpecificTPs", "TranchSpecificFPs", "CumFPs")
rownames(res) <- colnames(d)
res$totalNovel <- res$CumTPs + res$CumFPs
res$novelTiTv <- novelTiTv
res$tranches <- sensitivity

outfile = paste(outputPrefix, ".txt", sep = "")
write.table(res, file = outfile, col = T, row = F, qu = F, sep = "\t")


library(readr)
library(xgboost)
library(e1071)

set.seed(1)

cat("reading the train and test data\n")
#train <- read_csv("../../data/train.csv-1")
#test  <- read_csv("../../data/test.csv-1")
train <- read_csv("../../data/train.csv")
test  <- read_csv("../../data/test.csv")

#Drop Features with All NA
lstDrp = c()
j = 1
for (i in 2:ncol(test))
{
	if (sum(is.na(train[, i])) == nrow(train))
	{
		lstDrp[j] = i
		j = j + 1
		#train[, i] = NULL
		cat("Dropped: ", i, "\n")
	}
}

train[lstDrp] = list(NULL)
test[lstDrp] = list(NULL)
#cat("Dropped lst: ", lstDrp, "\n")
cat("New Din Train: ", dim(train), "\n")
cat("New Dim Test: ", dim(test), "\n")

#feature.names <- names(train)[2:ncol(train)-1]
mrmr_feature_index = c(105,963,789,710,5,1415,919,879,497,1120,412,187,674,177,620,77,73,724,1540,1023,534,95,1093,226,154,498,59,1116,33,162,878,713,629,1569,145,1097,52,207,1849,618,505,300,962,109,1073,625,79,49,816,156,129,1557,160,1027,1251,499,603,36,1098,70,53,51,1004,1092,1565,101,965,75,399,61,1119,159,1024,125,1554,14,1,1382,164,209,68,1522,766,152,66,961,34,1380,716,97,630,87,1541,1762,179,1117,126,1638,37,1032,150,110,966,50,69,830,787,56,1014,799,141,615,228,166,67,668,35,16,613,1112,208,1040,60,1559,1856,94,80,172,832,127,279,1543,586,500,1118,76,201,938,78,169,144,1028,890,1363,71,174,1381,54,1257,1858,15,1626,62,852,133,1558,86,1037,948,128,230,1327,206,6,687,84,96,170,731,1542,1099,83,1791,628,176,1379,81,117,506,85,804,788,7,1847,134,951,1134,229,113,1219,1021,135,72,865,1100,57,1774,13,88,55,63,1025,1631,681,121,1376,1855,89,111,839,825,82,908,102,686,791,744,860,136,233,1358,58,896,1041,137,626,142,582,64,1695,1848,1145,112,1770,1033,118,1639,17,1359,227,777,835,65,794,838,1618,143,909,1870,939,585,120,1833,1851,1778,1029,882,1701,103,1384,1231,688,746,119,780,1793,104,796,1867,836,784,1630,1326,1372,875,1143,1850,700,857,654,1761,851,769,785,1789,689,578,786,683,1139,1357,1625,877,833,797,1345,759,1853,1815,756,1146,608,1732,837,1875,699,1823,552,1595,1331,802,1895,745,581,1619,1822,1132,728,885,1640,1854,1814,1869,606,1731,792,1342,1094,801,1616,1788,1872,888,1852,579,653,1777,1894,1332,1624,1769,1868,874,1773,1610,607,1343,1877,1611,682,1790,1893,881,1792,1878,1244,602,1368,1889,887,1344,1891,1881,1362,891,605,1866,1238,598,684,1237,1892,609,1241,1871,1370,889,1760,1885,1297,1874,900,600,1240,1876,590,1807,952,599,1295,893,1890,1797,577,953,610,1242,1883,1785,1873,591,1361,1806,1884,1300,1311,1880,1805,1221,1821,1886,1299,1804,1879,583,1365,1818,1887,1243,1819,936,1882,1776,1317,604,1888,1796,1312,1763,685,1245,1373,1772,576,1369,1765,1220,1768,1239,601,1784,1799,1350,1107,575,1766,1366,1787,574,1798,1367,1347,1782,1809,1294,1817,1764,1364,1268,680,1351,1783,1795,584,1816,1280,1808,589,1803,1346,1794,1272,1801,588,1802,1292,1800,1293,1349,1276,1236,1348,1234,1235,580,1316,1324,1306,1322,1323,1313,1320,1310,933,1314,587,1305,1315,1308,1307)

mrmr_feature_index = mrmr_feature_index + 1
feature.names <- names(train)[mrmr_feature_index]
cat("FEatures Used: ", feature.names, "\n")

cat("assuming text variables are categorical & replacing them with numeric ids\n")
for (f in feature.names) {
	  if (class(train[[f]])=="character") {
		      levels <- unique(c(train[[f]], test[[f]]))
    train[[f]] <- as.integer(factor(train[[f]], levels=levels))
	    test[[f]]  <- as.integer(factor(test[[f]],  levels=levels))
	  }
}

#cat("replacing missing values with -1\n")
#train[is.na(train)] <- -1
#test[is.na(test)]   <- -1

cat("replace missing values with mean \n")

#Impute Numerical Variables with Mean and Categorical with Mode
for (i in 2:ncol(test))
{
	#if(class(train[, i]) == "character")
	#{
	#	mode(train[, i])
	#}

	fMean = mean(train[!is.na(train[, i]), i])
	#cat("mean", i, ":", fMean, "\n")
	train[is.na(train[, i]), i] = fMean
	test[is.na(test[, i]), i] = fMean

	if(is.na(train[,i]) == TRUE)
	{
		cat("NA", i, " ", feature.names[i], "\n")
	}

}

#Write Data to file
#write.csv(train[, 2:ncol(train)], file = 'Processed_Train.csv')

#return(train)
#if (sum(!is.na(train)) ) { cat("NAN ", sum(!is.na(train)), "\n")}

cat(dim(train), "\n", dim(test), "\n")
#"
###############################################################
#Prediction on Training Data
if (FALSE) {
gc()
cat("sampling train to get around 8GB memory limitations -1\n")
train_sample_row = sample(nrow(train), 45000)
#left_train_samples = train[-c(train_sample_row), ]
train_1 <- train[train_sample_row, ]
gc()

#Do train on the 1st sample
cat("training a XGBoost classifier 1 \n")
clf1 <- xgboost(data = data.matrix(train_1[,feature.names]),
               label       = train_1$target,
               nrounds     = 25,
               objective   = "binary:logistic",
               eval_metric = "auc")

rm(train_1)
gc()

# Predict Left over training samples
left_train_samples = train[-c(train_sample_row), ]
train_pred1 = data.frame(ID=left_train_samples$ID)
for (rows in split(1:nrow(left_train_samples), ceiling((1:nrow(left_train_samples))/10000))) {

  train_pred1[rows, "target"] <- predict(clf1, data.matrix(left_train_samples[rows,feature.names]))
}
rm(clf1)
#********************************************************************
#Do train on new sample and predict 1st sample
gc()
cat("sampling train to get around 8GB memory limitations -2\n")
#cat(nrow(left_train_samples), "\n")
train_sample_new_row = sample(nrow(left_train_samples), 45000)
train_2 <- left_train_samples[train_sample_new_row, ]
rm(left_train_samples)
gc()
test_1 = train[train_sample_row, ]

#Do train on the 1st sample
cat("training a XGBoost classifier 2 \n")
clf2 <- xgboost(data = data.matrix(train_2[,feature.names]),
                label       = train_2$target,
                nrounds     = 25,
                objective   = "binary:logistic",
                eval_metric = "auc")
rm(train_2)
gc()
# Predict Left over training samples
train_pred2 = data.frame(ID=test_1$ID)
for (rows in split(1:nrow(test_1), ceiling((1:nrow(test_1))/10000))) {

  train_pred2[rows, "target"] <- predict(clf2, data.matrix(test_1[rows,feature.names]))

}
#Write Training Predictions to File
write_csv(rbind(train_pred1, train_pred2), "pred_training_logistic.csv")
rm(train_pred1, train_pred2, test_1, clf2)
gc()

}

###################################################################
#Final Prediction Phase
#cat("sampling train to get around 8GB memory limitations -3\n")
#train <- train[sample(nrow(train), 50000),]
gc()

cat("training a XGBoost classifier\n")
clf <- xgboost(data = data.matrix(train[,feature.names]),
			   label       = train$target,
			   nrounds     = 20,
			   objective   = "binary:logistic",
			   eval_metric = "auc")
#			   missing	   = NAN )

if(FALSE){
#SVM Learing
cat("Start SVM\n")
x_train = train[,feature.names]
y_train = train$target
svm_model = svm(x_train, y_train, scale = TRUE, type = 'C-classification', kernel = "radial", gamma =  1 / ncol(x_train),
                cost = 1, nu = 0.5, class.weights = NULL, cachesize = 1000, tolerance = 0.001, epsilon = 0.1,
                shrinking = TRUE, cross = 5, probability = FALSE, fitted = TRUE)

print(summary(svm_model))
svm_submission <- data.frame(ID=test$ID)
svm_submission$target = NA
}

cat("making predictions in batches due to 8GB memory limitation\n")
submission <- data.frame(ID=test$ID)
submission$target <- NA

for (rows in split(1:nrow(test), ceiling((1:nrow(test))/10000))) {

	    submission[rows, "target"] <- predict(clf, data.matrix(test[rows,feature.names]))

	    #SVM Prediction
	    #svm_submission[rows, "target"] <- predict(svm_model, data.matrix(test[rows,feature.names]))
}

cat("saving the submission file\n")
write_csv(submission, "xgboost_submission-fs.csv")
#write_csv(svm_submission, "svm_submission.csv")
#"


setwd(dataDir)
source("../scripts/DNAm/FunctionsForBrainCellProportionsPrediction.r")
library(minfi)
library(genefilter)
library(rafalib)
library(bigmelon)

## parameters
probeSelect = "any" ## options "both" (select equal number of probes associated with hyper and hypo methylation) or "any" (just select probes based on significance regardless of direction)
cellTypes = c("GABAneurons","GLIA","GLUneurons", "NeuN","Sox10","IRF8")
cellTypes<-sort(cellTypes)
numProbes<-100

gfile.epi<-openfn.gds("gdsFiles/epigabaNorm.gds")
gfile.bdr<-openfn.gds("gdsFiles/bdrNorm.gds")

QCmetrics.epi<-read.gdsn(index.gdsn(gfile.epi, "QCdata"))
QCmetrics.bdr<-read.gdsn(index.gdsn(gfile.bdr, "QCdata"))
pheno.epi<-as.data.frame(QCmetrics.epi[,c("Basename", "Individual_ID", "Cell.type")], stringsAsFactors = FALSE)
pheno.epi$Cell.type<-gsub(" ", "", pheno.epi$Cell.type)
pheno.bdr<-as.data.frame(QCmetrics.bdr[,c("Basename", "Indidivual.ID", "Cell.type")], stringsAsFactors = FALSE)
pheno.bdr$Cell.type<-gsub(" \\+ve", "", pheno.bdr$Cell.type) ## need to remove the "+" and "-"
pheno.bdr$Cell.type<-gsub(" -ve", "", pheno.bdr$Cell.type) ## need to remove the "+" and "-"

colnames(pheno.bdr)<-colnames(pheno.epi)

## use normalised within cell types

norm.epi<-read.gdsn(index.gdsn(gfile.epi, "celltypenormbeta"))
rownames(norm.epi)<-rownames(gfile.epi)
colnames(norm.epi)<-colnames(gfile.epi)
norm.bdr<-read.gdsn(index.gdsn(gfile.bdr, "celltypenormbeta"))
rownames(norm.bdr)<-rownames(gfile.bdr)
colnames(norm.bdr)<-colnames(gfile.bdr)

probes<-intersect(rownames(norm.epi), rownames(norm.bdr))

norm.epi<-norm.epi[probes,]
norm.bdr<-norm.bdr[probes,]

norm.all<-cbind(norm.epi, norm.bdr)

pheno.all<-rbind(pheno.epi, pheno.bdr)
pheno.all<-pheno.all[ match(colnames(norm.all), pheno.all$Basename),]

pheno.all$Cell.type<-as.factor(pheno.all$Cell.type)

cellInd<-pheno.all$Cell.type

## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=norm.all, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataForCellCompEstimationAll.rdata")

## exclude NeuN
cellTypes = c("GABAneurons","GLIA","GLUneurons","Sox10","IRF8")
## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=norm.all, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataForCellCompEstimationAllNoNeuN.rdata")

## exclude NeuN, GLIA
cellTypes = c("GABAneurons","GLUneurons","Sox10","IRF8")
## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=norm.all, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataForCellCompEstimationFourPositiveFractions.rdata")

## exclude NeuN, GLIA, include Double Negative
cellTypes = c("GABAneurons","GLUneurons","Sox10","IRF8", "Double")
## select probes as basis of algorithm
compData <- pickCompProbes(rawbetas=norm.all, cellInd=cellInd, cellTypes = cellTypes, numProbes = numProbes, probeSelect = probeSelect)
braincelldata <- compData$coefEsts
save(braincelldata, file = "RefDataForCellCompEstimationFourPositiveFractionsDNeg.rdata")


# 2020-03-12-hatch-final-data-merged

# Let's load some packages and the data set.

library(ggplot2)
library(leaps)
library(cowplot)
dat <- read.csv(file = "metrology-compiled/2020-03-12-hatch-data-merged.csv", header = T)
str(dat)

## Biom + Metadata

# Intall:
# BiocManager::install("phyloseq")
# Load libraries
library(phyloseq)
#library(dada2)
library(ggplot2)
library(RColorBrewer)
library(vegan)

# Here we'll load in the microbial data.

# Import sequence processing table and check it out
# How many sequences were retained at each step?
track = readRDS("microbial-compiled/track.rds")
track
# Import final otu table
OTUs = readRDS("microbial-compiled/OTUtab.nochim.rds")
# Change rows and columns so taxa are rows
OTUs = t(OTUs)
# Import as phyloseq object table
otutab = otu_table(OTUs, taxa_are_rows=TRUE)
head(otutab)
# Look at lowest-abundance samples
head(sort(sample_sums(otutab)))
name = row.names(otutab)[1]
name
hist(nchar(row.names(otutab)))
colnames(otutab)
# The sample names have suffixes appended to them - we just want sample IDs
# Get names
names = colnames(otutab)
# Remove last 17 characters
newnames = gsub('.{17}$', '', names)
# Check out names
newnames

# Assign new names to samples
colnames(otutab) = newnames

# Same thing if we wanted to simplify OTU names to IDs
# Instead of sequences (although that's useful)
otunames=row.names(otutab)
length(otunames)
newotunames = paste("OTU",rep(1:length(otunames)),sep="")
head(newotunames)
row.names(otutab) = newotunames
head(otutab)

# Cut off the sampling ID to match metadata
for (i in 1:length(colnames(otutab))){
  newname = strsplit(colnames(otutab[i]),"_")[[i]][1]
  colnames(otutab)[i]=newname
}

# Import sample data
samdat = read.csv("metrology-compiled/2020-03-12-hatch-data-merged-as-metadata.csv", header=T)
# samdat$Sample.ID = as.character(samdat$Sample.ID)
# samdat$Sample.ID[1:9] = paste("00",samdat$Sample.ID[1:9],sep="")
# samdat$Sample.ID[10:length(samdat$Sample.ID)] = paste("0",samdat$Sample.ID[10:length(samdat$Sample.ID)],sep="")

# Check we have all the same sample names now
samdat$Sample.ID[1:65] == colnames(otutab)[1:65]
samdat$Sample.ID[66:125] == colnames(otutab)[66:125]
samdat = sample_data(samdat)

# Exponentiate all pH values
samdat$DNA.Extr.Hplus.After.C1 <- 10^-samdat$DNA.Extr.pH.After.C1
samdat$DNA.Extr.Hplus.After.C2 <- 10^-samdat$DNA.Extr.pH.After.C2
samdat$Lab.CO2.Hplus.one2one <- 10^-samdat$Lab.CO2.pH.one2one
samdat$Lab.CO2.Hplus.one2two <- 10^-samdat$Lab.CO2.pH.one2two
samdat$Lab.CO2.Hplus.one2three <- 10^-samdat$Lab.CO2.pH.one2three
samdat$Lab.CO2.Hplus.one2four <- 10^-samdat$Lab.CO2.pH.one2four
samdat$High.CO2.Hplus.one2one <- 10^-samdat$High.CO2.pH.one2one
samdat$High.CO2.Hplus.one2two <- 10^-samdat$High.CO2.pH.one2two
samdat$High.CO2.Hplus.one2three <- 10^-samdat$High.CO2.pH.one2three
samdat$High.CO2.Hplus.one2four <- 10^-samdat$High.CO2.pH.one2four

row.names(samdat) = samdat$Sample.ID

# Create phyloseq object
ps = phyloseq(otu_table=otutab,sample_data=samdat)
ps = subset_samples(ps, Sample.ID != "049-W3-Compost" & Sample.ID!="004-K2-Muck" & Sample.ID!="028-S-0-30" & Sample.ID!="029-S-30-60")

# Melt
ps.melt = psmelt(ps)
ps.melt

head(ps.melt)

hist(sample_sums(ps))

# Relative abundances
ps.norm = transform_sample_counts(ps,function(x) x/sum(x))
head(otu_table(ps.norm))
sample_sums(ps.norm)
# Looks good

colnames(sample_data(ps.norm))

# Spooner Vs. Wisconsin

ps.wisc <- subset_samples(ps, Study=="Wisconsin")
ps.spoon <- subset_samples(ps, Study=="Spooner")

ps.norm.wisc <- subset_samples(ps.norm, Study=="Wisconsin")
ps.norm.spoon <- subset_samples(ps.norm, Study=="Spooner")

# [...]


source("lib/libraries.r")

#1 tabela-brezposelnost po statističnih regijah
brezposelnost.regije <- read.csv2(file="podatki/brezposelnost_po_statisticnih_regijah.csv", header=TRUE, skip = 3, fileEncoding="Windows-1250", dec = '.',
                                  col.names = c('leto', 'regija', 'stopnja_aktivnosti', "stopnja_delovne_aktivnosti", 'stopnja_brezposelnosti', 'delovna_aktivnost_glede_na_starostno_skupino'))

graf_regije <- brezposelnost.regije[,-6]
graf_regije <- graf_regije[,-4]
graf_regije <- graf_regije[,-3]

  #tabela za zemljevid 2010
brezposelnost.2010 <-filter(graf_regije, leto == '2010')

  #tabela za zemljevid 2018
brezposelnost.2018 <- filter(graf_regije, leto == '2018')

#2.tabela-brezposelnost po trajanju iskanja dela za celotno Slovenijo
trajanje <- read.csv2(file="podatki/trajanje.csv", header=TRUE, skip = 2, na=c('N'), fileEncoding="Windows-1250",
                                   col.names = c("nekaj","cas", "spol", "leto",  "skip", "brezposelnost"))

trajanje <- trajanje[,-5]
trajanje <- trajanje[,-3]
trajanje <- trajanje[,-1]

#3.tabela-brezposelnost v Sloveniji(ja)
slovenija <- read.csv2(file="podatki/slovenija.csv", header=TRUE, skip = 1, fileEncoding="Windows-1250",
                       col.names = c("kohezj", "skupine", "spol", "leto", "brezposelnost"))

slovenija <- slovenija[,-3]
slovenija <- slovenija[,-2]
slovenija <- slovenija[,-1]
#slovenija <- transform(slovenija, brezposelnost = (brezposelnost * 1000))

#4.tabela-brezposelnost glede na stopnjo dosežene izobrazbe
izobrazba <- read.csv2(file="podatki/izobrazba.csv", header=TRUE, skip = 2, fileEncoding="Windows-1250",
                                     col.names = c("leto", "Kohezijska_regija", "Spol", "izobrazbe",
                                                   "meritve", "brezposelnost"))
izobrazba <- izobrazba[, -5]
izobrazba <- izobrazba[, -3]
izobrazba <- izobrazba[, -2]

#5.tabela- Delovno sposobni glede na aktivnost in mere aktivnosti po starostnih skupinah in spolu za celotno Slovenijo
aktivnost <- read.csv2(file="podatki/aktivnosti.csv", header=TRUE, skip = 2,
                           col.names = c("regija", "starostna_skupina","spol", "leto", "meritve", "delovno_sposobni"), dec = '.', fileEncoding="Windows-1250")

aktivnost<-aktivnost[,-1]
aktivnost$delovno_sposobni <- as.numeric(aktivnost$delovno_sposobni)
aktivnost$leto <- as.numeric(aktivnost$leto)


###############################################################
#make heatmap for genes in each category of WebGestalt result
###############################################################

usePearsonInHCA<-TRUE
hmcols <- colorRampPalette(c("green", "black", "red"))(256)
maxCategory=20 #max 20 heatmap (categories)
if (!exists("fileTypePrefix")) { #to add in file name, GOID+fileTypePrefix.png
  fileTypePrefix="_DESeq2-vsd-heatmap"
}

library(heatmap3)

#function from DESeq2.r
drawHCA<-function(prefix, rldselect, ispaired, designData, conditionColors, gnames, outputFormat,
                  main=paste0("Hierarchical Cluster Using ", nrow(rldselect), " Genes"),
                  labRow=ifelse(nrow(rldselect)<=30,row.names(rldselect),NA),
                  fileTypePrefix="_DESeq2-vsd-heatmap"){
  genecount<-nrow(rldselect)
  showRowDendro = genecount <= 50
  if(genecount > 2){
    cexCol = max(1.0, 0.2 + 1/log10(ncol(rldselect)))
    if(ispaired){
      htColors<-rainbow(length(unique(designData$Paired)))
      gsColors<-as.matrix(data.frame(Group=conditionColors, Sample=htColors[designData$Paired]))
    }else{
      gsColors = conditionColors;
    }
    if (genecount<=30) {
      #labRow=row.names(rldselect)
      margins=c(12,8)
    } else {
      #labRow=NA
      margins=c(12,5)
    }

    filePrefix<-paste0(prefix, fileTypePrefix)
    for(format in outputFormat){
      openPlot(filePrefix, format, 10, 10, 3000, 3000, "HCA")
      if(usePearsonInHCA){
        heatmap3(rldselect,
                 col = hmcols,
                 ColSideColors = gsColors,
                 margins=margins,
                 scale="r",
                 labRow=labRow,
                 showRowDendro=showRowDendro,
                 main=main,
                 cexCol=cexCol,
                 useRaster=FALSE,
                 legendfun=function() showLegend(legend=paste0("Group ", gnames), col=c("red","blue"),cex=1.0,x="center"))
      }else{
        heatmap3(rldselect,
                 col = hmcols,
                 ColSideColors = gsColors,
                 margins=margins,
                 scale="r",
                 distfun=dist,
                 labRow=labRow,
                 showRowDendro=showRowDendro,
                 main=main,
                 cexCol=cexCol,
                 useRaster=FALSE,
                 legendfun=function() showLegend(legend=paste0("Group ", gnames), col=c("red","blue"),cex=1.0,x="center"))
      }
      dev.off()
    }
  }
}

openPlot<-function(filePrefix, format, pdfWidth, pdfHeight, otherWidth, otherHeight, figureName){
  fileName<-paste0(filePrefix, ".", tolower(format))
  if(format == "PDF"){
    pdf(fileName, width=pdfWidth, height=pdfHeight, useDingbats=FALSE)
  }else if(format == "TIFF"){
    tiff(filename=fileName, width=otherWidth, height=otherHeight, res=300)
  }else {
    png(filename=fileName, width=otherWidth, height=otherHeight, res=300)
  }
  cat("saving", figureName, "to ", fileName, "\n")
}

annoFiles<-read.table(parSampleFile1, header=F, sep="\t", stringsAsFactors = F)
deseq2Files<-read.table(parSampleFile2, header=F, sep="\t", stringsAsFactors = F)
deseq2VsdFiles<-read.table(parSampleFile3, header=F, sep="\t", stringsAsFactors = F)
deseq2DesignFiles<-read.table(parSampleFile4, header=F, sep="\t", stringsAsFactors = F)

comparisons<-unique(annoFiles$V2)
comparison<-comparisons[1]
for (comparison in comparisons){
  dir.create(comparison,showWarnings=FALSE)
  compAnnoFiles<-annoFiles[annoFiles$V2 == comparison,]$V1
  compDeseq2File<-deseq2Files[deseq2Files$V2 == comparison,1]
  deseq2VsdFile<-deseq2VsdFiles[deseq2VsdFiles$V2 == comparison,1]
  deseq2DesignFile<-deseq2DesignFiles[deseq2DesignFiles$V2 == comparison,1]

  compAnnoFile<-compAnnoFiles[1]
  for(compAnnoFile in compAnnoFiles){
    if (!file.exists(compAnnoFile)) {
      warning(paste0(compAnnoFile," doesn't exist, Skip!"))
      next;
    }
    targetFolder=paste0("./",comparison,"/",basename(compAnnoFile),"/")
    dir.create(targetFolder,showWarnings=FALSE)

    currentWd=getwd()
    setwd(targetFolder)

    category <- gsub(paste0(".*?", comparison,"_"), "", basename(compAnnoFile) )
    category <- gsub(".txt", "", category )
    category <- gsub("_", " ", category )

    enriched<-read.table(compAnnoFile, sep="\t", header=T, stringsAsFactors = F)
    #deseq2<-read.csv(compDeseq2File, header=T, row.names=1, stringsAsFactors = F)
    #deseq2<-deseq2[,c("Feature_gene_name", "baseMean", "pvalue", "padj", "FoldChange") ]
    deseq2=readFilesAndFormat(compDeseq2File)
    diffCol=getDiffCol(deseq2)[["colName"]]
    diffCenterValue=getDiffCol(deseq2)[["centerValue"]]
    geneCol=getGeneCol(deseq2)[["colName"]]

    #geneExpression<-read.csv(deseq2VsdFile, header=T, row.names=1, stringsAsFactors = F)
    geneExpression<-readFilesAndFormat(deseq2VsdFile)

    designData<-read.delim(deseq2DesignFile, header=T,  stringsAsFactors = F,check.names=F)
    conditionColors=as.matrix(data.frame(Group=c("red", "blue")[as.factor(designData[,2])]))
    gnames=levels(as.factor(designData[,2]))

    rowCount<-min(maxCategory,nrow(enriched))
    idx<-1
    for(idx in c(1:rowCount)){
      entry<-enriched[idx,]
      userIds<-unlist(strsplit( entry$userId[1], ';'))
      #entryTable<-geneExpression[row.names(deseq2)[which(deseq2$Feature_gene_name %in% userIds)],]
      #row.names(entryTable)=make.unique(deseq2[which(deseq2$Feature_gene_name %in% userIds),"Feature_gene_name"])
      entryTable<-geneExpression[row.names(deseq2)[which(deseq2[,geneCol] %in% userIds)],]
      row.names(entryTable)=make.unique(deseq2[which(deseq2[,geneCol] %in% userIds),geneCol])

      drawHCA(prefix=make.names(enriched[idx,1]), rldselect=entryTable, ispaired=FALSE, designData=deseq2Design,
                   conditionColors=conditionColors, gnames=gnames, outputFormat="PNG",
              main=paste(enriched[idx,1:2],collapse=", "),labRow=row.names(entryTable),fileTypePrefix=fileTypePrefix)

    }
    setwd(currentWd)
  }
}


#!/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)
if(length(args)<6){
    stop("No input files supplied\n\nUsage:\nRscript run_ascat.r tumor_baf tumor_logr normal_baf normal_logr tumor_sample_name baseDir gcfile\n\n")
} else{
    tumorbaf = args[1]
    tumorlogr = args[2]
    normalbaf = args[3]
    normallogr = args[4]
    tumorname = args[5]
    baseDir = args[6]
    gcfile = args[7]
}

source(paste(baseDir,"/scripts/ascat.R", sep=""))

if(!require(RColorBrewer)){
    source("http://bioconductor.org/biocLite.R")
    biocLite("RColorBrewer", suppressUpdates=TRUE, lib="$baseDir/scripts")
    library(RColorBrewer)
}
options(bitmapType='cairo')

#Load the  data
ascat.bc <- ascat.loadData(Tumor_LogR_file=tumorlogr, Tumor_BAF_file=tumorbaf, Germline_LogR_file=normallogr, Germline_BAF_file=normalbaf)

#GC wave correction
ascat.bc = ascat.GCcorrect(ascat.bc, gcfile)

#Plot the raw data
ascat.plotRawData(ascat.bc)

#Segment the data
ascat.bc <- ascat.aspcf(ascat.bc)

#Plot the segmented data
ascat.plotSegmentedData(ascat.bc)

#Run ASCAT to fit every tumor to a model, inferring ploidy, normal cell contamination, and discrete copy numbers
ascat.output <- ascat.runAscat(ascat.bc, gamma=1)

#Write out segmented regions (including regions with one copy of each allele)
#write.table(ascat.output$segments, file=paste(tumorname, ".segments.txt", sep=""), sep="\t", quote=F, row.names=F)

#Write out CNVs in bed format
cnvs=ascat.output$segments[2:6]
write.table(cnvs, file=paste(tumorname,".cnvs.txt",sep=""), sep="\t", quote=F, row.names=F, col.names=T)

#Write out purity and ploidy info
summary <- tryCatch({
		matrix(c(ascat.output$aberrantcellfraction, ascat.output$ploidy), ncol=2, byrow=TRUE)}, error = function(err) {
			# error handler picks up where error was generated
			print(paste("Could not find optimal solution:  ",err))
			return(matrix(c(0,0),nrow=1,ncol=2,byrow = TRUE))
		}
)
colnames(summary) <- c("AberrantCellFraction","Ploidy")
write.table(summary, file=paste(tumorname,".purityploidy.txt",sep=""), sep="\t", quote=F, row.names=F, col.names=T)


#install.packages("reshape2")
#install.packages("network")
#install.packages("igraph")
#install.packages("rgl")
#library("igraph")
#install.packages("ggplot2")

in_colnames <- c("qseqid", "sseqid", "qlen", "qstart", "qend", "slen", "sstart", "send", "evalue", "bitscore", "score", "length", "pident", "nident", "gaps")

ara_mz_aa <- read.table("../blast_out/ara-mz-aa.txt")
colnames(ara_mz_aa) <- in_colnames
ara_mz_cds <- read.table("../blast_out/ara-mz-cds.txt")
colnames(ara_mz_cds) <- in_colnames

mz_ara_aa <- read.table("../blast_out/mz-ara-aa.txt",header = F,sep = "\t",quote = "")
colnames(mz_ara_aa) <- in_colnames
mz_ara_cds <- read.table("../blast_out/mz-ara-cds.txt")
colnames(mz_ara_cds) <- in_colnames

hist(mz_ara_aa$length/mz_ara_aa$qlen)
head(as.character(mz_ara_aa$qseqid))
head(gsub("_P..","",as.character(mz_ara_aa$qseqid)))
head(gsub("_P..","",as.character(mz_ara_aa$qseqid)))
head(mz_ara_cds$qseqid)
sum(mz_ara_aa$length/mz_ara_aa$qlen>0.8)
sum(mz_ara_aa$length/mz_ara_aa$slen>0.8)

plot(mz_ara_aa$score/max(mz_ara_aa$score),mz_ara_aa$evalue)

plot(mz_ara_aa$length/mz_ara_aa$qlen)

plot(mz_ara_aa[mz_ara_aa$length>4000,]$score,mz_ara_aa[mz_ara_aa$length>4000,]$evalue)
summary(mz_ara_aa[mz_ara_aa$length>1000,]$slen)
summary(mz_ara_aa[mz_ara_aa$length>1000,]$qlen)
sum(mz_ara_aa$evalue<0.001)
head(unique(mz_ara_aa$qseqid))

tmp <- mz_ara_aa[mz_ara_aa$qseqid=="GRMZM2G424981_P01",]
mz_ara_aa[mz_ara_aa$qseqid=="GRMZM2G054378_P01",c("qseqid","sseqid","nident","evalue","score")]
qcov <- round(tmp$length/tmp$qlen*100,2)
scov <- round(tmp$length/tmp$slen*100,2)
tmp <- cbind(tmp,qcov,scov)
tmp

library("reshape2")
library("ggplot2")
tmp_melt<- melt(tmp[,c("sseqid","qcov","scov","length","pident","score","evalue")],id.vars = "sseqid",as.is = T)
head(tmp_melt[tmp_melt$variable=="evalue",])
#plot(tmp$sseqid,tmp$qcov)
#plot(tmp$sseqid,qcov)

#par(mfrow=c(2,2))\
png("img/blast_hits.png",width = 9,height = 5.8,units = "in",res = 300)
gplot <- ggplot(tmp_melt,aes(x=sseqid,y=value,fill=sseqid))
gplot <- gplot + geom_bar(stat="identity")
gplot <- gplot + theme(axis.text.x=element_text(angle = -45, hjust = 0)) + guides(fill=FALSE)
gplot <- gplot + ggtitle("BLAST output for the hits for GRMZM2G424981") + facet_grid(variable~.,scales = "free")
gplot
dev.off()
tmp_melt[tmp_melt$variable=="score",]
tmp$score
tmp
# evalue_trans <- round(-1*log(tmp$evalue,10),2)
evalue_trans
#tmp <- cbind(tmp, evalue_trans)face
tmp$evalue_trans <- evalue_trans
tmp
png("img/evalue.png",width = 9,height = 5.8,units = "in",res = 300)
gplot <- ggplot(tmp,aes(x=sseqid,y=evalue_trans,fill=sseqid))
gplot <- gplot + geom_bar(stat="identity")
gplot <- gplot + theme(axis.text.x=element_text(angle = -45, hjust = 0)) + guides(fill=FALSE)
gplot <- gplot + ggtitle("BLAST output for the hits for GRMZM2G054378")
gplot
dev.off()

tmp$sseqid

# tmp$qseqid <- "ZM"
# tmp$sseqid <- paste("AT",1:dim(tmp)[1],sep = "")
write.table(tmp,file = "img/pident.txt",row.names = F,col.names = T,quote = F)
#
# tmp <- mz_ara_aa[mz_ara_aa$qseqid=="GRMZM2G054378_P01" & mz_ara_aa$pident>=40,c("qseqid","sseqid","evalue")]
# tmp
# tmp$qseqid <- "ZM"
# tmp$sseqid <- paste("AT",1:dim(tmp)[1],sep = "")
# write.table(tmp,file = "img/evalue.txt",row.names = F,col.names = T,quote = F)
#
# mz_ara_aa[mz_ara_aa$nident/mz_ara_aa$qlen*100 > 60 & mz_ara_aa$nident/mz_ara_aa$qlen*100 <90,]
head(unique(mz_ara_aa$qseqid),10)
# mz_ara_aa[mz_ara_aa$qseqid=="GRMZM2G424981_P01",]


#!/usr/bin/env Rscript --vanilla

# Map missions of the Paulist Fathers over time
# Lincoln A. Mullen | lincoln@lincolnmullen.com | http://lincolnmullen.com
# MIT License <http://lmullen.mit-license.org/>

library(ggplot2)
library(ggthemes)
library(maps)
library(rgdal)

missions <- read.csv("demographics-religion/data/paulist-chronicles/paulist-missions.geocoded.csv",
                     stringsAsFactors = FALSE)

# Maps
canada <- map_data("world", "Canada")
mexico <- map_data("world", "Mexico")
us     <- map_data("state")
rr_1861 <- readOGR(dsn = "/home/lmullen/research-data/USrailshps/RR1861/",
                   layer = "RR1861WGS84")
rr_1861 <- fortify(rr_1861)
rr_1870 <- readOGR(dsn = "/home/lmullen/research-data/USrailshps/RR1870/",
                   layer = "RR1870WGS84")
rr_1870 <- fortify(rr_1870)

# Three datasets
missions_1 <- subset(missions, year < 1866)
missions_2 <- subset(missions, year >= 1866 & year <= 1882 )
missions_3 <- subset(missions, year >= 1883)

# Base map
base_map <- ggplot() +
  coord_map() +
  geom_path(data = us,
            aes(x = long, y = lat, group = group),
            color = 'gray', fill = 'white', size = .3) +
  geom_path(data = canada, aes(x = long, y = lat, group = group),
            color = 'gray', fill = 'white', size = .3) +
  geom_path(data = mexico, aes(x = long, y = lat, group = group),
            color = 'gray', fill = 'white', size = .3) +
  theme_tufte() +
  theme(panel.border = element_blank(),
        axis.ticks   = element_blank(),
        axis.text    = element_blank(),
        axis.title   = element_blank()) +
  guides(size=guide_legend(title="Converts\nper mission")) +
  scale_size(range = c(3, 8))

# Map 1
map_1 <- base_map +
  xlim(-93,-65) +
  ylim(23, 49) +
  geom_point(data = missions_1,
             aes(x = geo.lon, y=geo.lat, size = converts_total),
             alpha = 0.5) +
  geom_path(data = rr_1861, aes(x = long, y= lat, group = group),
            color = 'black', alpha = .5, size = .3) +
  ggtitle("Redemptorist and Paulist Missions, 1852-1865, with Railroads in 1861")

pdf(file = "paulists-map-1.pdf",
    height = 8.5, width = 11)
print(map_1)
dev.off()

# Map 2
map_2 <- base_map +
  geom_path(data = rr_1870, aes(x = long, y= lat, group = group),
            color = 'black', alpha = .5, size = .3) +
  xlim(-126,-65) +
  ylim(23, 51) +
  geom_point(data = missions_2,
             aes(x = geo.lon, y=geo.lat, size = converts_total),
             alpha = 0.5) +
  ggtitle("Paulist Missions 1871-1882, with Railroads in 1870")

pdf(file = "paulists-map-2.pdf",
    height = 8.5, width= 11)
print(map_2)
dev.off()
system("pdftk paulists-map-2.pdf cat 1west output paulists-map2.pdf")
system("mv paulists-map2.pdf paulists-map-2.pdf")

# Map 3
map_3 <- base_map +
  xlim(-126,-65) +
  ylim(23, 51) +
  geom_point(data = missions_3,
             aes(x = geo.lon, y=geo.lat, size = converts_total),
             alpha = 0.5) +
  geom_path(data = rr_1870, aes(x = long, y= lat, group = group),
            color = 'black', alpha = .5, size = .3) +
  ggtitle("Paulist Missions 1883-1893, with Railroads in 1870")

pdf(file = "paulists-map-3.pdf",
    height = 8.5, width= 11)
print(map_3)
dev.off()
system("pdftk paulists-map-3.pdf cat 1west output paulists-map3.pdf")
system("mv paulists-map3.pdf paulists-map-3.pdf")


#----------------------------------------------------------------------------------
# zcep -- Compute Bark Cepstral coefficients for a windowed region of speech
#
# Synopsis:  zcoefs <- zcep(sr, data, nc)
#            sr   - sample rate of the speech data needed for calculation of Bark
#                   filter bands.
#            data - a vector of windowed waveform samples such as returned by
#                   getFrame()
#            nc   - Number of Bark Cepstral coefficients to return
#
# Description:
#  The zcep function for R calls the libcdsp zcep funtion from the standard SRL
#  libcdsp via an interface/wrapper function called r_zcep that translates the
#  the passed args to the correct format.
#
#  When called, zcep first checks to see that the necessary r_zcep function is
#  loaded. If not, the shared object lib is loaded. The lib name/path is system-
#  dependent and right now, we check for either Linux or macOS (Darwin) to load
#  the correct lib. If run on another OS (e.g. Windows), the function will print
#  an error message and return NA.
#
#  If successful, the function will return a vector of cepstral coefficients.
#
#  HTB -- 3/24/21
#---------------------------------------------------------------------------------
#

zcep <- function(sr, data, nc) {
  #
  # Make sure the r_zcep function is accessible and if not, load libcdsp
  #
  if (!is.loaded("r_zcep")) {
    if (Sys.info()['sysname'] == "Linux") {
      dyn.load("/usr/local/srl/lib/libcdsp.so")
    } else if (Sys.info()['sysname'] == "Darwin") {
      dyn.load("/usr/local/srl/lib/libcdsp.dylib")
    } else {
      message("zcep: libcdsp not loaded!")
      return(NA)
    }
  }

  totenergy = as.double(0.0)
  rtn = .C("r_zcep", sr_p=as.double(sr),
               npts_p=as.integer(length(data)),
               data=as.single(data),
               ncoef_p=as.integer(nc),
               coefs=as.single(rep(0,nc)),
               totenergy)
  return(as.double(rtn$coefs))
}


library("xml2")
library("dplyr")
library("stringr")
library("rlist")
library("xts")
library("quantmod")
library("PortfolioAnalytics")
library("DEoptim")
library("ROI")
require("ROI.plugin.glpk")
require("ROI.plugin.quadprog")

#weights<-function(final_fund_all){
    ### Read data from last milestone
    #setwd("C:/Users/EDZ/Desktop/理享�?/Portfolio_Proj") #can be specified
    data = read.csv("finalfund.csv",header = TRUE, fileEncoding = "UTF-8", sep=",", na.strings = "")
    #data = final_fund_all
    rows = nrow(data)
    print("rows:")
    print(rows)
    print("cols:")
    print(ncol(data))
    fund_num = ncol(data) - 1
    #tmp = as.character(data[,1])
    #data[,1] = as.Date(tmp, format="%Y/%m/%d")

#####These are the code for last version

###Complete all funds
    for (j in 1:fund_num){
        for (i in 1:rows){
            if(is.na(data[i,j+1])){
                if(i != rows){
                    #last_data = data[i-1,j+1]
                    i_tmp = i + 1;
                    while(is.na(data[i_tmp,j+1])) i_tmp = i_tmp + 1
                    data[i,j+1] = (data[i-1,j+1] + data[i_tmp,j+1]) / 2
                }
                else{
                    data[i,j+1] = data[i-1,j+1]
                }
            }
        }
    }

###These are the code for last version
if(FALSE){
    if(FALSE){
        ###Step 1: find the fund with most dates
        fund_most_date = 1
        MAX_date = 1
        for (j in 1:fund_num){
            i = 1
            while(!is.na(data[i,j+1]))
                i = i + 1
            if(i > MAX_date) {
                MAX_date = i
                fund_most_date = j
            }
        }
    }
    if(fund_most_date != fund_num){
    for (j in (fund_most_date+1):fund_num){
        for (i in i:rows){
            if(is.na(data[i,j+1])){
                if(i != rows){
                    #new input format do not require data moving
                    if(FALSE)
                    {
                        #move the dates
                        data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                        data[(i+1):rows, 2*j+1] = data[i:(rows-1),2*j+1]
                        data[i,2*j] = data[i,2*fund_most_date]
                        data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) /2
                    }
                    data[i,j+1] = (data[i-1,j+1] + data[i+1,j+1]) /2
                }
                else{
                    data[i,j+1] = data[i-1,j+1]
                }
            }
        }
    }
}

    if(fund_most_date != fund_num){
        for (j in (fund_most_date+1):fund_num){

            for (i in i :rows){
                if(is.na(data[i,2*j]) || (data[i,2*j] > data[i, 2*fund_most_date])){
                    if(i != rows){
                        #move the dates
                        data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                        data[(i+1):rows, 2*j+1] = data[i:(rows-1),2*j+1]
                        data[i,2*j] = data[i,2*fund_most_date]
                        data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) /2
                    }
                    else{
                        data[i,2*j] = data[i,2*fund_most_date]

                        data[i,2*j+1] = data[i,2*fund_most_date+1]
                    }
                }
            }
        }
    }
}

### Construct the system by Marko model
#Initialization
rows = nrow(data)
returns_tmp = c()
return = data.frame()

for (j in 1:fund_num){
    #return<-data[,j+1]
    #for(i in 1:rows-1){
    #    return[i+1] = data[i+1,j+1] / data[i,j+1] - 1.00
    #}
    data_tmp <- data.frame(data[,1],data[,j+1])
    data_tmp <- xts(data_tmp[,2],as.Date(data_tmp[,1]))
    return <- periodReturn(data_tmp,period="daily",type="log")
    returns_tmp <- cbind(returns_tmp,return)
}

returns <- returns_tmp[,1:5]
rownames(returns) <- data[,1]
colnames(returns) <- c("fd1", "fd2", "fd3", "fd4","fd5")
funds <- colnames(returns)
init <- portfolio.spec(assets = funds)
init <- add.constraint(portfolio=init, type="leverage",min_sum=0.99, max_sum=1.01)
init <- add.constraint(portfolio=init, type="box", min=0.10, max=0.40)
#print.default(init)

#6.2 Maximize mean return with ROI
max_ret <- add.objective(portfolio=init, type="return", name="mean")
opt_maxret <- optimize.portfolio(R=returns, portfolio=max_ret, optimize_method="ROI",trace=TRUE)
#print(opt_maxret)
#plot(opt_maxret, risk.col="StdDev", return.col="mean", main="Maximum Return Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,30))

#6.3 Minimize variance with ROI
minvar <- add.objective(portfolio=init, type="risk", name="var")
opt_minvar <- optimize.portfolio(R=returns, portfolio=minvar, optimize_method="ROI", trace=TRUE)
print(opt_minvar)
plot(opt_minvar, risk.col="StdDev", return.col="mean", main="Minimum Variance Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

#6.4 Maximize quadratic utility with ROI
qu <- add.objective(portfolio=init, type="return", name="mean")
qu <- add.objective(portfolio=qu, type="risk", name="var", risk_aversion=0.25) #can be specified
opt_qu <- optimize.portfolio(R=returns, portfolio=qu, optimize_method="ROI", trace=TRUE)
#print(opt_qu)
#plot(opt_qu, risk.col="StdDev", return.col="mean", main="Quadratic Utility Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

#6.5 Minimize expected tail loss with ROI
etl <- add.objective(portfolio=init, type="risk", name="ETL")
opt_etl <- optimize.portfolio(R=returns, portfolio=etl, optimize_method="ROI", trace=TRUE)
#print(opt_etl)
#plot(opt_etl, risk.col="ES", return.col="mean", main="ETL Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

#6.6 Maximize mean return per unit ETL with random portfolios
meanETL <- add.objective(portfolio = init, type = "return", name = "mean")
meanETL <- add.objective(portfolio = meanETL, type="risk", name="ETL", arguments=list(p=0.95))
opt_meanETL <- optimize.portfolio(R=returns, portfolio = meanETL, optimize_method = "random", trace = TRUE, search_size = 2000)
#print(opt_meanETL)
stats_meanETL <-extractStats(opt_meanETL)
#head(stats_meanETL)
#plot(opt_meanETL, risk.col="ETL", return.col="mean", main="mean-ETL Optimization", neighbors=25)

w = extractWeights(opt_minvar)

#return w