SSBparm<-"out"   # read ssb-R parameters from SSB_R.in (="in") or SSB_R.out (="out")
include.terminal.year <- FALSE          # plot terminal year as well?
dev<-"screen"
#dev<-"png"
Portrait <- T

##########################################################################
## init section used by other sections
#

cleanup()
if (nsp==1) { nox<-1; noy<-1; } else { nox<-3; noy<-4; }

noxy<-nox*noy
par(ask=TRUE)

Init.function() # get SMS.contol object  including sp.names

SSB.R.year.first<-SMS.control@SSB.R.year.first
SSB.R.year.last <-SMS.control@SSB.R.year.last
SSB.R.year.first[SSB.R.year.first==-1]<-SMS.control@first.year.model
SSB.R.year.last[SSB.R.year.last==-1]<-SMS.control@last.year.model

# extract SSB and Recruits
s<-Read.summary.data(extend=include.terminal.year)
s1<-subset(s,Quarter==1 & Year<=SMS.control@last.year.model-SMS.control@first.age & Species.n>=first.VPA)
ssb<-tapply(s1$SSB,list(s1$Species.n,s1$Year),sum)/1000

rec<-subset(s,Quarter==SMS.control@rec.season,select=c(Year,Species.n,Age,N))

rec<-subset(rec,Age==SMS.control@first.age & Year>=SMS.control@first.year+SMS.control@first.age)
rec<-subset(rec,Year<=SMS.control@last.year.model)
rec<-tapply(rec$N,list(rec$Species.n,rec$Year),sum)/1000000

# read recruiment years used
recruit.years<-matrix(head(scan(file='recruitment_years.in',comment.char='#'),-1),nrow=dim(rec)[1],byrow=T)
colnames(recruit.years)<-c(as.character(seq(SMS.control@first.year,SMS.control@last.year)))

#read SSB/R parameters
if (SSBparm=="in") p<-Read.SSB.Rec.data.in() else p<-Read.SSB.Rec.data()

model.name<-c('Ricker','Bev. & Holt','Geom. mean','Hockey stick')

##########################  SSB - Recruit plot Obsevations  #############

#nox<-3; noy<-4;
nox<-1; noy<-1;
noxy<-nox*noy

newplot(dev,filename='SSB_R_a',nox,noy,Portrait);
i<-0

for (sp in (first.VPA:nsp)) {
  s.index<-sp-first.VPA+1
  if (i==noxy) {newplot(dev,filename=paste('SSB_R_a',s.index,sep=''),nox,noy,Portrait); i<-0 }
  plot(ssb[s.index,],rec[s.index,],xlab="SSB (kt)",ylab="Recruits (billions)",main=sp.names[sp],
  xlim=c(0,max(ssb[s.index,])), ylim=c(0,max(rec[s.index,])),type='b' )
  colors<-seq(SMS.control@first.year.model,max(s$Year))

  for (j in (1:length(colors))) {
   if (colors[j] %in% (SSB.R.year.first[s.index]:SSB.R.year.last[s.index])) colors[j]<-1 else colors[j]<-2
  }
  ry<-recruit.years[s.index,]
  ry<-ry[as.character(seq(SMS.control@first.year.model,max(s$Year)))]
  colors[ry==0]<-2
  cat("\n")
  cohort.labels <- sprintf("%02.0f",as.numeric(dimnames(ssb)[[2]])%%100)
  if (noxy <2)text(x=ssb[s.index,],y=rec[s.index,],labels=cohort.labels,pos=2,col=colors)
  i<-i+1
  grid()
}
if (dev=='png') cleanup()

##########################  SSB - Recruit plot Obsevations and regression line  #############
nox<-3; noy<-4;
nox<-1; noy<-1;
noxy<-nox*noy

include.CV<-TRUE            # include CV on estimated relation
include.CV2<-TRUE           # include 2*CV on estimated relation
include.year.labels<-TRUE   # put year label on each point

include.MCMC.hist<-F    # include MCMC values of historical assessment SSB- R obs
include.MCMC.pred<-F    # include MCMC values of prediction SSB- R obs

include.excluded.years<-T   # exclude years not included in the SSB-R fit
scale.yaxis.include<-F
include.mean<-TRUE  # include mean recruitment

SSB_R<-function(x) {
    delta<-0.5
    y<-x  # copy structure
    #print(c(alfa,beta,exp(alfa+beta)))
    if (model==1) y<-alfa*x*exp(-beta*x)
    else if (model==51 | model==52) y<-alfa*x*exp(-beta*x+info1*info2)
    else if (model==2) y<-alfa*x/(1+x*beta)
    else if (model==3) y<-rep(exp(alfa),length(x))
    else if (model==4) {for (ii in (1:length(x))) y[i]<-exp(alfa)*min(x[i],exp(beta))}
    else if (model==5) {for (ii in (1:length(x))) {
        if (x[ii]<=(exp(beta)*(1-delta))) y[ii]<-exp(alfa)*x[ii]
        else if (x[ii]< exp(beta)*(1+delta)) y[ii]=exp(alfa)*(x[ii]-(((x[ii]-exp(beta)*(1+delta))^2)/(4*delta*exp(beta))))
        else if (x[ii]>=exp(beta)*(1+delta)) y[ii]<=exp(alfa+beta)
        else x[i]<-NA
        }}
    else if (model==100) {for (ii in (1:length(x))) y[ii]<-exp(alfa)*min(x[ii],beta)}
    return(y)
}

yy<-as.character(seq(SMS.control@first.year,SMS.control@last.year.model))
ss<-as.character(seq(first.VPA,nsp))

if (dev=="print") cleanup()

newplot(dev,filename='SSB_R_b',nox,noy,Portrait);
i<-1
dot.size<-1

if ((include.MCMC.hist) || (include.MCMC.pred)) { #read MCMC.output
  ssb.r<-Read.MCMC.SSB.rec.data()
  dot.size<-2
}

s.index<-0
for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']
  #CV<-p[s.index,'std'] approxmation
  CV<- sqrt(exp(p[s.index,'std']^2) - 1)
  if (i==noxy) {newplot(dev,filename=paste('SSB_R_b.fit',s.index,sep=''),nox,noy,Portrait); i<-0 }

  colors<-seq(SMS.control@first.year.model,max(s$Year))
  if (include.excluded.years) {
    for (j in (1:length(colors))) {
     if (colors[j] %in% (SSB.R.year.first[s.index]:SSB.R.year.last[s.index])) colors[j]<-1 else colors[j]<-2
    }
    ry<-recruit.years[s.index,]
    ry<-ry[as.character(seq(SMS.control@first.year.model,max(s$Year)))]
    colors[ry==0]<-2
  }

  recPlot<-rec[sp,]
  if (scale.yaxis.include) recPlot[colors!=1]<-NA
  SSBplot<-ssb[sp,]
  if (scale.yaxis.include) SSBplot[colors!=1]<-NA

  modelName<-model.name[min(model,4)]
  if (model==51 | model==52) modelName<-paste("Ricker, Temp=",info2,sep='')

  plot(ssb[sp,1:dim(rec)[2]],rec[sp,],xlab="SSB (1000t)",ylab="recruits 10^9",
         main=paste(sp.names[as.numeric(sp)],': ',modelName,', ',SSB.R.year.first[s.index],":",SSB.R.year.last[s.index],sep=''),
         ylim=c(0,max(recPlot*1.2,na.rm=T)),type='p',col=colors,pch=19,cex=dot.size,
        xlim=c(0,max(SSBplot,na.rm=T)))

  # print(ssb);print(rec)  ;print(as.character(seq(SMS.control@first.year,max(s$Year))%%100))
  if ((noxy <5) && (include.year.labels==1)) text(x=ssb[sp,],y=rec[sp,],labels=as.character(sprintf("%02.0f",seq(SMS.control@first.year,max(s$Year))%%100)),pos=3)

  x<-seq(0,max(ssb[sp,]), by=max(ssb[sp,])/100)*1000
  y<-SSB_R(x)
  x<-x/1000
  y<-y/1000000
  lines(x,y,col=2)
  if (include.CV) {
      lines(x,y*exp(CV),col=4)
      lines(x,y*exp(-CV),col=4)
      if (include.CV2==1) {
        lines(x,y*exp(2*CV),col=5)
        lines(x,y*exp(-2*CV),col=5)
      }
  }
  if (include.mean) {
    lines(x,y*exp((CV^2)/2),col=6,lty=2)
  }
  if (model==100) abline(v=beta/1000,lty=2)

  if (include.MCMC.hist) {
    a<-subset(ssb.r,(Year<=SMS.control@last.year.model & Species.n==sp))
    x<-a$SSB/1000
    y<-a$recruit/1000000
    points(x,y,pch=25,col=2)
  }
  if (include.MCMC.pred) {
    a<-subset(ssb.r,(Year>SMS.control@last.year.model & Species.n==sp))
    x<-a$SSB/1000
    y<-a$recruit/1000000
    points(x,y,pch=24,col=3)
  }

  # re-draw
  if ((include.MCMC.hist) || (include.MCMC.pred)) {

     points(ssb[sp,1:dim(rec)[2]],rec[sp,],
      type='p',col=colors,pch=19,cex=dot.size )
      if ((noxy <5) && (include.year.labels==1)) text(x=ssb[sp,],y=rec[sp,],
         labels=as.character(seq(SMS.control@first.year,max(s$Year))%%100),pos=3)
  }
  i<-i+1
}

if (dev=='png') cleanup()

########################
## Histogram of residuals
s.index<-0

if (dev=="print") cleanup()

nox<-3; noy<-4;
#nox<-2; noy<-2;
noxy<-nox*noy
newplot(dev,filename='SSB_R_c',nox,noy,Portrait);
i<-0

for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']
  CV<- sqrt(exp(p[s.index,'std']^2) - 1)
  modelName<-model.name[min(model,4)]
  if (model==51 | model==52) modelName<-paste("Ricker, Temp=",info2,sep='')

  if (i==noxy) {newplot(dev,filename=paste('SSB_R_c',s.index,sep=''),nox,noy,Portrait); i<-0 }
  x<-ssb[sp,as.character(SSB.R.year.first[s.index]:SSB.R.year.last[s.index])]*1000
  y<- 1000000*rec[sp,as.character(SSB.R.year.first[s.index]:SSB.R.year.last[s.index])] /SSB_R(x)   # residuals: observed / predicted

  ry<-recruit.years[s.index,]
  ry<-ry[names(y)]
  x<-x[ry==1]
  y<-y[ry==1]

  #cat("SSB:\n",x,"\n")
  #cat('obs rec:\n',rec[sp,],"\n")
  #cat("calc rec:\n",SSB_R(x),'\n')
  #cat('resid:\n',log(y),'\n')
  cat(sp.names[as.numeric(sp)],'resid min:',log(min(y)),'  resid max:',log(max(y)),'\n')
  x<-seq(-3,3,by=0.01)
  hist(log(y),freq=F,main=paste(sp.names[as.numeric(sp)],': ',modelName," ",SSB.R.year.first[s.index],':',SSB.R.year.last[s.index],sep=''),xlab='Residual (log(obs/est))')

  SD<-p[s.index,'std']
  curve(dnorm(x,mean=0,sd=SD), col = 2, lty = 2, lwd = 3, add = TRUE)
  i<-i+1
}

## range in noise function
s.index<-0

if (dev=="print") cleanup()

newplot(dev,filename='SSB_R_d',nox,noy,Portrait);
i<-0

for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']
  CV<-p[s.index,'std']
  modelName<-model.name[min(model,4)]
  if (model==51 | model==52) modelName<-paste("Ricker, Temp=",info2,sep='')

  if (i==noxy) {newplot(dev,filename=paste('SSB_R_d',s.index,sep=''),nox,noy,Portrait); i<-0 }
  x<-ssb[sp,as.character(SSB.R.year.first[s.index]:SSB.R.year.last[s.index])]*1000
  y<- 1000000*rec[sp,as.character(SSB.R.year.first[s.index]:SSB.R.year.last[s.index])] /SSB_R(x)   # residuals: observed / predicted
  ry<-recruit.years[s.index,]
  ry<-ry[names(y)]
  x<-x[ry==1]
  y<-y[ry==1]

  cat(sp.names[as.numeric(sp)],'norm min:',log(min(y))/CV,'  norm max:',log(max(y))/CV,'\n')
  x<-seq(-3,3,by=0.01)
  hist(log(y)/CV,freq=F,main=paste(sp.names[as.numeric(sp)],': ',modelName," ",SSB.R.year.first[s.index],':',SSB.R.year.last[s.index],sep=''),xlab='Noise')

  CV<-p[s.index,'std']
  curve(dnorm(x,mean=0,sd=1), col = 2, lty = 2, lwd = 3, add = TRUE)
  i<-i+1
}
if (dev=='png') cleanup()
#exp(sqrt(SSB_R_s2(s))*noise)

##########################  SSB - cummulated Recruit probability  plot #############
if (F) {
nox<-1; noy<-1
include.MCMC.hist<-T    # include line for MCMC values of historical assessment SSB- R obs
include.MCMC.pred<-T    # include line for MCMC values of prediction SSB- R obs

ref<-Read.reference.points()
lower.SSB.limit.on.plot<-ref[,'Blim']/1000

ss<-(seq(first.VPA,nsp))
s<-Read.summary.data()

for (sp in ss) {
  # extract SSB and Recruits

  s1<-subset(s,Quarter==1 & Year<=SMS.control@last.year.model-SMS.control@first.age & Species.n==sp )
  s1<-subset(s1,Year %in% (SSB.R.year.first[sp]:SSB.R.year.last[sp]))
  ssb<-tapply(s1$SSB,list(s1$Year),sum)/1000

  rec<-subset(s,Quarter==SMS.control@rec.season &Species.n==sp,select=c(Year,Age,N))
  rec<-subset(rec,Year %in% (SSB.R.year.first[sp]:SSB.R.year.last[sp]) )
  rec<-subset(rec,Age==SMS.control@first.age & Year>=SMS.control@first.year+SMS.control@first.age)
  rec<-tapply(rec$N,list(rec$Year),sum)/1000000

  incl<-ssb>lower.SSB.limit.on.plot[sp]

  ssb<-ssb[incl]
  rec<-rec[incl]

  if (dev=="print") cleanup()
  newplot(dev,nox,noy);
  i<-0

  sp.rec<-sort(rec)
  prob.rec<-seq(1,length(sp.rec))
  prob.rec<-prob.rec/length(prob.rec)

  if ((include.MCMC.hist==1) || (include.MCMC.pred==1)) { #read MCMC.output
    ssb.r<-Read.MCMC.SSB.rec.data()
  }

  if (i==noxy) {newplot(dev,nox,noy); i<-0 }
  max.x<-max(sp.rec)
  if (include.MCMC.pred==1) {
    a<-subset(ssb.r,(Year>(SMS.control@last.year.model) & Species.n==sp ))
    agem<<-a
    max.x<-max(a$recruit/1000000,max.x)
  }

  if (lower.SSB.limit.on.plot[sp]>0) {
    if (nsp>1) titl<-paste(SMS.control@species.names[sp],"SSB>",lower.SSB.limit.on.plot[sp]) else titl<-' '
  } else titl<-SMS.control@species.names[sp]

  plot(sp.rec,prob.rec ,ylab="probability",xlab="recruits 10^9",main=titl,
      xlim=c(0,max.x), ylim=c(0,1),type='p',col=1,pch=24 )

  if (include.MCMC.hist) {
    a<-subset(ssb.r,Year<=SMS.control@last.year.model & Species.n==sp & SSB>1000*lower.SSB.limit.on.plot[sp] &
                Year %in% (SSB.R.year.first[sp]:SSB.R.year.last[sp]))
    x<-sort(a$recruit/1000000)
    y<-seq(1,length(x))
    y<-y/length(y)
    # points(x,y,pch=25,col=2)
    lines(x,y,col=1,lwd=2)
  }
  if (include.MCMC.pred) {
    a<-subset(ssb.r,Year>(SMS.control@last.year.model) & Species.n==sp & SSB>1000*lower.SSB.limit.on.plot[sp])
    x<-sort(a$recruit/1000000)
    y<-seq(1,length(x))
    y<-y/length(y)
    lines(x,y,col=2,lwd=2)
  }
  i<-i+1
  }
}
##################################


library(GSIF) # From devtools::install_github("GreatEmerald/GSIF")
library(hydroGOF)
library(doParallel)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/subpixel-confusion-matrix.r") # Replace with package eventually
source("utils/accuracy-statistics.r")
source("pixel-based/utils/crossvalidation.r")
source("utils/fnc-centroids.r")

Data.orig = LoadTrainingAndCovariates()
Data.orig = st_set_geometry(Data.orig, NULL)
Data.df = Data.orig
# Manually rescale
#Data.df = RescaleBasedOn(Data.df, Data.orig, GetAllPixelCovars())
Data.df[is.na(Data.df)] = 0
#Data.df[,GetAllPixelCovars()] = as.matrix(apply(Data.df[,GetAllPixelCovars()], 2, scale))
#Data.df[is.na(Data.df)] = -9999
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val = RescaleBasedOn(Data.val, Data.orig, GetAllPixelCovars())
#Data.val[,GetAllPixelCovars()] = as.matrix(apply(Data.val[,GetAllPixelCovars()], 2, scale))
Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

FullFormula = paste("dominant_lc", paste0(GetAllPixelCovars(), collapse="+"), sep="~")
FullFormula = formula(FullFormula)

# spfkm does not have a split between training and prediction.
# In fact, the training is the derivation of the class centre and SD;
# all the rest is prediction. So it cn be split out manually.

train_wm.spfkm = function(formula, data, ...)
{
    return(list(class.c=GetClassMeans(formula, data), class.sd=GetClassSDs(formula, data)))
}

# Function to emulate the logistic regression training method
# Not reliable right now: if the logistic regression never predicts that a class will appear, then we miss classes and it's impossible to make a full prediction.
train_lr.spfkm = function(formula, ..., data)
{
    #rout = spmultinom(formulaString=formula, data[formula.tools::lhs.vars(formula)], data[,formula.tools::rhs.vars(formula)], class.stats=TRUE, predict.probs=FALSE)
    rout = spfkm(formula, data[formula.tools::lhs.vars(formula)], data[,formula.tools::rhs.vars(formula)])
    return(list(class.c=rout@class.c, class.sd=rout@class.sd))
}

predict.spfkm = function(model, pred_formula, ..., newdata)
{
    return(spfkm(pred_formula, newdata[formula.tools::lhs.vars(pred_formula)], newdata[,formula.tools::rhs.vars(pred_formula)], class.c=model[["class.c"]], class.sd=model[["class.sd"]], ...)@mu)
}

# What is the difference between centroids derived from logistic regression and weighted average
CompleteRows = apply(as.matrix(Data.df[,GetAllPixelCovars()]), 1, function(x)any(is.na(x)))

LogCentroids = spmultinom(formulaString=FullFormula, Data.df["dominant_lc"], Data.df[,GetAllPixelCovars()], class.stats=TRUE, predict.probs=FALSE)
LogCentroids$class.c
SimpleCentroids = GetClassMeans(FullFormula, Data.df)
CentroidDifferences = LogCentroids$class.c - SimpleCentroids
AccuracyStats(LogCentroids$class.c, SimpleCentroids)

LogCentroids$class.sd
SimpleCentroidSDs = GetClassSDs(FullFormula, Data.df)
SDDifferences = LogCentroids$class.sd - SimpleCentroidSDs
AccuracyStats(LogCentroids$class.sd, SimpleCentroidSDs)

# try log centroids
LCModel = spfkm(FullFormula, Data.val["dominant_lc"], Data.val[,GetAllPixelCovars()],
    class.c=LogCentroids$class.c, class.sd=LogCentroids$class.sd)
AccuracyStatisticsPlots(LCModel@mu[,Classes], Truth[,Classes]/100) # RMSE 28.8, MAE 15.4, better than intercept
SCM(LCModel@mu[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 46%±4, kappa 0.34±0.05
NSE(unlist(LCModel@mu[,Classes]), unlist(Truth[,Classes]/100)) # 0.07, barely better than intercept
PlotHex(as.data.frame(LCModel@mu[,Classes]*100), Truth[,Classes], "Fuzzy nearest centroid, centroids from logistic regression")
PlotBox(as.data.frame(LCModel@mu[,Classes]*100), Truth[,Classes], main="Fuzzy nearest centroid, centroids from logistic regression", binpredicted=TRUE)

# How good is it to use weighted means
WMModel = spfkm(FullFormula, Data.val["dominant_lc"], Data.val[,GetAllPixelCovars()],
    class.c=GetClassMeans(FullFormula, Data.df), class.sd=GetClassSDs(FullFormula, Data.df))

# Scaled to original and also set NA to 0
#write.csv(WMModel@mu[,Classes], "../data/pixel-based/predictions/fnc-na0-scaled.csv", row.names=FALSE)
AccuracyStatisticsPlots(WMModel@mu[,Classes], Truth[,Classes]/100) # RMSE 24.5, MAE 13.5, slightly better
SCM(WMModel@mu[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 53%±4, kappa 0.42±0.06
NSE(unlist(WMModel@mu[,Classes]), unlist(Truth[,Classes]/100)) # 0.33
PlotHex(as.data.frame(WMModel@mu[,Classes]*100), Truth[,Classes], "Fuzzy nearest centroid, weighted means")
PlotBox(as.data.frame(WMModel@mu[,Classes]*100), Truth[,Classes], main="Fuzzy nearest centroid, weighted means", binpredicted=TRUE)
write.csv(WMModel@mu[,Classes], "../data/pixel-based/predictions/fnc-na0.csv", row.names=FALSE)

# What if we replace NAs with means instead
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val[is.na(Data.val)] = -9999
Data.val = NAToMean(Data.val, GetAllPixelCovars())
Data.val = TidyData(Data.val, drop.cols=NULL)

# Log
LCModel = spfkm(FullFormula, Data.val["dominant_lc"], Data.val[,GetAllPixelCovars()],
    class.c=LogCentroids$class.c, class.sd=LogCentroids$class.sd)
AccuracyStatisticsPlots(LCModel@mu[,Classes], Truth[,Classes]/100) # RMSE 27.7, MAE 14.7, improved
SCM(LCModel@mu[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 49%±3, kappa 0.36±0.05
NSE(unlist(LCModel@mu[,Classes]), unlist(Truth[,Classes]/100)) # 0.14, slightly better than intercept
PlotHex(as.data.frame(LCModel@mu[,Classes]*100), Truth[,Classes], "Fuzzy nearest centroid, centroids from logistic regression, NA set to mean")
PlotBox(as.data.frame(LCModel@mu[,Classes]*100), Truth[,Classes], main="Fuzzy nearest centroid, centroids from logistic regression, NA set to mean", binpredicted=TRUE)

# How good is it to use weighted means
WMModel = spfkm(FullFormula, Data.val["dominant_lc"], Data.val[,GetAllPixelCovars()],
    class.c=GetClassMeans(FullFormula, Data.df), class.sd=GetClassSDs(FullFormula, Data.df))

AccuracyStatisticsPlots(WMModel@mu[,Classes], Truth[,Classes]/100) # RMSE 25.1, MAE 14.2, improved
SCM(WMModel@mu[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE, scale=TRUE) # OA 51%±5, kappa 0.40±0.06
NSE(unlist(WMModel@mu[,Classes]), unlist(Truth[,Classes]/100)) # 0.30
PlotHex(as.data.frame(WMModel@mu[,Classes]*100), Truth[,Classes], "Fuzzy nearest centroid, weighted means, NA set to mean")
PlotBox(as.data.frame(WMModel@mu[,Classes]*100), Truth[,Classes], main="Fuzzy nearest centroid, weighted means, NA set to mean", binpredicted=TRUE)

# What if fuzziness is increased
FuzzierLogModel = spfkm(FullFormula, Data.df["dominant_lc"], Data.df[,GetAllPixelCovars()], fuzzy.e=1.5)
AccuracyStatisticsPlots(FuzzierLogModel@mu, Data.df[, colnames(FuzzierLogModel@mu)]/100) # RMSE of 21%
SCM(FuzzierLogModel@mu, as.matrix(Data.df[, colnames(FuzzierLogModel@mu)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 44% accuracy, kappa 0.35: contradictory

FuzzierWeightModel = spfkm(FullFormula, Data.df["dominant_lc"], Data.df[,GetAllPixelCovars()], class.c=GetClassMeans(FullFormula, Data.df), class.sd=GetClassSDs(FullFormula, Data.df), fuzzy.e=1.5)
AccuracyStatisticsPlots(FuzzierWeightModel@mu, Data.df[, colnames(FuzzierWeightModel@mu)]/100) # RMSE of 21%
SCM(FuzzierWeightModel@mu, as.matrix(Data.df[, colnames(FuzzierWeightModel@mu)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 42% accuracy, kappa 0.33: worse even than the logistic centroids

# What if we do crisp classification
CrispLogModel = spfkm(FullFormula, Data.df["dominant_lc"], Data.df[,GetAllPixelCovars()], fuzzy.e=1.01)
AccuracyStatisticsPlots(CrispLogModel@mu, Data.df[, colnames(CrispLogModel@mu)]/100) # RMSE of 29%
SCM(CrispLogModel@mu, as.matrix(Data.df[, colnames(CrispLogModel@mu)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 46% accuracy, kappa 0.36: poor as well

CrispWeightModel = spfkm(FullFormula, Data.df["dominant_lc"], Data.df[,GetAllPixelCovars()], class.c=GetClassMeans(FullFormula, Data.df), class.sd=GetClassSDs(FullFormula, Data.df), fuzzy.e=1.01)
AccuracyStatisticsPlots(CrispWeightModel@mu, Data.df[, colnames(CrispWeightModel@mu)]/100) # RMSE of 29%, much worse than the intercept model!
SCM(CrispWeightModel@mu, as.matrix(Data.df[, colnames(CrispWeightModel@mu)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 46% accuracy, kappa 0.37: almost the same as logistic


###############################################################################
# Cargar librerías necesarias para conducir la estimación de la biomasa aérea #
###############################################################################
cargarLattice<-function()
{
tryCatch({
  library(lattice)
  return(FALSE)
}, error = function(ex) {
  print("No se pudo cargar la libreria lattice")
  return(TRUE)
})
}

cargarExtremevalues<-function()
{
tryCatch({
  library(extremevalues)
  return(FALSE)
}, error = function(ex) {
  print("No se pudo cargar la libreria extremevalues")
  return(TRUE)
})
}

#######################################################
# Cargar datos necesarios para realizar la estimación #
#######################################################

CargarIndividuos<-function(y){
tryCatch({
ID1<-read.csv2(y,enc="latin1")
ID2<-subset(ID1,D...cm.>=10)
ID3<-subset(ID2,Entra!="No")
return (list(FALSE,ID3))
}, error = function(ex) {
print("Error en la carga de datos de individuos")
return (TRUE)
})
}

CargarParcelas<-function(x){
tryCatch({
PL1<-read.csv2(x,enc="latin1")
return (list(FALSE,PL1))
}, error = function(ex) {
print("Error en la carga de datos de parcelas")
return (TRUE)
})
}

CargarBosques<-function(b){
tryCatch({
BQ1<-read.csv2(b,enc="latin1")
return (list(FALSE,BQ1))
}, error = function(ex) {
print("Error en la carga de datos de bosques")
return (TRUE)
})
}

Merge<-function(ID3,PL1){
tryCatch({

return (list(FALSE,DT1))
}, error = function(ex) {
print("Error realizando el merge")
return(TRUE)
})
}

############################################
# Estimar la biomasa aérea de las parcelas #
############################################

CB<-function(x){
#tryCatch({
  Bio1<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(3.652+(-1.697*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(1.285*log(Dens..g.cm3.))) # Tropical Dry (Álvarez et al. 2012)
  Bio2<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(2.406+(-1.289*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(0.445*log(Dens..g.cm3.))) # Tropical Moist (Álvarez et al. 2012)
  Bio3<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(1.662+(-1.114*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(0.331*log(Dens..g.cm3.))) # Tropical Rain (Álvarez et al. 2012)
  Bio4<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(1.960+(-1.098*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(1.061*log(Dens..g.cm3.))) # Premontane Moist (Álvarez et al. 2012)
  Bio5<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(1.836+(-1.255*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(-0.222*log(Dens..g.cm3.))) # Lower Montane Wet (Álvarez et al. 2012)
  Bio6<-function(Dens..g.cm3.,D...cm.,Alt=NULL,AB=NULL) exp(3.130+(-1.536*log(D...cm.))+(1.169*((log(D...cm.))^2))+(-0.122*((log(D...cm.))^3))+(1.767*log(Dens..g.cm3.))) # Montane Wet (Álvarez et al. 2012)
  EQ1<-c("Bio1","Bio2","Bio3","Bio4","Bio5","Bio6")
  BA<-get(EQ1[as.integer(x[["EQ"]])])(as.numeric(x[["Dens..g.cm3."]]),
  as.numeric(x[["D...cm."]]),
  as.numeric(x[["Alt"]]),
  as.numeric(x[["AB"]]))
  #return(BA)
#}, error = function(ex) {
#print("Error en el calculo de la Biomasa")
#})
}

CBC<-function(ID3,PL1){
tryCatch({
DT1<-merge(ID3,PL1)
DT1$BAKg<-apply(DT1,1,CB)
DT2<-aggregate(DT1$BAKg/((DT1$Área*10000)/10),list(Plot=DT1[,"Plot"]),sum,na.rm=TRUE)
DT2$BA<-DT2$x
MG1<-merge(PL1,DT2)
DT3<-subset(MG1,select=c(Plot,Área,Año,Bosque,BA))
print(DT3)
print(DT3$BA)
OUT<-getOutliers(DT3$BA,method="II",distribution="lognormal")
print(OUT)
DT4<-DT3[-c(OUT$iRight,OUT$iLeft),]

return(list(FALSE,DT3))
}, error = function(ex) {
print("Error en el calculo de la biomasa y el carbono")
return (TRUE)
})
}

###########################################################
# Identificar parcelas con valores biomasa aérea atípicos #
###########################################################

ATP<-function(DT3){
tryCatch({
OUT<-getOutliers(DT3$BA,method="II",distribution="lognormal")
print(OUT)
DT4<-DT3[-c(OUT$iRight,OUT$iLeft),]
return(list(FALSE,DT4))
},error = function(ex){
print("Error en el calculo de los valores atipicos")
return (TRUE)
})
}

###############################################
# Estimar la biomasa aérea por tipo de bosque #
###############################################

ABC<-function(r,DT4,BQ1){
tryCatch({
NS1<-with(DT4,tapply(BA,list(Bosque),length))
MN1<-with(DT4,tapply(BA,Bosque,mean))
DS1<-with(DT4,tapply(BA,list(Bosque),sd))
BQ2<-BQ1[order(BQ1$Bosque),]
EST<-data.frame(Ai=BQ2$Ai, # Área que ocupa cada tipo de bosque en el país (expresado en ha) #
                n=NS1, # Número de parcelas por tipo de bosque #
                BAj=MN1, # Biomasa aérea por tipo de bosque (expresada en Mg/ha) #
                DS=DS1, # Desviación estándar asociada al promedio de biomasa aérea por tipo de bosque (expresada en Mg/ha) #
                CV=DS1/MN1*100, # Coeficiente de variación por tipo de bosque (expresado en %) #
                IC=1.96*DS1/sqrt(NS1), # Intervalo de confianza asociado al promedio de biomasa aérea por tipo de bosque (expresado en Mg/ha) #
                BAi=(MN1*BQ2$Ai)/1000000000, # Biomasa aérea total potencial por tipo de bosque (expresada en Pg) #
                Ci=((MN1*0.5)*BQ2$Ai)/1000000000, # Potencial de Carbono almacenado en la biomasa aérea por tipo de bosque (expresado en Pg) #
                CO2e=((MN1*0.5*3.67)*BQ2$Ai)/1000000000) # Dióxido de Carbono que aún no ha sido emitido a la atmósfera por tipo de bosque (expresado en Pg) #
write.table(EST,file=r,row.names=TRUE,sep=";",dec=",")
},error = function(ex){
print("Error en la escritura de los datos")
return (TRUE)
})
}


x = c(1, 2, 3, 4, 5, 20)
print("Vector x:")
print(x)

y = as.character(x)
print("Vector y:")
print(y)

z = as.integer(y)
print("Vector z:")
print(z)

v = c(3, -7, 19)
print("Initial vector v:")
print(v)

append(v, 3)
print("Append 3 on the 4th position:")
print(v)

v = head(v, 2)
print("First 2 positions:")
print(v)

vc = c("unu", "doi", "trei")
print("Vector with objects:")
print(vc)

fvc = factor(vc)
print("Factor:")
print(fvc)

elevi <- c("unu", "unu", "trei", "doi", "trei", "unu", "doi", "doi", "trei", "unu")
note <- c(7, 3, 9, 10, 9, 8, 5, 2, 7, 9)
factorElevi = factor(elevi)

meanByHighschool = by(note, factorElevi, mean)
print("Grade mean by highschool:")
print(meanByHighschool)

Curs 1 - Introduction in Machine Learning/set3.r


library(gdata)     # read.xls()
library(dplyr)
library(ggplot2)

## extract the population data

## this is the Excel file downloaded 2008-10-08 from gapminder.org
pop_xls <- read.xls("gapdata003.xls", verbose = TRUE,
                    fileEncoding =  "ISO-8859-1")
pop_xls %>% str
## 2014: 20455 obs. of  12 variables
## 2010 cleaning code comment: 22903 obs. of  10 variables <-- huh?
## Note: I did not use gdata::read.xls() in 2010; rather, I exported a text file
## from Excel 'by hand'.
pop_xls %>% head

## get rid of vars I will not use; rename vars I keep
pop_raw <- pop_xls %>%
  select(country = Area, year = Year, pop = Population)
pop_raw %>% str
# 'data.frame':  20455 obs. of  3 variables:
# $ country: Factor w/ 253 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year   : int  1800 1820 1870 1913 1950 1951 1952 1953 1954 1955 ...
# $ pop    : Factor w/ 19155 levels "0","1,000","1,000,000",..: 8705 8705 11243 13767 17502 17579 17652 17722 17793 17873 ...

## focus on the years where most of the data is
summary(pop_raw$year)
# Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
# 1491    1935    1967    1953    1988    2030
## AHA! In 2010, this also included 2448 NA's.
## 20455 + 2448 = 22903
## Mystery of the rows solved.
year_freq <- pop_raw %>%
  group_by(year) %>%
  tally

(p <- ggplot(year_freq, aes(x = year, y = n)) +
   geom_bar(stat = "identity"))
p + xlim(c(1800, 2010))
p + xlim(c(1945, 1955)) # huge increase at 1950
p + xlim(c(2000, 2015)) # huge drop at 2009 (data contains some extrapolation)

## keep data from 1950 to 2008
year_min <- 1950
year_max <- 2008
pop_raw <- pop_raw %>%
  filter(year >= year_min & year <= year_max)
str(pop_raw)                             # 14105 obs. of  3 variables:
# 'data.frame':  14105 obs. of  3 variables:
# $ country: Factor w/ 253 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year   : int  1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 ...
# $ pop    : Factor w/ 19155 levels "0","1,000","1,000,000",..: 17502 17579 17652 17722 17793 17873 18364 18453 18531 18602 ...

## get rid of the commas in pop (which is currently a factor!)
pop_raw <- pop_raw %>%
  mutate(pop = levels(pop)[as.numeric(pop)]) %>%
  mutate(pop = as.numeric(gsub(",","", pop)))
pop_raw %>% str # 14105 obs. of  3 variables
# 'data.frame':  14105 obs. of  3 variables:
# $ country: Factor w/ 253 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year   : int  1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 ...
# $ pop    : num  8150368 8284473 8425333 8573217 8728408 ...

## save for now
write.table(pop_raw,
            "01_pop.tsv",
            quote = FALSE, sep = "\t", row.names = FALSE)


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：distance_bv , break voltge 启动电压与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
setwd("D:/data")
library(xlsx)

#读取v~h的数据
de_h<-read.xlsx("voltage.xls",sheetName="ethanol_d", header=TRUE)
da_h<-read.xlsx("voltage.xls",sheetName="acetone_d", header=TRUE)
di_h<-read.xlsx("voltage.xls",sheetName="iso_d", header=TRUE)

#保存pdf
pdf("distance_3liquids_bv.pdf")
#画图-乙醇

plot(de_h$distance, de_h$BV,  col=0, xaxs="i", xlim=c(0, 4.2), ylim=c(2, 3.2),
xlab="Distance (mm)",  mgp=c(1, 0, 0),
tck=0.02,
cex.lab=1.1, ylab=expression(V["bv"](kv))
)

title(main="Break Voltage changes with distance",line=0.5,cex.main=1.1)

model_hBV <- loess(de_h$BV ~ de_h$distance)
fit <- fitted(model_hBV)
ord <- order(de_h$distance)

lines(de_h$distance[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2) # 乙醇的拟合曲线

#画图-丙酮
#points(da_h$distance, da_h$BV,  pch=23, col="blue")

model_aBV <- loess(da_h$BV ~ da_h$distance)
fit <- fitted(model_aBV)
ord <- order(da_h$distance)

lines(da_h$distance[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_h$distance, di_h$BV,  pch=23, col="green")

model_iBV <- loess(di_h$BV ~ di_h$distance)
fit <- fitted(model_iBV)
ord <- order(di_h$distance)

lines(di_h$distance[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("bottomright", bty= "n", c("Ethanol", "Acetone", "Isoproply"), inset=.1,  pch=c(6, 23, 24), col=c("red", "blue", "darkgreen"), lty=2, lwd=2.5, cex=1)

dev.off()


gknotLG = gauss.quad(9000,kind="hermite")
poiscompLG <- function(mu,sig,dat){
  t=mu+sqrt(2*sig)*gknotLG$nodes
  dp=dpois(dat,exp(t))*gknotLG$weights/sqrt(pi)
  evs=dp%*%cbind(1,t,t^2)
  un=evs[2]/evs[1]
  vn=evs[3]/evs[1]-evs[2]^2/evs[1]^2
  c(un,vn,evs[1])
}

getLapLoc<-function(mu,sig,d,cut=20){
  l=rep(0,length(d))
  l[d<cut]=d[d<cut]*sig[d<cut]+mu[d<cut]-lambert_W0(exp((d*sig+mu)[d<cut])*sig[d<cut])
  l[d>cut]=(log(d[d>cut])*d[d>cut]+mu[d>cut]/sig[d>cut])/(d[d>cut]+1/sig[d>cut])
  sh=1/(exp(l)+1/sig)
  pr=sqrt(2*pi*sh)*dpois(d,exp(l))*dnorm(l,mu,sqrt(sig))
  list(l,sh,pr)
}

makeTable <- function(data,muoffs,stabval,maxcut=100){
  maxval=max(data)
  llmu=sapply(0:maxval,function(i){
    if(i<maxcut){
      v=poiscompLG(muoffs,stabval,i)
      (v[1]/v[2]-muoffs/stabval)/(1/v[2]-1/stabval)
    }else{
      (log(i)*i+muoffs/stabval)/(i+1/stabval)
    }
  })
  llprec=sapply(0:maxval,function(i){
    if(i<maxcut){
      1/poiscompLG(muoffs,stabval,i)[2]-1/stabval
    }else{
      me=(log(i)*i+muoffs/stabval)/(i+1/stabval)
      exp(me)-1/stabval
    }
  })
  list(llmu,llprec)
}

fastFit <- function(data,mupri,muadjusts,sigadjusts,scid){
  datind=which(data>0)
  if(length(datind)>0){
  sigadjust=sigadjusts[data[datind]+1]-sigadjusts[1]
  #
  dss=scid[datind,datind,drop=F]*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  sccm=t(scid[datind,,drop=F])
  cminternal=(solve(dss+diag(length(datind))))*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  a1=sccm%*%cminternal%*%t(sccm)
  allinv=(scid-a1)
  vh=as.vector(muadjusts[data+1]*sigadjusts[data+1]+mupri)
  uinv=scid%*%vh-sccm%*%(cminternal%*%(t(sccm)%*%vh))
  list(uinv,allinv)
  }else{
    list(scid%*%as.vector(mupri+muadjusts[1]*sigadjusts[1]),scid)
  }
}

fastMu <- function(data,mupri,muadjusts,sigadjusts,scid){
  datind=which(data>0)
  if(length(datind)>0){
  sigadjust=sigadjusts[data[datind]+1]-sigadjusts[1]
  #
  dss=scid[datind,datind,drop=F]*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  sccm=t(scid[datind,,drop=F])
  cminternal=(solve(dss+diag(length(datind))))*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  #a1=sccm%*%cminternal%*%t(sccm)
  #allinv=(scid-a1)
  sapply(mupri,function(mu){
    vh=as.vector(muadjusts[data+1]*sigadjusts[data+1]+mu)
    uinv=scid%*%vh-sccm%*%(cminternal%*%(t(sccm)%*%vh))
  })
  }else{
    sapply(mupri,function(mu){
      scid%*%as.vector(mu+muadjusts[1]*sigadjusts[1])
    })
  }
}

#cin = solve(covpost+zerovar)
calcPR <- function(data,mupris,muadjusts,sigadjusts,cin){
  datind=which(data>0)
  dv= sapply(mupris,function(mu){
      as.vector((muadjusts[data+1]-mu)%*%cin%*%(muadjusts[data+1]-mu))
  })
  if(length(datind)>0){
  sigadjust=1/(sigadjusts[data[datind]+1]-sigadjusts[1])
  #
  dss=cin[datind,datind,drop=F]*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  sccm=t(cin[datind,,drop=F])
  cminternal=(solve(dss+diag(length(datind))))*outer(sqrt(sigadjust),sqrt(sigadjust),'*')
  da=sapply(mupris,function(mu){
    sum((((muadjusts[data+1]-mu)%*%sccm)^2)%*%cminternal)
    #%*%(t(sccm)%*%(muadjusts[data+1]-mu))
    #as.vector((muadjusts[data+1]-mu)%*%cin%*%(muadjusts[data+1]-mu))
  })
  #a1=sccm%*%cminternal%*%t(sccm)
  #allinv=(cin-a1)
  dv-da
  }else{
    dv
  }
}

makeblocks <- function(xs,bln){
  bind=do.call(c,lapply(1:bln,function(i){
    do.call(c,lapply(1:bln,function(j){
      ofx=length(xs)*(i-1)
      ofy=length(xs)*(j-1)
      c(list(cbind(xs+ofx,xs+ofy)),
        lapply(1:(length(xs)-1),function(i){
          cbind(ofx+xs[-(length(xs):(length(xs)-i+1))],ofy+xs[-(1:i)])
        }))
    }))
  }))
}

toepvals <- function(x,bind){
  sapply(bind,function(i){mean(x[i])})
}

toeptomat <- function(x,bind,sz){
  cmt=matrix(0,sz,sz)
  for(i in 1:length(bind)){
    cmt[bind[[i]]]=x[i]
  }
  cmt[cmt==0]=t(cmt)[cmt==0]
  ind1=1:(sz/2)
  ind2=ind1+(sz/2)
  same.strand.avg=(cmt[ind1,ind1]+cmt[ind2,ind2])/2
  cmt[ind1,ind1]=same.strand.avg
  cmt[ind2,ind2]=same.strand.avg
  cmt
}

topproj <- function(x,bind){
  spp=toepvals(x,bind)
  toeptomat(spp,bind,ncol(x))
}

topiter <- function(matinp,bind){
  matin=topproj(matinp,bind)
  ecp=eigen(matin)
  ecv=ecp$values
  while(min(ecv)< -1e-2){
    print(min(ecv))
    matin=ecp$vectors%*%diag(ecv*(ecv>0))%*%t(ecp$vectors)
    matin=topproj(matin,bind)
    ecp=eigen(matin)
    ecv=ecp$values
  }
  matin+diag(ncol(matin))*0.011
}


setwd("../../contialign/varconti")

kallisto = read.table("output/kallisto/abundance.tsv", stringsAsFactors=F, sep="\t", header=T)
kcounts = as.numeric(kallisto[,4])
names(kcounts) = kallisto[,1]
rust = read.table("output/counts.tsv", stringsAsFactors=F, sep="\t")
rcounts = as.numeric(rust[,2])
names(rcounts) = rust[,1]

cc = cor(log2(1+kcounts)[names(rcounts)], log2(1+rcounts))
plot(log2(1+kcounts), log2(1+rcounts)[names(rcounts)], pch=".", cex=1, ylab="rust counts", xlab="kallisto counts", main=paste(round(cc, digits=2), sum(rcounts), round(sum(kcounts))))
abline(0,1, col="blue")


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(rnorm(30), 10)
  cp = crossprod(x)
} else {
  x = NULL
}

dx = expand(x)

cp_test = crossprod(dx)

comm.print(all.equal(cp, cp_test))

finalize()


# 4. faza: Analiza podatkov

#podatki <- obcine %>% transmute(obcina, povrsina, gostota,
#                                gostota.naselij=naselja/povrsina) %>%
#  left_join(povprecja, by="obcina")
#row.names(podatki) <- podatki$obcina
#podatki$obcina <- NULL

# Število skupin
#n <- 5
#skupine <- hclust(dist(scale(podatki))) %>% cutree(n)

#skupine držav, ki imajo približno enak:

skupno.trgovanje <- function(trg){
  sestejmo.po.letih <- trg %>% group_by(`LETO`,`UVOZ_ALI_IZVOZ`) %>%
    summarise(SKUPAJ=sum(`KOLICINA_€`))
  return(sestejmo.po.letih)
}

skupen.uvoz <- skupno.trgovanje(uvoz.in.izvoz.Slovenije) %>%  filter(str_detect(`UVOZ_ALI_IZVOZ`,"Uvoz"))
skupen.izvoz <- skupno.trgovanje(uvoz.in.izvoz.Slovenije) %>% filter(str_detect(`UVOZ_ALI_IZVOZ`,"Izvoz"))

predict.model.i <- lm(SKUPAJ ~ LETO, data=skupen.izvoz)
predict.model.u <- lm(SKUPAJ ~ LETO, data=skupen.uvoz)

pred.u <- data.frame(LETO=seq(2010,2021,1))
pred.i <- data.frame(LETO=seq(2010,2021,1))

napoved.u <- predict(predict.model.u,pred.u )
napoved.i <- predict(predict.model.i,pred.i )

napoved.u1 <- pred.u %>% mutate(SKUPAJ=predict(predict.model.u, .))
napoved.i1 <- pred.i %>% mutate(SKUPAJ=predict(predict.model.i, .))

napoved.za.izvoz <- ggplot(skupen.izvoz, aes(x=LETO,y=SKUPAJ/1e6)) + geom_point() + geom_smooth() +
  scale_x_continuous(breaks = seq(2010, 2021, by=1)) +
  geom_line(data=napoved.u1, aes(x=LETO,y=SKUPAJ/1e6),color="orange",size=1.3) +
  geom_point(data=napoved.u1, aes(x=LETO,y=SKUPAJ/1e6),color="yellow",size=2) +
  ggtitle("Napoved za izvoz Slovenije") + xlab("leto") + ylab("skupna količina izvoza v milijonih evrov")
#print(napoved.za.izvoz)

napoved.za.uvoz <- ggplot(skupen.uvoz, aes(x=LETO,y=SKUPAJ/1e6)) + geom_point() +
  scale_x_continuous(breaks = seq(2010, 2021, by=1)) + geom_smooth() +
  geom_line(data=napoved.i1, aes(x=LETO,y=SKUPAJ/1e6),color="orange",size=1.3)+
  geom_point(data=napoved.i1, aes(x=LETO,y=SKUPAJ/1e6),color="yellow",size=2.2)+
  ggtitle("Napoved za uvoz Slovenije") + xlab("leto") + ylab("skupna količina uvoza v milijonih evrov")
#print(napoved.za.uvoz)

##########skupine glede na lastnosti ############
skup <- function(trg){
  trg.1 <- trg %>% group_by(`LETO`,`SMTK`,`UVOZ_ALI_IZVOZ`) %>%
    summarise(SKUPAJ=sum(`KOLICINA_€`)) %>% filter(str_detect(`LETO`,"2019"))
  return(trg.1)
}

sk.uvoz <- skup(uvoz.in.izvoz.Slovenije) %>% filter(str_detect(`UVOZ_ALI_IZVOZ`,"Uvoz")) %>%
  rename(Uvoz=SKUPAJ)
skupine.uvoz <- sk.uvoz[-c(3)]
sk.izvoz <- skup(uvoz.in.izvoz.Slovenije) %>% filter(str_detect(`UVOZ_ALI_IZVOZ`,"Izvoz")) %>%
  rename(Izvoz=SKUPAJ)
skupine.izvoz <-sk.izvoz[-c(3)]

zdruzeno.skupaj <- full_join(skupine.uvoz,skupine.izvoz )

zdruzeno.skupaj1 <- zdruzeno.skupaj[-c(1,2)] %>% filter(Izvoz > 1e+3)
izpuscene.panoge <- zdruzeno.skupaj %>% filter(Izvoz < 1e+3)

zdruz <- zdruzeno.skupaj1 %>% as.matrix() %>% scale()
D <- dist(zdruz)
mol <- hclust(D)
#plot(mol,hang=-1, cex=0.3, main=zdruzeno.skupaj1)
p <- cutree(mol,h=2)

molK <- kmeans(zdruzeno.skupaj1,5)

zdruzeno.skupaj2 <- left_join(zdruzeno.skupaj1,zdruzeno.skupaj) %>% select(-3)

graf.skupin.panog <-  zdruzeno.skupaj2 %>% mutate(skupina=molK$cluster) %>%
  ggplot( aes(x=Uvoz,y=Izvoz, col=factor(skupina))) + geom_point(size=3) +
  scale_x_log10() + scale_y_log10() + theme(axis.text.x=element_blank(),
                                            axis.ticks.x=element_blank(),
                                            axis.text.y=element_blank(),
                                            axis.ticks.y=element_blank()) +
  geom_abline(slope=1, intercept=0,linetype="dashed", color = "orange")
#print(graf.skupin.panog)


#############################
# Name: Inverse Gamma Landslide Fit
# Author: Faith Taylor
# Last updated : 02/02/2014
# Purpose: Fit inverse gamma pdf to landslide data and test gooness of fit
# Copyright: (c) 2014 Faith Taylor
# This program is free software under the GNU General Public Licence (>=v2).
##############################

# Load modules
library(MCMCpack)
library(MASS)
library(PearsonDS)
library(calibrate)
library(sfmisc)
# Initial definitions
# 1. The inverse gamma log likelihood function

ll = function(par){
  if(par[1]>0 & par[2]>0 & par[3]<min(data)) return( -sum(log(dinvgamma(data-    par[3],par[1],par[2]))) )
  else return(Inf)
}
# 2. Make a series of x values (Length to width ratios)
xs = seq(1,100, 0.01)

# 3. Table of values for bin sizes
#lower_upper_vals = read.csv("lower_upper_vals.csv")

rm(A)
#parmar x x top right-side
par(mar= c(8,5,1,1), family = "serif")
LWRrainbow_pal = c("#902525", "#ff0707", "#f18c37", "#fcfc02", "#91cd4e", "#1EBB66", "#07b1f0", "#0069bd", "#001055", "#68259b")

lower = lower_upper_vals[1,2]
upper = lower_upper_vals[1,3]
phrase1 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[2,2]
upper = lower_upper_vals[2,3]
phrase2 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[3,2]
upper = lower_upper_vals[3,3]
phrase3 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[4,2]
upper = lower_upper_vals[4,3]
phrase4 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[5,2]
upper = lower_upper_vals[5,3]
phrase5 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[6,2]
upper = lower_upper_vals[6,3]
phrase6 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[7,2]
upper = lower_upper_vals[7,3]
phrase7 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[8,2]
upper = lower_upper_vals[8,3]
phrase8 = bquote(bold(.(lower)~ m^2 ~""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[9,2]
upper = lower_upper_vals[9,3]
phrase9 = bquote(bold(.(lower)~ m^2 ~ ""<= "" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
lower = lower_upper_vals[10,2]
upper = lower_upper_vals[10,3]
phrase10 = bquote(bold( ~bolditalic(A[L]) ~ ""<= "" ~bold(.(lower) ~ m^2)))

roundUp <- function(x, nice=c(1,2,4,5,6,8,10)) {
  if(length(x) != 1) stop("'x' must be of length 1")
  10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}

#par(mfrow=c(4,3))
#alldata = northridge_new_lwrs[!is.na(northridge_new_lwrs)]
alldata = guat_data[!is.na(guat_data)]
max_data = max(alldata)
round_max_data = roundUp(max_data)

#plot(1,1,   col = "White",  xaxs ="i", yaxs = "i", ylim = c(0,20), xlim = c(0,35))
#for (h in 1:10){
#  boxplot(c(Umbria_lwrs[h], guat_elip_binlwrs[h], northridge_new_lwrs[h]), range = 0, lwd = 1, lty = 1, col = LWRrainbow_pal[h],  xaxs ="i", yaxs = "i", add = TRUE, at = c((1+(h*3)),(2+(h*3)),(3+(h*3))))
#}

# Create boxplot of all data by category
par(mar= c(10,5,1,1), family = "serif")
boxplot(nridge_data, range = 0, lwd = 1, lty = 1, col = LWRrainbow_pal, axes = FALSE, xaxs ="i", yaxs = "i", ylim = c(0,round_max_data+5))
axis(1, tck = 0, at = seq(0,11,1), labels = FALSE, lwd = 2)
axis(2, lwd = 2, at = seq(0, round_max_data+5, 5), las = 1, cex.axis = 1.5, tck = 0.03)
axis(3, tck = 0, labels = FALSE, at = c(0,11), lwd = 2)
axis(4, lwd = 2, at = seq(0, round_max_data+5, 5), las = 1, cex.axis = 1.5, labels = FALSE, tck = 0.03)
title(ylab = expression(bold("Length to Width Ratio, ") ~bolditalic("LWR")), cex.lab = 1.5, line = 3)
title(xlab = expression(bold("Landslide Area Category, ") ~bolditalic(C[A[L] ]) ~bold((m^2))), cex.lab = 1.5, line = 9)
labels = list( phrase1, phrase2, phrase3, phrase4, phrase5, phrase6, phrase7, phrase8, phrase9, phrase10)
text(1:10, par("usr")[3] - 0.25, srt = 45, adj = 1,labels = do.call("expression", labels), xpd = TRUE)
for (g in 1:10){
  dataset = nridge_data[g]
  max_cat = max(dataset[!is.na(dataset)]) + 1.5
  num = length(dataset[!is.na(dataset)])
  faith = bquote(bolditalic("n = " ~bold(.(num))))
  text(g,max_cat, srt = 90, labels = faith, col = "grey")
  med = median(dataset[!is.na(dataset)])
  print(med)
}

# Read data
for (A in 1:10){
  rm(shape_f, location_f, scale_f, Proportion, all_d, quants, m, ests, estsa, b, bin, bin_boundaries, binsizes, bootstrap_location, bootstrap_location, bootstrap_scale, bootstrap_scale_recip, bootstrap_shape, cumulative_x, data, dif, dval, emp_bin_mids, emp_cum_y, emp_freq_dens, emp_freqs, emp_prob_dens, empirical_D, g, h, i, k, label, loc_max, location_s, logdat, loghist, lower, lower_pdf, max_pdf, max_x_d, maxx, median_pdf,  mle, n, numbins, params, parset, pdf, phrase, phrase2, rand_D, rand_cdf, rand_lwrs, rand_lwrs_cumulative, location_1, scale_a, shape_a, shape_rho, smooth_teo_cum, startlocation, startscale, startshape, teo_cdf, teo_cum, testresult, upper, upper_pdf, val, yupper, yupper2)

  # 1. Initialising steps
  # Name the bin category (e.g. LW1 is landslides between 0 and 100 m2)
  bin = paste("Northridge","LW", A, sep = "")
  # Add in here the text for lanslide bin size
  lower = lower_upper_vals[A,2]
  upper = lower_upper_vals[A,3]
  phrase = bquote(bold(.(lower)~ m^2 ~"<" ~bolditalic(A[L]) ~ "<" ~bold(.(upper) ~ m^2)))
  variablej = paste("phrase_", A, sep = "")
  assign(variablej, phrase)
  # Read a column of the table
  data = northridge_new_lwrs[A]
  #Strip out any non numeric rows
  data = data[!is.na(data)]
  #Calculate the number of observations
  n = length(data)
  phrase2 = bquote(bolditalic( "n = "~.(n)))

  # 2. Fitting an inverse gamma pdf to the raw data
  # Use mle fitting to find the parameters that best fit the lwrs in this area category. This uses the optim function
  try((mle = optim(c(1,1,1),ll)), silent = FALSE)

  # Obtain initial parameter values
  params = mle$par
  shape_rho = params [1]
  scale_a = params[2]
  location_s = params[3]

  # Produce a plot of the observed data and the pdf/cdf fit to the data (non cumulative then cumulative)
  # Evaluate the inverse gamma pdf for each of the x values using the parameters from MLE fitting
  pdf = dpearsonV(xs, shape_rho, location_s, (1/scale_a))

  # Bin the raw data

  logdat = log(data)
  loghist = hist(logdat, plot = FALSE)
  bin_boundaries = exp(loghist$breaks)
  emp_bin_mids = exp(loghist$mids)
  emp_freqs = loghist$counts
  #calculate bin sizes
  numbins = length(emp_bin_mids)
  binsizes = numeric(numbins)
  for (k in 1:numbins){
    dif = bin_boundaries[k +1] - bin_boundaries[k]
    binsizes[k] = dif}

  emp_freq_dens = emp_freqs/binsizes
  emp_prob_dens = emp_freqs/(binsizes * n)

  # Plot the pdf and raw data
  par(mar= c(5,6,2,2))
  plot(xs, pdf, type = "l", col = rgb(1,0,0), lwd = 3, ylim= c(10^-8, 10), log = "xy", ylab = "", xlab=expression(bold("Length to Width Ratio, "~bolditalic(LWR))), axes = FALSE, yaxs ="i", xaxs = "i", cex.lab = 1.7 )
  ticks = c(0.1,1,2,3,4,5,6,7,8,9,10,20,30,40,50,60,70,80,90,100)
  title(ylab = expression(bold("Probability Density, " ~bolditalic(p(LWR)))), cex.lab = 1.7, line = 4)
  axis(1, at = c(1,10, 100), labels =( expression(~bold(10^0),~bold(10^1), ~bold(10^2))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7)
  yticks = c(0.000000001, 0.000000002, 0.000000003, 0.000000004, 0.000000005,  0.000000006, 0.000000007, 0.000000008, 0.000000009, 0.00000001, 0.00000002, 0.00000003, 0.00000004, 0.00000005,  0.00000006, 0.00000007, 0.00000008, 0.00000009,0.0000001, 0.0000002, 0.0000003, 0.0000004, 0.0000005,  0.0000006, 0.0000007, 0.0000008, 0.0000009, 0.000001, 0.000002, 0.000003,  0.000004, 0.000005, 0.000006, 0.000007, 0.000008, 0.000009, 0.00001, 0.00002, 0.00003, 0.00004, 0.00005, 0.00006, 0.00007, 0.00008, 0.00009,0.0001, 0.0002, 0.0003, 0.0004, 0.0005, 0.0006, 0.0007, 0.0008, 0.0009, 0.001, 0.002, 0.003, 0.004, 0.005, 0.006, 0.007, 0.008, 0.009, 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, 0.09, 0.1, 0.2, 0.3, 0.4,0.5,0.6,0.7,0.8,0.9,1,2,3,4,5,6,7,8,9,10)
  axis(2, at = c(0.000000001, 0.00000001,0.0000001, 0.000001, 0.00001, 0.0001, 0.001, 0.01, 0.1, 1,10), labels =(expression(~bold(10^-9),~bold(10^-8),~bold(10^-7),~bold(10^-6),~bold(10^-5), ~bold(10^-4), ~bold(10^-3), ~bold(10^-2), ~bold(10^-1), ~bold(10^0) , ~bold(10^1))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7, las = 1)
  axis(1, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(2, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(3, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(4, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  points(emp_bin_mids, emp_prob_dens, pch = 20)
  val <- substitute("value" == phrase, list(phrase = phrase))
  legend("topright", do.call("expression", list(phrase, "Observed", "Inverse Gamma pdf", phrase2)), lty = c(NA, NA, 1), col = c(NA, "black", "red"), pch = c(NA, 20, NA), lwd = c(NA, NA, 2),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)

  ## Now plot the cumulative
  # Sort the observed data
  cumulative_x = sort(data)
  emp_cum_y = (1:n)/n
  emp_cum_y = sort(emp_cum_y, decreasing = TRUE)
  teo_cum = ppearsonV(cumulative_x, shape_rho, location_s, (1/scale_a), lower.tail = FALSE)
  empirical_D = max(abs(emp_cum_y - teo_cum))
  smooth_teo_cum = ppearsonV(xs, shape_rho, location_s, (1/scale_a), lower.tail = FALSE)
  dev.new()
  par(mar= c(5,6,2,2))
  #Plot both distributions and check manually
  plot(xs, smooth_teo_cum, col = "red", type ="l", lwd = 2, axes = FALSE, xaxs = "i", yaxs = "i", xlim = c(1, (max(data))+5), ann = FALSE, ylim = c(0,1))
  points(cumulative_x, emp_cum_y, col = "blue", pch = 20)
  title(ylab = expression(bold("Cumulative Probability, " ~bolditalic(F(LWR)))), cex.lab = 1.5, line = 3)
  title(xlab = expression(bold("Length to Width Ratio, " ~bolditalic(LWR))), cex.lab = 1.5)
  axis(1, lwd = 2, tck =0.03, cex.axis = 1.5, font =2, at = c(1,(seq(0, ((max(data))+10), 5))))
  axis(2, lwd = 2, tck =0.03, cex.axis = 1.5, font =2, at = seq(0,1, by = 0.2), las =1)
  axis(3, lwd = 2, tck =0.03, labels = FALSE, at = c(1,(seq(0, ((max(data))+10), 5))))
  axis(4, lwd = 2, tck =0.03, labels = FALSE, at = seq(0,1, by = 0.2), las =1)
  legend("topright", do.call("expression", list(phrase, "Observed", "Inverse Gamma cdf", phrase2)), lty = c(NA, NA, 1), col = c(NA, "blue", "red"), pch = c(NA, 20, NA), lwd = c(NA, NA, 2),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)

  all_d = emp_cum_y - teo_cum
  g = match((min(emp_cum_y - teo_cum)), all_d)
  h = match((max(emp_cum_y - teo_cum)), all_d)
  if (abs(all_d[g]) > abs(all_d[h])) maxx = g else maxx = h
  max_x_d = cumulative_x[maxx]

  dev.new()
  par(mar= c(5,6,2,2))
  plot(cumulative_x, all_d, xlab = "LWR",  col ="darkgreen", pch = 20, xlim = c(1, (max(data))+5), ylim =c(-0.2, 0.2), xaxs ="i", yaxs = "i", ann = FALSE, axes = FALSE )
  axis(1, lwd = 2, tck =0.03, cex.axis = 1.5, font =2, at = c(1,(seq(0, ((max(data))+10), 5))))
  axis(3, lwd = 2, tck =0.03, labels = FALSE, at = c(1,(seq(0, ((max(data))+10), 5))))
  axis(2, at = seq( -0.2, 0.2, 0.05 ), lwd = 2, cex.lab = 1.2, las = 1, tck  = 0.03, cex.axis = 1.5)
  axis(4, at = seq(-0.2, 0.2, 0.05) , lwd = 2, labels = FALSE, tck  = 0.03)
  title(ylab = expression(bold("Obs. - Theoret.,  ")~bolditalic(F(LWR)[obs]~ " -" ~F(LWR)[theo])),cex.lab = 1.5, line = 4)
  title(xlab = expression(bold("Length to Width Ratio, " ~bolditalic(LWR))), cex.lab = 1.5)
  points(max_x_d, all_d[maxx], col = "red", pch = 8)
  label = round(max_x_d, 2)
  label = paste("LWR =", label)
  textxy(max_x_d, all_d[maxx],label, cx = 1.3, dcol = "red")
  abline(0,0, lty = 2, lwd = 2, col ="grey" )
  legend("topright", do.call("expression", list(phrase,  phrase2)), lty = c(NA, NA), col = c(NA, NA), pch = c(NA, NA), lwd = c(NA, NA),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)

  # Use monte carlo modelling to test goodness of fit
  testresult = numeric(2500)
  dval = numeric(2500)

  rm(mle)
  rm(params)
  #Set up for loop
  for (i in 1:2500){
    # Generate n random values of LWR using the parameters fit to the observed data. N should be the same as the number of observed LWRS.
    rand_lwrs = (rpearsonV(n, shape_rho,  location_s,  (1/scale_a)))
    rand_lwrs_cumulative = sort(rand_lwrs)
    # Use MLE to fit an inverse gamma to these randomly generated LWRs

    # Optimise the parameter values
    mle = optim(c(1.4,0.001,-0.0001),ll)
    params = mle$par
    shape_f = params [1]
    #Scale is the reciprocal of the actual scale value
    scale_f = 1/(params[2])
    location_f = params [3]
    parset = list(shape_f, location_f, scale_f)
    teo_cdf = ppearsonV(rand_lwrs_cumulative, params = parset, lower.tail = FALSE)
    rand_cdf = (1:n)/n
    rand_cdf = sort(rand_cdf, decreasing = TRUE)
    rand_D= max(abs(rand_cdf - teo_cdf))
    dval[i] = rand_D
    if (rand_D <= empirical_D){ testresult[i] = 0}
    if (rand_D > empirical_D){ testresult[i] = 1}}

  ### The number of times the Empirical D value is smaller than the Monte carlo D value ###
  sum(testresult)
  Proportion = sum(testresult) / 2500
  ### Proportion of times the D value is smaller than the Monte Carlo D value ###
  dev.new()
  par(mar= c(5,6,2,2))
  yupper = (round(max(dval), 2)) + 0.1
  yupper2 = round(yupper, 1)
  boxplot(dval, range = 0, lwd = 2, lty = 1, axes = FALSE, xaxs ="i", yaxs = "i", ylim = c(0, yupper2) )
  axis(1, tck = 0, labels = FALSE, at = c(0,2), lwd = 2)
  axis(2, lwd = 2, at = seq(0, yupper2, 0.05), las = 1, cex.axis = 1.5, tck = 0.03)
  axis(3, tck = 0, labels = FALSE, at = c(0,2), lwd = 2)
  axis(4, lwd = 2, at = seq(0, yupper2, 0.05), las = 1, cex.axis = 1.5, labels = FALSE, tck = 0.03)
  title(ylab = expression(bold(D - Value)), cex.lab = 1.5, line = 4)
  points(empirical_D, col = "red", pch = "+", cex = 2)
  abline((quantile(dval, 0.9)), 0, lty = 2, col = "grey", lwd = 2)
  abline((quantile(dval, 0.95)), 0, lty = 2, col = "lightgrey", lwd = 2)
  legend("topright", do.call("expression", list(phrase,  phrase2)), lty = c(NA, NA), col = c(NA, NA), pch = c(NA, NA), lwd = c(NA, NA),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)

  # Now try producing bootstapped samples of the real data and fitting to each sample
  startshape = shape_rho
  startscale = scale_a
  startlocation = location_s

  estsa <- sapply(1:1000, function(i) {

  #Sample the data with replacement (the bootstrapping part)
    xi <- sample(data, size = n, replace = TRUE)
    ll = function(par){
    if(par[1]>0 & par[2]>0 & par[3]<min(xi)) return( -sum(log(dinvgamma(xi-    par[3],par[1],par[2]))) )
    else return(Inf)}

    optim(c(startshape, startscale, startlocation),ll)})

  bootstrap_shape = numeric(1000)
  bootstrap_location = numeric(1000)
  bootstrap_scale = numeric(1000)
  bootstrap_rollover = numeric(1000)
  for (b in 1:1000){
  bootstrap_shape [b] = estsa[,b]$par[1]
  bootstrap_location[b] = estsa[,b]$par[3]
  bootstrap_scale[b]  = estsa[,b]$par[2]}
  bootstrap_rollover[b] = (bootstrap_location[b]/(bootstrap_shape [b] + 1))+  bootstrap_scale[b]
  bootstrap_scale_recip = 1/bootstrap_scale

  m = matrix(c(bootstrap_shape, bootstrap_location, bootstrap_scale_recip), nrow= 1000, ncol =3)
  ests = apply(m, 1, function(x) dpearsonV(xs, params = x))

  #Plot the first distritbution
  par(mar= c(5,6,2,2))
  plot(xs, ests[,1], type = "l", col=rgb(.6, .6, .6, .1), ylim= c(10^-8, 10), log = "xy", ylab = "", xlab=expression(bold("Length to Width Ratio, "~bolditalic(LWR))), axes = FALSE, yaxs ="i", xaxs = "i", cex.lab = 1.7 )
  ticks = c(0.1,1,2,3,4,5,6,7,8,9,10,20,30,40,50,60,70,80,90,100)
  title(ylab = expression(bold("Probability Density, " ~bolditalic(p(LWR)))), cex.lab = 1.7, line = 4)
  axis(1, at = c(1,10, 100), labels =( expression(~bold(10^0),~bold(10^1), ~bold(10^2))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7)
  yticks = c(0.000000001, 0.000000002, 0.000000003, 0.000000004, 0.000000005,  0.000000006, 0.000000007, 0.000000008, 0.000000009, 0.00000001, 0.00000002, 0.00000003, 0.00000004, 0.00000005,  0.00000006, 0.00000007, 0.00000008, 0.00000009,0.0000001, 0.0000002, 0.0000003, 0.0000004, 0.0000005,  0.0000006, 0.0000007, 0.0000008, 0.0000009, 0.000001, 0.000002, 0.000003,  0.000004, 0.000005, 0.000006, 0.000007, 0.000008, 0.000009, 0.00001, 0.00002, 0.00003, 0.00004, 0.00005, 0.00006, 0.00007, 0.00008, 0.00009,0.0001, 0.0002, 0.0003, 0.0004, 0.0005, 0.0006, 0.0007, 0.0008, 0.0009, 0.001, 0.002, 0.003, 0.004, 0.005, 0.006, 0.007, 0.008, 0.009, 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, 0.09, 0.1, 0.2, 0.3, 0.4,0.5,0.6,0.7,0.8,0.9,1,2,3,4,5,6,7,8,9,10)
  axis(2, at = c(0.000000001, 0.00000001,0.0000001, 0.000001, 0.00001, 0.0001, 0.001, 0.01, 0.1, 1,10), labels =(expression(~bold(10^-9),~bold(10^-8),~bold(10^-7),~bold(10^-6),~bold(10^-5), ~bold(10^-4), ~bold(10^-3), ~bold(10^-2), ~bold(10^-1), ~bold(10^0) , ~bold(10^1))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7, las = 1)

   for(i in 2:500)lines(xs, ests[, i], col=rgb(.6, .6, .6, .1))
  quants <- apply(ests, 1, quantile, c(0.025, 0.5, 0.975))
  median_pdf = quants[2,]
  lower_pdf = quants[3,]
  upper_pdf = quants[1,]
  lines(xs, quants[1, ], col="red", lwd=1.5, lty=2)
  lines(xs, quants[3, ], col="red", lwd=1.5, lty=2)
  lines(xs, quants[2, ], col="darkred", lwd=2)
  axis(1, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(2, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(3, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  axis(4, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
  legend("topright", do.call("expression", list(phrase, "Fit to bootstrapped samples", "Median fit", "5th/95th Percentile Fit", phrase2)), lty = c(NA, 1,1, 2, NA), col = c(NA, "Grey", "red", "red", NA),  lwd = c(NA, 0.5,2,1, NA),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)

  bootstrap_rollover = numeric(1000)
  for(i in 1:1000){
    max_pdf = max(ests[,i])
    loc_max = match(max_pdf, ests[,i])
    location_1 = xs[loc_max]
    bootstrap_rollover[i] = location_1}

  variable1 = paste("shape", bin, sep = "")
  assign(variable1, bootstrap_shape)
  variable2 = paste("location", bin, sep = "")
  assign(variable2, bootstrap_location)
  variable3 = paste("scale", bin, sep = "")
  assign(variable3, bootstrap_scale)
  variable4 = paste("rollover", bin, sep = "")
  assign(variable4, bootstrap_rollover)
  variable5 = paste("d", bin, sep = "")
  assign(variable5, empirical_D)
  variable6 = paste("dprop", bin, sep = "")
  assign(variable6, Proportion)
  variable7 = paste("median_pdf", bin, sep = "")
  assign(variable7, median_pdf)
  variable8 = paste("upper_pdf", bin, sep = "")
  assign(variable8, upper_pdf)
  variable9 = paste("lower_pdf", bin, sep = "")
  assign(variable9, lower_pdf)

  print(bin)
}

##################
# dev.new()
# par(mar= c(5,6,2,2))
# plot(xs, median_pdfTaiwanLW3, type = "l", col = "darkred", lwd = 3, ylim= c(10^-8, 10), log = "xy", ylab = "", xlab=expression(bold("Length to Width Ratio, "~bolditalic(LWR))), axes = FALSE, yaxs ="i", xaxs = "i", cex.lab = 1.7 )
# ticks = c(0.1,1,2,3,4,5,6,7,8,9,10,20,30,40,50,60,70,80,90,100)
# title(ylab = expression(bold("Probability Density, " ~bolditalic(p(LWR)))), cex.lab = 1.7, line = 4)
# axis(1, at = c(1,10, 100), labels =( expression(~bold(10^0),~bold(10^1), ~bold(10^2))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7)
# yticks = c(0.000000001, 0.000000002, 0.000000003, 0.000000004, 0.000000005,  0.000000006, 0.000000007, 0.000000008, 0.000000009, 0.00000001, 0.00000002, 0.00000003, 0.00000004, 0.00000005,  0.00000006, 0.00000007, 0.00000008, 0.00000009,0.0000001, 0.0000002, 0.0000003, 0.0000004, 0.0000005,  0.0000006, 0.0000007, 0.0000008, 0.0000009, 0.000001, 0.000002, 0.000003,  0.000004, 0.000005, 0.000006, 0.000007, 0.000008, 0.000009, 0.00001, 0.00002, 0.00003, 0.00004, 0.00005, 0.00006, 0.00007, 0.00008, 0.00009,0.0001, 0.0002, 0.0003, 0.0004, 0.0005, 0.0006, 0.0007, 0.0008, 0.0009, 0.001, 0.002, 0.003, 0.004, 0.005, 0.006, 0.007, 0.008, 0.009, 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, 0.09, 0.1, 0.2, 0.3, 0.4,0.5,0.6,0.7,0.8,0.9,1,2,3,4,5,6,7,8,9,10)
# axis(2, at = c(0.000000001, 0.00000001,0.0000001, 0.000001, 0.00001, 0.0001, 0.001, 0.01, 0.1, 1,10), labels =(expression(~bold(10^-9),~bold(10^-8),~bold(10^-7),~bold(10^-6),~bold(10^-5), ~bold(10^-4), ~bold(10^-3), ~bold(10^-2), ~bold(10^-1), ~bold(10^0) , ~bold(10^1))), lty = 1, lwd = 0, tck = 0, cex.axis = 1.7, las = 1)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW1)), col = rgb(1,0,0,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW2)), col = rgb(1,0.5,0,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW3)), col = rgb(1,1,0.2,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW4)), col = rgb(0.5,1,0.2,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW5)), col = rgb(0.2,0.5,1,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW6)), col = rgb(0.5,0.5,1,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW7)), col = rgb(0.5,0  ,1  ,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW8)), col = rgb(1,1,1 ,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW9)), col = rgb(1,0.5,1 ,0.3), border = NA)
# #polygon(c(lwr, rev(lwr)), c(lower_pdfTaiwanLW1, rev(upper_pdfTaiwanLW10)), col = rgb(0.3,0,0.5,0.3), border = NA)
#
# #points(xs, median_pdfTaiwanLW1, col = "darkred", type = "l", lwd = 3)
# #points(xs, median_pdfTaiwanLW2, col = "red", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW3, col = "orange", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW4, col = "gold", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW5, col = "yellow", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW6, col = "lawngreen", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW7, col = "darkgreen", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW8, col = "blue", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW9, col = "darkblue", type = "l", lwd = 3)
# points(xs, median_pdfTaiwanLW10, col = "magenta", type = "l", lwd = 3)
# axis(1, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
# axis(2, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
# axis(3, ticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
# axis(4, yticks, labels = NA, lty = 1, lwd = 2, tck = 0.01)
# legend("topright", do.call("expression", list(phrase_1, phrase_2, phrase_3, phrase_4, phrase_5, phrase_6, phrase_7, phrase_8, phrase_9, phrase_10)), lty = 1, col = c("darkred", "red", "Orange", "gold", "yellow", "lawngreen", "darkgreen", "Blue", "darkblue", "Magenta"),  lwd = 2 ,bty = 'o', cex = 0.8, box.lwd = 2, inset = 0.01)
#
# #
# dev.new()
# par(mar= c(8,6,2,2))
# boxplot(rolloverTaiwanLW1, rolloverTaiwanLW2, rolloverTaiwanLW3, rolloverTaiwanLW4, rolloverTaiwanLW5, rolloverTaiwanLW6, rolloverTaiwanLW7, rolloverTaiwanLW8, rolloverTaiwanLW9, rolloverTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xaxs = "i", yaxs = "i", ylim = c(1, 5))
# #boxplot(rolloverTaiwanLW3, rolloverTaiwanLW4, rolloverTaiwanLW5, rolloverTaiwanLW6, rolloverTaiwanLW7, rolloverTaiwanLW8, rolloverTaiwanLW9, rolloverTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xlim = c(0, 11), xaxs = "i", yaxs = "i", ylim = c(1, 5), at  = c( 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7))
# box(lwd = 2)
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("Location of Max. Probability, " ~  bolditalic((LWR)))), line = 3, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 5, cex.lab = 1.5)
#
#
# dev.new()
# par(mar= c(8,6,2,2))
# boxplot(locationTaiwanLW1, locationTaiwanLW2, locationTaiwanLW3, locationTaiwanLW4, locationTaiwanLW5, locationTaiwanLW6, locationTaiwanLW7, locationTaiwanLW8, locationTaiwanLW9, locationTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xaxs = "i", yaxs = "i")
# #boxplot(locationTaiwanLW3, locationTaiwanLW4, locationTaiwanLW5, locationTaiwanLW6, locationTaiwanLW7, locationTaiwanLW8, locationTaiwanLW9, locationTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xlim = c(0, 11), xaxs = "i", yaxs = "i",  at  = c( 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7))
# box(lwd = 2)
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("Location Parameter Value, " ~bolditalic(s))), line = 4, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 5, cex.lab = 1.5)
#
# dev.new()
# par(mar= c(8,6,2,2))
# #boxplot(scaleTaiwanLW1, scaleTaiwanLW2, scaleTaiwanLW3, scaleTaiwanLW4, scaleTaiwanLW5, scaleTaiwanLW6, scaleTaiwanLW7, scaleTaiwanLW8, scaleTaiwanLW9, scaleTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xaxs = "i", yaxs = "i", ylim = c(0,40))
# boxplot(scaleTaiwanLW3, scaleTaiwanLW4, scaleTaiwanLW5, scaleTaiwanLW6, scaleTaiwanLW7, scaleTaiwanLW8, scaleTaiwanLW9, scaleTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, ylim = c(0,50), xlim = c(0, 11), xaxs = "i", yaxs = "i",  at  = c( 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7))
# box(lwd = 2)
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2, add= TRUE)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("Scale Parameter Value, " ~bolditalic(a))), line = 4, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 6, cex.lab = 1.5)
#
# dev.new()
# par(mar= c(8,6,2,2))
# #boxplot(shapeTaiwanLW1, shapeTaiwanLW2, shapeTaiwanLW3, shapeTaiwanLW4, shapeTaiwanLW5, shapeTaiwanLW6, shapeTaiwanLW7, shapeTaiwanLW8, shapeTaiwanLW9, shapeTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xaxs = "i", yaxs = "i", ylim = c(0,15))
# boxplot(shapeTaiwanLW3, shapeTaiwanLW4, shapeTaiwanLW5, shapeTaiwanLW6, shapeTaiwanLW7, shapeTaiwanLW8, shapeTaiwanLW9, shapeTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, ylim = c(0,20), xlim = c(0, 11), xaxs = "i", yaxs = "i",  at  = c( 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7))
# box(lwd = 2)
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("shape Parameter Value, " ~bolditalic(rho))), line = 4, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 6, cex.lab = 1.5)
#
#
# Taiwan_median_shape = numeric(10)
# Taiwan_median_location = numeric(10)
# Taiwan_median_scale = numeric(10)
# Taiwan_median_rollover = numeric(10)
# for (j in 1:10){
#   bina = paste("shapeTaiwan","LW", j, sep = "")
#   binb = paste("locationTaiwan","LW", j, sep = "")
#   binc = paste("scaleTaiwan","LW", j, sep = "")
#   bind = paste("rolloverTaiwan","LW", j, sep = "")
#   Taiwan_median_shape[j] = median(get(bina))
#   Taiwan_median_location[j] = median(get(binb))
#   Taiwan_median_scale[j] = median(get(binc))
#   Taiwan_median_rollover[j] = median(get(bind))}
#
# Taiwan_q25_shape = numeric(10)
# Taiwan_q25_location = numeric(10)
# Taiwan_q25_scale = numeric(10)
# Taiwan_q25_rollover = numeric(10)
# for (j in 1:10){
#   bina = paste("shapeTaiwan","LW", j, sep = "")
#   binb = paste("locationTaiwan","LW", j, sep = "")
#   binc = paste("scaleTaiwan","LW", j, sep = "")
#   bind = paste("rolloverTaiwan","LW", j, sep = "")
#   Taiwan_q25_shape[j] = quantile(get(bina), 0.25)
#   Taiwan_q25_location[j] = quantile(get(binb), 0.25)
#   Taiwan_q25_scale[j] = quantile(get(binc), 0.25)
#   Taiwan_q25_rollover[j] = quantile(get(bind), 0.25)}
#
# Taiwan_q75_shape = numeric(10)
# Taiwan_q75_location = numeric(10)
# Taiwan_q75_scale = numeric(10)
# Taiwan_q75_rollover = numeric(10)
# for (j in 1:10){
#   bina = paste("shapeTaiwan","LW", j, sep = "")
#   binb = paste("locationTaiwan","LW", j, sep = "")
#   binc = paste("scaleTaiwan","LW", j, sep = "")
#   bind = paste("rolloverTaiwan","LW", j, sep = "")
#   Taiwan_q75_shape[j] = quantile(get(bina), 0.75)
#   Taiwan_q75_location[j] = quantile(get(binb), 0.75)
#   Taiwan_q75_scale[j] = quantile(get(binc), 0.75)
#   Taiwan_q75_rollover[j] = quantile(get(bind), 0.75)}
#
# dev.new()
# par(mar= c(8,6,2,2))
# #boxplot(shapeTaiwanLW1, shapeTaiwanLW2, shapeTaiwanLW3, shapeTaiwanLW4, shapeTaiwanLW5, shapeTaiwanLW6, shapeTaiwanLW7, shapeTaiwanLW8, shapeTaiwanLW9, shapeTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, xaxs = "i", yaxs = "i", ylim = c(0,15))
# boxplot(shapeTaiwanLW3, shapeTaiwanLW4, shapeTaiwanLW5, shapeTaiwanLW6, shapeTaiwanLW7, shapeTaiwanLW8, shapeTaiwanLW9, shapeTaiwanLW10, lty =1, lwd =1.5, range = 0, pch =1, axes = FALSE, ylim = c(0,20), xlim = c(0, 11), xaxs = "i", yaxs = "i",  at  = c( 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7))
# box(lwd = 2)
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("shape Parameter Value, " ~bolditalic(rho))), line = 4, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 6, cex.lab = 1.5)
#
#
# errbar(1:10, Northridge_median_shape, Northridge_q25_shape, Northridge_q75_shape, col = "aquamarine4", pch = 0, ylim = c(1,7),xaxt='n', yaxt='n',xlab=NA,ylab=NA,xaxs = "i", yaxs = "i", xlim = c(0, 11), cex = 1.3, lwd = 4 )
# par(new = TRUE)
# errbar(1:10, Guatemala_median_shape, Guatemala_q25_shape, Guatemala_q75_shape, col = "orange", pch = 2,ylim = c(1,7),xaxt='n', yaxt='n',xlab=NA,ylab=NA,xaxs = "i", yaxs = "i", xlim = c(0, 11), cex = 1.3, lwd = 4 )
# par(new = TRUE)
# errbar(1:10, Umbria_median_shape, Umbria_q25_shape, Umbria_q75_shape, col = "DarkOrchid", pch = 4,ylim = c(1,7),xaxt='n', yaxt='n',xlab=NA,ylab=NA,xaxs = "i", yaxs = "i", xlim = c(0, 11), cex = 1.3, lwd = 4 )
# axis(1, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), labels =( expression(~bold("0"), ~bold("100"), ~bold("200"), ~bold("400"), ~bold("800"), ~bold("1,600"), ~bold("3,200"), ~bold("6,400"), ~bold("12,800"), ~bold("25,600"), ~bold("250,000"))), lty = 1, lwd = 2, tck = 0.03, cex.axis = 1.3, las =2)
# box(lwd = 2)
# axis(2, lty =1, lwd = 2, tck = 0.03, cex.axis = 1.5, font = 2, las =1)
# axis(3, at = c(0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.5, 7.5, 8.5, 9.5, 10.7), tck = 0.03, labels = FALSE, lwd = 2)
# axis(4, lty = 1, lwd = 2, tck = 0.02, labels = FALSE)
# title(ylab = expression(bold ("shape Parameter Value, " ~bolditalic(rho))), line = 4, cex.lab = 1.5)
# title(xlab=expression(bold ("Landslide Area Bin, "~bolditalic(A[L]) ~(m^2))) , line = 6, cex.lab = 1.5)
# legend("topright", c("Northridge", "Guatemala", "Umbria"), col = c("aquamarine4", "orange", "DarkOrchid"), pch = c(0,2,4),bty = 'o', cex = 1.1, box.lwd = 2, inset = 0.01)


set.seed(42)

train <- read.csv('data/train.csv', sep=',')
# select subset of the data to keep it managable
train <- train[1:5,c(1,2,6,10)]
train[1,1] = NA
train[2,3] = NA

summary(train)
print(train$Age)

random.imp <- function (a){
	# simple random imputation, works on vectors
	missing <- is.na(a)
	n.missing <- sum(missing)
	a.obs <- a[!missing]
	imputed <- a
	imputed[missing] <- sample(a.obs, n.missing, replace=TRUE)
	return (imputed)
}

train$Age <- random.imp(train$Age)
train$PassengerId <- random.imp(train$PassengerId)

topcode <- function (a, top) {
	# cutoff values in vector if above top and set to top
	return (ifelse (a>top, top, a))
}

train$Age <- topcode(train$Age, 50)


###################################
###Random Forest
modRF <- new_resultFrame()

df.split <- h2o.splitFrame(df.hex, ratios = c(0.8), seed = 1234)
train <- df.split[[1]]
test <- df.split[[2]]
df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234) #validation set to size of 5-fold

sel_feat <- rownames(feat_rank)[1:40]

#using prespecified validation for quicker results

df_rf1 <- h2o.randomForest(
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
model_id = "rf_first",
# nfolds = 5,
# fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5,
score_each_iteration = T,
seed = 1234
)

modRF <- add_results(df_rf1, modRF)

# modH <- add_cv_results(df_xgb, modH)

df_rf2 <- h2o.randomForest(
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
model_id = "rf_first",
# nfolds = 5,
# fold_assignment = "Stratified",
balance_classes = TRUE,
ntrees = 500,
binomial_double_trees = TRUE,
stopping_rounds = 5,
stopping_tolerance = 1e-4, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 10,
score_each_iteration = T,
seed = 1234
)

modRF <- add_results(df_rf2, modRF)

####Hypertune

hyper_params = list(max_depth = c(4,6,8,12,14,16,18,20))
t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = list(strategy = "Cartesian"),
algorithm = "randomForest",
grid_id = "depth_grid_rf",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
ntrees = 10000, #just some big number
binomial_double_trees = TRUE,
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "auc",
score_tree_interval = 5
)
print(Sys.time() - t)

sortedGrid <- h2o.getGrid("depth_grid_rf", sort_by = "AUCPR", decreasing = TRUE)
sortedGrid <- h2o.getGrid("depth_grid_rf", sort_by = "auc", decreasing = TRUE)

# 16:20 for max depth

hyper_params = list(max_depth = c(16,18,20,22,24,26,28,30))
t <- Sys.time()
grid2 <- h2o.grid(
hyper_params = hyper_params,
search_criteria = list(strategy = "Cartesian"),
algorithm = "randomForest",
grid_id = "depth_grid_rf_2",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
ntrees = 10000, #just some big number
binomial_double_trees = TRUE,
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "auc",
score_tree_interval = 5
)
print(Sys.time() - t)

sortedGrid <- h2o.getGrid("depth_grid_rf_2", sort_by = "AUCPR", decreasing = TRUE)
sortedGrid <- h2o.getGrid("depth_grid_rf_2", sort_by = "auc", decreasing = TRUE)

#higher than 20 gets overfitted
hyper_params <- list(
	max_depth = seq(16,20,1),
	# sample_rate = seq(0.2, 1, 0.01),
	sample_rate_per_class = lapply(seq(0.4, 1, 0.01), function(x){x * c(0.12, 1)}),
	mtries = c(-1,-2, seq(10,37,3)),
	min_rows = 2 ^ seq(0, log2(nrow(df.split_valid[[1]]))-1,1),
	min_split_improvement = c(0, 1e-8, 1e-6, 1e-4),
	histogram_type = c("UniformAdaptive", "QuantilesGlobal", "RoundRobin")
)

search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 8,
max_models = 500,
seed = 1234,
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-3
)
t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = search_criteria,
algorithm = "randomForest",
grid_id = "final_grid_rf",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat,
y = vary,
ntrees = 10000, #just some big number
binomial_double_trees = TRUE,
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5
)
print(Sys.time() - t)

# sortedGrid <- h2o.getGrid("final_grid_rf", sort_by = "auc", decreasing = TRUE)
sortedGrid <- h2o.getGrid("final_grid_rf", sort_by = "AUCPR", decreasing = TRUE)

#Looking closer at the top 5 models
for (i in sortedGrid@model_ids[1:5]){
	modRF <- add_results(h2o.getModel(i), modRF)
}

                # Model Hit_Ratio Mean_PerC_Error LogLoss       AUC  AUCPR  Recall Precision
# 3                 rf_first     0.800           0.292   0.304 0.804 0.341  0.586     0.320
# 2   final_grid_rf_model_29     0.811           0.296   0.551 0.808 0.359  0.564     0.332
# 3.1  final_grid_rf_model_8     0.801           0.290   0.551 0.808 0.358  0.591     0.322
# 4   final_grid_rf_model_96     0.815           0.300   0.547 0.807 0.358  0.550     0.336
# 5   final_grid_rf_model_56     0.803           0.289   0.550 0.809 0.357  0.591     0.325
# 6   final_grid_rf_model_72     0.808           0.294   0.553 0.808 0.357  0.572     0.329
    # Specificity max_F1 trshold training_AUC training_AUCPR training_Recall
# 3         0.936  0.414   0.162        0.834          0.819           0.866
# 2         0.934  0.418   0.666        0.821          0.808           0.854
# 3.1       0.937  0.417   0.649        0.821          0.810           0.850
# 4         0.932  0.417   0.673        0.826          0.809           0.867
# 5         0.937  0.419   0.648        0.820          0.807           0.879
# 6         0.935  0.418   0.664        0.821          0.806           0.862
    # training_Precision training_Spec
# 3                0.698         0.823
# 2                0.690         0.809
# 3.1              0.686         0.809
# 4                0.689         0.820
# 5                0.674         0.826
# 6                0.686         0.815

###reTrain the top 5 models with CV on all train subset of data
RFtop5_cv <- new_resultFrame()

for (i in 1:5){
	rfModel <- h2o.getModel(sortedGrid@model_ids[[i]])
	cvRFModel <- do.call(h2o.randomForest,
	#update parameters of CV models
	{
		p <- rfModel@parameters
		p$model_id = NULL
		p$training_frame = train
		p$validation_frame = NULL
		p$nfolds = 5
		p$fold_assignment = "Stratified"
		p
	})
	print(rfModel@model_id)
	RFtop5_cv <- add_cv_results(cvRFModel, RFtop5_cv)
	RFtop5_cv$Model[nrow(RFtop5_cv)] <- paste("RF_top5_CV", i, sep="_")
}
RFtop5_cv

                            # Model Hit_Ratio Mean_PerC_Error LogLoss   AUC AUCPR Recall
# 1 DRF_model_R_1623451639824_61450     0.812           0.297   0.551 0.807 0.354  0.561
# 2                    RF_top5_CV_2     0.804           0.292   0.551 0.807 0.354  0.582
# 3                    RF_top5_CV_3     0.808           0.295   0.546 0.806 0.354  0.569
# 4                    RF_top5_CV_4     0.811           0.296   0.550 0.808 0.353  0.564
# 5                    RF_top5_CV_5     0.808           0.294   0.552 0.807 0.353  0.572
  # Precision Specificity max_F1 trshold training_AUC training_AUCPR training_Recall
# 1     0.331       0.934  0.416   0.667        0.821          0.808           0.869
# 2     0.324       0.936  0.416   0.654        0.821          0.808           0.869
# 3     0.327       0.935  0.415   0.659        0.825          0.808           0.868
# 4     0.331       0.934  0.417   0.661        0.820          0.808           0.861
# 5     0.327       0.935  0.416   0.662        0.821          0.805           0.875
  # training_Precision training_Spec
# 1              0.681         0.819
# 2              0.672         0.823
# 3              0.687         0.821
# 4              0.681         0.815
# 5              0.678         0.824

top_id_list <- c(61450,61732,61869,62138,62398) %>% sapply(function(x){paste0("DRF_model_R_1623451639824_",x)})

myPath = "./hypeTune_results/top5_RF_models_cv/"
for (i in top_id_list){
	h2o.saveModel(h2o.getModel(i), path = myPath)
}
#saving Sorted Grid for model hyperTuning
sortedGrid@summary_table %>% as.data.frame %>% write.csv("./hypeTune_results/top5_RF_models_cv/sortedGrid_rf.csv", row.names=F)

#############################
#############################
##########################################################
############################# Hyper parameter tuning for ed only model
#############################
#############################
#############################
#############################
#############################
#############################
#############################
#############################
#############################
#############################
modRF <- new_resultFrame()

# 16:20 for max depth

hyper_params = list(max_depth = c(16,18,20,22,24,26,28,30))
t <- Sys.time()
depthgrid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = list(strategy = "RandomDiscrete"),
algorithm = "randomForest",
grid_id = "depth_rf_ed",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
x = sel_feat_ed_big,
y = "alc_status",
ntrees = 10000, #just some big number
binomial_double_trees = TRUE,
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5
)
print(Sys.time() - t)

sortedGrid <- h2o.getGrid("depth_rf_ed", sort_by = "AUCPR", decreasing = TRUE)
sortedGrid <- h2o.getGrid("depth_rf_ed", sort_by = "auc", decreasing = TRUE)

modRF <- add_results(h2o.getModel("depth_rf_ed_model_2"), modRF)
#16:20 seems the way to go

hyper_params <- list(
	max_depth = seq(16,20,1),
	# sample_rate = seq(0.2, 1, 0.01),
	# sample_rate_per_class = lapply(seq(0.4, 1, 0.01), function(x){x * c(0.12, 1)}),
	mtries = c(-1,-2, seq(10,length(sel_feat_ed_big),3)),
	min_rows = 2 ^ seq(0, log2(nrow(df.split_valid[[1]]))-1,1),
	min_split_improvement = c(0, 1e-8, 1e-6, 1e-4),
	histogram_type = c("UniformAdaptive", "QuantilesGlobal", "RoundRobin")
)

search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 4,
max_models = 500,
seed = 1234,
stopping_rounds = 5,
stopping_metric = "AUCPR", #Try with AUC also
stopping_tolerance = 1e-3
)
t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params,
search_criteria = search_criteria,
algorithm = "randomForest",
grid_id = "final_grid_rf_ED",
balance_classes = TRUE,
training_frame = df.split_valid[[1]],
validation_frame = df.split_valid[[2]],
binomial_double_trees = TRUE, #build twice internal trees, for each class
x = sel_feat_ed_big,
y = "alc_status",
ntrees = 10000, #just some big number
binomial_double_trees = TRUE,
seed = 1234,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.01% over 5 consecutive turns
stopping_metric = "AUCPR",
score_tree_interval = 5
)
print(Sys.time() - t)

# sortedGrid <- h2o.getGrid("final_grid_rf_ED", sort_by = "auc", decreasing = TRUE)
sortedGrid <- h2o.getGrid("final_grid_rf_ED", sort_by = "AUCPR", decreasing = TRUE)

top5 <- new_resultFrame()
for (i in sortedGrid@model_ids[1:5]){
	top5 <- add_results(h2o.getModel(i), top5)
}
top5
###Picking the first one, training it on all samples using cross validation
bestModel <- h2o.getModel(sortedGrid@model_ids[[1]])

bestModel_cv <- do.call(h2o.randomForest,
{
	p <- bestModel@parameters
	p$model_id = "rf_ed_best_cv"
	p$training_frame = train
	p$nfolds = 5
	p$fold_assignment = "Stratified"
	p$keep_cross_validation_prediction = TRUE#this was not runn in saved model
	p$keep_cross_validation_fold_assignment = TRUE
	p$stopping_rounds = 5
	p$stopping_tolerance = 1e-3
	p$score_tree_interval = 10
	p
})

perf <- h2o.performance(bestModel_cv, test)

top5 <- add_cv_results(bestModel_cv, top5)# careful here as the validation frame is null
#it was corrected using perf

top5 %>% write.csv("./hypeTune_results/top5_RF_ed_models_cv/top5_andBestCV.csv", row.names=F)
sortedGrid@summary_table %>%
 as.data.frame %>%
 write.csv("./hypeTune_results/top5_RF_ed_models_cv/sortedGrid_rf_ed.csv", row.names=F)
#saving the trained model also
bestModel_cv %>% h2o.saveModel("./hypeTune_results/top5_RF_ed_models_cv")

#try a little experiment---> will it actually help the positive predictions?
sample_rate_per_class = [0.1128, 0.94]

sampleRate_rf <- do.call(h2o.randomForest,
{
	p <- bestModel@parameters
	p$model_id = "sample_rate_best"
	training_frame = df.split_valid[[1]]
	validation_frame = df.split_valid[[2]]
	p$sample_rate_per_class = c(0.1128, 0.94)
	p$nfolds = NULL
	p$fold_assignment = NULL
	p
})

srcomp <- top5[1,]
srcomp <- add_results(sampleRate_rf, srcomp)
srcomp

################end of experiment---
####
rf_models <- c()
path <- "./hypeTune_results/top5_RF_models_cv"
model_names <- grep("^DRF_model", list.files(path), value=T)
for(model in model_names){
	rf_models <- c(rf_models, h2o.loadModel(paste(path, model, sep = "/")))
}
#Now we have 5 models that we can use their "hyperTuned" parameters
rf_models[[1]]@parameters

rf_cv_model <- do.call(h2o.randomForest,
{
	p <- rf_models[[1]]@parameters
	p$training_frame = train
	p$validation_frame = test
	p$nfolds = NULL
	p$fold_assignment = NULL
	p$sample_rate_per_class = NULL
	p$keep_cross_validation_prediction = TRUE
	p$keep_cross_validation_fold_assignment = TRUE
	p
})

newRF <- c(rf_cv_model)
modRFcihi <- new_resultFrame()
modRFcihi <- add_results(rf_cv_model, modRFcihi)
for (i in c(2:5)){

rf_model <- rf_models[[i]]
newRF<- c( newRF, do.call(h2o.randomForest,
	#update parameters models, original models were cross validated, no need for that now, also change predictors in here
	{
		p <- rf_model@parameters
		p$model_id = paste0("RF_EDCihi_", i)
		p$training_frame = train
		p$validation_frame = test
		p$nfolds = NULL
		p$fold_assignment = NULL
		p$sample_rate_per_class = NULL
		p$keep_cross_validation_prediction = TRUE
		p$keep_cross_validation_fold_assignment = TRUE
		p$stopping_rounds = 5
		p$stopping_tolerance = 1e-3
		p$score_tree_interval = 10
		p
	}))
modRFcihi <- add_results(newRF[[i]], modRFcihi)
}
modRFcihi
modRFcihi %>% write.csv("./hypeTune_results/top5_RF_models_cv/updated_version/top5_tuned_test_results.csv")
###The 4th one seems like the one! It is saved
newRF[[4]]@parameters

newRF[[4]] %>% h2o.saveModel("./hypeTune_results/top5_RF_models_cv/updated_version")


library(xgboost)
library(magrittr)
library(dplyr)
library(Matrix)
library(ROCR)
library(MLmetrics)
library(caret)
library(hrbrthemes)
library(ggplot2)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# keep away training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with too many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# class distribution
fig <- ggplot(data = finalData, aes(x = DE)) +
  geom_histogram(stat = "count", fill = "turquoise", color = "purple", binwidth = 5) +
  ggtitle("Class Distribution") +
  xlab(label = "Differential Expression") +
  ylab("Number of Observations") +
  theme_ipsum() +
  theme(plot.title = element_text(hjust = 0.5))
fig
ggsave(filename = "./test/xgbClassDistribution.png", width = 15, height = 15, units = "cm")
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# One-Hot Encoding
label <- ifelse(test = finalData[,'DE'] == TRUE, yes = 1, no = 0)
n = nrow(finalData)
train.index = sample(n,floor(0.70*n))
train.data = as.matrix(sapply(finalData[train.index,-ncol(finalData)], as.numeric))
train.label = label[train.index]
test.data = as.matrix(sapply(finalData[-train.index,-ncol(finalData)], as.numeric))
test.label = label[-train.index]
xgb.train = xgb.DMatrix(data=train.data,label=train.label)
xgb.test = xgb.DMatrix(data=test.data,label=test.label)
test.label <- as.factor(ifelse(test = test.label == 1, yes = TRUE, no = FALSE))
#XGBoost Model Parameters
constant_params <- list(booster = 'gbtree',
                        silent = 0,
                        objective = 'binary:logistic',
                        eval_metric = 'error',
                        gamma = 0,
                        early.stop.round = 50
                        )
tunable_params_grid <- expand.grid(eta = (1:6)*0.05,
                                   nrounds = (1:6)*150,
                                   max_depth = c(4:9),
                                   subsample = c(0.6:1),
                                   colsample_bytree = c(0.5,0.8,1)
                                   )
colnames(tunable_params_grid) <- c("eta", "nrounds", "max_depth", "subsample", "colsample_bytree")
watchlist <- list(train = xgb.train, test = xgb.test)
numModels <- 10; #could increase
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(tunable_params_grid) + 3))
colnames(currParams) <- c(colnames(tunable_params_grid), "Accuracy", "AUC", "F1score")

for (i in 1:numModels){
  print(paste0("Building model ", i, "..."))
  currParams[i, ] <- tunable_params_grid[sample(nrow(tunable_params_grid), size = 1), ] #sample random combination and train the trees
  #Train Model
  xgbModel <- xgb.train(params = constant_params,
                        eta = currParams[i, 'eta'],
                        nrounds = currParams[i, 'nrounds'],
                        max_depth = currParams[i, 'max_depth'],
                        subsample = currParams[i, 'subsample'],
                        colsample_bytree = currParams[i,'colsample_bytree'],
                        data = xgb.train)
  #Prediction
  xgb.pred <- predict(xgbModel, test.data)
  xgb.pred <- as.data.frame(xgb.pred)
  pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
  #Evaluate model
  confusionMatrix(data = as.factor(pred.class), reference = test.label, positive = 'TRUE')
  currParams[i, 'Accuracy'] <- Accuracy(y_pred = pred.class, y_true = test.label)
  pred_obj = prediction(xgb.pred, test.label, label.ordering = c("FALSE", "TRUE"))
  currParams[i, 'AUC'] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  currParams[i, 'F1score'] <- F1_Score(y_true = test.label, y_pred = pred.class, positive = 'TRUE')
}
#taking best model parameters
bestModel <- currParams[which(currParams$Accuracy == max(currParams$Accuracy)), ]
bestModel <- bestModel[which(bestModel$AUC == max(bestModel$AUC)), ]
bestParams <- bestModel[1,c(1:5)]
# Best model
xgbModel <- xgb.train(params = constant_params,
                      eta = bestParams$eta,
                      nrounds = bestParams$nrounds,
                      max_depth = bestParams$max_depth,
                      subsample = bestParams$subsample,
                      colsample_bytree = bestParams$colsample_bytree,
                      data = xgb.train)
#Prediction
xgb.pred <- predict(xgbModel, test.data)
xgb.pred <- as.data.frame(xgb.pred)
pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
#Evaluate model
confusionMatrix(data = as.factor(pred.class), reference = test.label, positive = 'TRUE')
Accuracy <- Accuracy(y_pred = pred.class, y_true = test.label)
pred_obj = prediction(xgb.pred, test.label, label.ordering = c("FALSE", "TRUE"))
ROCcurve <- performance(pred_obj, "tpr", "fpr")
plot(ROCcurve, col = "blue")
abline(0, 1, col = "grey")
AUC <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
# Stability Analysis permuting FinalData
# Create 10 equally size folds
acc <- list()
f1 <- list()
# Perform 10 fold cross validation
for(i in 1:10){
  # Randomly shuffle the data
  # finalData <- finalData[sample(nrow(finalData)),]
  finalData <- finalData[sample(nrow(finalData)),]
  # One-Hot Encoding
  label <- ifelse(test = finalData[,'DE'] == TRUE, yes = 1, no = 0)
  n = nrow(finalData)
  train.index = sample(n,floor(0.70*n))
  train.data = as.matrix(sapply(finalData[train.index, -ncol(finalData)], as.numeric))
  train.label = label[train.index]
  test.data = as.matrix(sapply(finalData[-train.index, -ncol(finalData)], as.numeric))
  test.label = label[-train.index]
  xgb.train = xgb.DMatrix(data=train.data,label=train.label)
  xgb.test = xgb.DMatrix(data=test.data,label=test.label)
  test.label <- as.factor(ifelse(test = test.label == 1, yes = TRUE, no = FALSE))
  # Train Model
  xgbModel <- xgb.train(params = constant_params,
                        eta = bestParams$eta,
                        nrounds = bestParams$nrounds,
                        max_depth = bestParams$max_depth,
                        subsample = bestParams$subsample,
                        colsample_bytree = bestParams$colsample_bytree,
                        data = xgb.train)
  # Prediction
  xgb.pred <- predict(xgbModel, test.data)
  xgb.pred <- as.data.frame(xgb.pred)
  pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
  # Accuracy
  acc[i] <- Accuracy(y_pred = as.factor(pred.class), y_true = test.label)
  f1[i] <- F1_Score(y_true = test.label, y_pred = pred.class, positive = 'TRUE')
}
a <- data.frame(acc = unlist(acc), n = c(1:10))
# Plot
p1 <- ggplot(aes(x = n, y = acc), data = a)+
  geom_line(color = "purple4", size = 1) +
  geom_point(shape=20, color="grey69", fill="#69b3a2", size=4) +
  xlab("Permutation i") +
  xlim(1,10) +
  ylab("Accuracy") +
  ylim(0.9,1.1) +
  ggtitle("XGBoost - Stability Analysis") +
  theme_bw(base_size=18)
p1
ggsave(filename = "./test/xgBoostStability.png", width = 15, height = 15, units = "cm")


# This function does the core add-in work.
increment <- function(delta) {
  # Get information about the current document
  context <- rstudioapi::getActiveDocumentContext()

  # Loop over all of the selected text regions in the document
  for (sel in context$selection) {

    # Attempt to coerce the selected text to a number; skip if it's not a
    # number.
    suppressWarnings(int <- as.integer(sel$text))
    if (is.na(int)) next

    # Replace the selection with the the updated number.
    rstudioapi::modifyRange(sel$range,
                            as.character(int+delta),
                            context$id)
    break
  }
}

# This is an exposed add-in function; it increments the selected number by 1.
incrementr <- function() {
  increment(1)
}

# This is an exposed add-in function; it decrements the selected number by 1.
decrementr <- function() {
  increment(-1)
}


iris[which(iris$Sepal_Length>2.5),]#iris data frame with Sepal Length>2.5
Sepal_Length_Mean<-sum(iris$Sepal_Length)/nrow(iris)#mean using data frame operations
Sepal_Width_Mean<-sum(iris$Sepal_Width)/nrow(iris)
Petal_Length_Mean<-sum(iris$Petal_Length)/nrow(iris)
Petal_Width_Mean<-sum(iris$Petal_Width)/nrow(iris)
merge(emp,dept,by="Dept_Id")#inner join
merge(emp,dept,by="Dept_Id",all = TRUE)#outer join
merge(emp,dept,by="Dept_Id",all.x = TRUE)#left join
merge(emp,dept,by="Dept_Id",all.y = TRUE)#right join

R Community/R DaraManipulation Assignments/Assignment5.r


yday_366 <- function(date) {
  temp_doy <- lubridate::yday(date)
  temp_leap <- lubridate::leap_year(date)
  temp_doy[(!is.na(temp_doy)) & temp_doy > 59 & (!temp_leap)] <- 1 + temp_doy[(!is.na(temp_doy)) & temp_doy > 59 & (!temp_leap)]
  return(temp_doy)
}