## prog ini 1
# read data from ASCII file and do some graphical initialisations
# you have to do this after every new SMS run
#################################################################

stom<-Read.stomach.data()
stom$Area<-stom$SMS.area
stom$SMS.area<-NULL
a<-aggregate(list(Pred.avail=stom$Prey.avail.part),
              list(Year=stom$Year,Quarter=stom$Quarter,Predator=stom$Predator,Predator.length.class=stom$Predator.length.class),sum)
stom<-merge(stom,a)
stom$stomcon.hat.part<-stom$Prey.avail.part/stom$Pred.avail
stom$Residual.part<-stom$stom.input-stom$stomcon.hat.part
stom<-transform(stom,year.range=ifelse(Year<=1981,'1977-81','1982-93'),year=paste("Y",Year,sep=''))

write.csv(stom, file = file.path(data.path,'ASCII_stom_data.csv'),row.names = FALSE)
stomAll<-stom  # all stomach input irrespectiv of actually use
stom<-subset(stom,stom.used.all==1)  # used stomachs specified for input

tr<-trellis.par.get( "background")
# old value  tr$col="#909090"
tr$col="white"
trellis.par.set("background", tr)

dev<-"print"
dev<-"screen"

nox<-4
noy<-3

no.areas<-SMS.control@no.areas
if (no.areas==4) no.areas<-3
area.names<-Read.area.names()
################################################################

stom<-subset(stom, Stom.var>0 & stom.used.like==1)

# Peter Lewy's Dirichlet residuals
stom$pl.theta<-stom$N.samples/stom$Diri.sum.p
stom$pl.E<-stom$N.samples*stom$Diri.p/stom$Diri.sum.p
stom$pl.Var<-stom$Diri.p*stom$pl.theta^2
stom$pl.sd<-sqrt(stom$pl.Var)
stom$pl.res<-((stom$N.samples*stom$stomcon)-stom$pl.E)/stom$pl.sd
stom$pl.y<-pgamma(stom$N.samples*stom$stomcon,shape=stom$Diri.p,scale=stom$pl.theta)

dim(stom)

stom<-subset(stom,stom$pl.y<1)
dim(stom)

cleanup()
newplot(dev="screen",nox=2,noy=1,w8=5,w11=8);      # Peter Lewy residual
hist(stom$pl.res,main='Stomach residuals',xlab="residuals")
qqnorm(stom$pl.res)
qqline(stom$pl.res)

cleanup()
newplot(dev="screen",nox=2,noy=2,w8=8,w11=8);
hist(stom$pl.res,main='Stomach residuals. Dirichlet trans',xlab="residuals")  # Peter Lewy residual
qqnorm(stom$pl.res)
qqline(stom$pl.res)

hist(stom$stan.res,main='Stomach residuals standardised',xlab="residuals")
qqnorm(stom$stan.res)
qqline(stom$stan.res)

a<-subset(stom,Stom.var>0 & stom.used.like==1 ,select=c(Area,Predator,Quarter,Year,Predator.length.class ,Predator.length.mean,Prey,Prey.length.mean,N.samples,stomcon,stomcon.hat,Residual,stan.residual))
a<-a[order(abs(a$stan.residual),decreasing =T),]
head(a,20)

a<-subset(stom,Stom.var>0 & stom.used.like==1 ,select=c(Area,Predator,Quarter,Year,Predator.length.class ,Predator.length.mean,Prey,Prey.length.mean,N.samples,stomcon,stomcon.hat,pl.res,stan.residual))
a<-a[order(abs(a$pl.res),decreasing =T),]
head(a,20)
#tail(a,20)

###
a<-a[order(abs(a$Residual),decreasing =T),]
head(a,20)

a<-unique(subset(stom,Stom.var>0 & stom.used.like==1 ,select=c(Predator,Quarter,Year,Predator.length.class ,N.samples,Diri.like)))
#a<-a[order(abs(a$Diri.like),decreasing =T),]
a<-a[order(a$Diri.like,decreasing =T),]
head(a,20)

tail(a,20)
###############################################################
#Number of stomachs;
ns<-unique(subset(stom,select=c(Predator,Predator.no,Predator.length,Predator.length.class,Year,Quarter, N.samples)))
ns<-ns[order(ns$N.sample),]
head(ns)

ftable(tapply(ns$N.sample,list(ns$Predator,ns$Year,ns$Quarter,ns$Predator.length),sum,na.rm=T))
tapply(ns$N.sample,list(ns$Predator,ns$Predator.length),sum,na.rm=T)
tapply(ns$N.sample,list(ns$Predator),sum,na.rm=T)
X11()
hist(ns$N.sample, freq = T,nclass=50,xlab='number of stomachs per sample',main='')

###############################################################
# Buble residual plot
#
stomBuble<-function(my.pred='Cod',my.area=1,my.dev=my.dev.used,filename='a',time.order="quarter-year",pred.order="pred-size",pred.prey.order="prey-pred",scale=2,Res.type=1,use.likelihood=F,make.table=F,...) {
    # res type
    # 1= observed-predicted
    # 2= standardised
    # 3= Peter Lewys suggestion

    area.names<-Read.area.names()
    stom3<-(subset(stom,Predator %in% my.pred & Size.model %in% c(0,1,4,11) & Area==my.area,
       select=c(Predator,Quarter,Year,Predator.length.class ,Predator.length,Prey,Prey.no,N.samples,Diri.like,stan.residual,Residual,pl.res)))

    if (use.likelihood) {
      stom3<-unique(subset(stom3,select=c(-stan.residual,-Residual,-Prey,-Prey.no)))
      stom3$Residual<-stom3$Diri.like
    } else if (Res.type==2) stom3$Residual<-stom3$stan.residual else if (Res.type==3) stom3$Residual<-stom3$pl.res

    if (time.order== "quarter-year") stom3$time<-paste(stom3$Quarter,stom3$Year,sep=' ')
    if (time.order== "year-quarter") stom3$time<-paste(stom3$Year,stom3$Quarter,sep=' ')
    if (use.likelihood) stom3$plPrey<-'' else stom3$plPrey<-paste(stom3$Prey.no,") ",stom3$Prey,sep='')
    if (pred.order=="pred-size") stom3$plPred<-paste(stom3$Predator,stom3$Predator.length/10,sep='-')
    if (pred.order=="size-pred") stom3$plPred<-paste(stom3$Predator.length/10,stom3$Predator,sep='-')

    s<-droplevels(subset(stom3,select=c(time,plPrey,plPred,Predator,Predator.length,Residual)))
    if (pred.prey.order=="pred-prey") a<-tapply(s$Residual,list(s$plPred,s$plPrey,s$time),sum,na.rm=T)
    if (pred.prey.order=="prey-pred") a<-tapply(s$Residual,list(s$plPrey,s$plPred,s$time),sum,na.rm=T)

    if (make.table) ftable(round(a,3))
    bb<-data.frame(ftable(a))
    names(bb)<-c('Prey','Pred','Period','Value')
    ylabs<-sort(unique(paste(bb$Prey,bb$Pred)))
    xlabs<-sort(unique(bb$Period))
    b<-as.matrix(ftable(a))
    b<-arr2df(b)
    names(b)<-c('y','x','v')
    b<-subset(b,!is.na(v))

    bp3<-function(x,y,v, scale=3,xlabs,ylabs,...){
      plot(x,y,cex=sqrt(abs(v))*scale, col='seagreen3', pch=ifelse(v<0,16,1), axes=F,ylab='',xlab='',main=area.names[my.area])
      axis(2,at=1:length(ylabs),labels=ylabs,las=1,cex.axis=0.7)
      axis(1,at=1:length(xlabs),labels=xlabs,las=2,cex.axis=0.7)
      box()
      points(x,y,cex=sqrt(abs(v))*scale, col='red', pch=1)
    }

    newplot(dev=my.dev,nox=1,noy=1,filename=filename,...);
    par(mar=c(4,6,1,2)) #c(bottom, left, top, right)
    bp3(x=as.numeric(b$x),y=b$y,v=b$v, scale=scale,xlabs=xlabs,ylabs=ylabs)
}

cleanup()

my.dev.used='png'
#stomBuble(my.area=1,my.pred='Cod',time.order="quarter-year",pred.order="pred-size",scale=1,Res.type=2)
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="quarter-year",pred.order="pred-size",scale=2,Res.type=1,filename='stom_res1_quarter-year')
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="quarter-year",pred.order="pred-size",scale=1.3,Res.type=2,filename='stom_res2_quarter-year')
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="quarter-year",pred.order="pred-size",scale=1.3,Res.type=3,filename='stom_res3_quarter-year')

for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="year-quarter",pred.order="pred-size",scale=2,Res.type=1,filename='stom_res1_year-quarter')
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="year-quarter",pred.order="pred-size",scale=1.3,Res.type=2,filename='stom_res2_year-quarter')
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',time.order="year-quarter",pred.order="pred-size",scale=1.3,Res.type=3,filename='stom_res3_year-quarter')

for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',my.dev='png',filename=paste('stom_likelihood1',are,sep='_'),time.order="year-quarter",pred.order="pred-size",scale=1,use.likelihood=T)
for (are in (1:no.areas)) stomBuble(my.area=are,my.pred='Cod',my.dev='png',filename=paste('stom_likelihood2',are,sep='_'),time.order="quarter-year",pred.order="pred-size",scale=1,use.likelihood=T)

cleanup()

my.pred<-"Cod"; my.area<-1
stom3<-(subset(stom,Predator %in% my.pred & Size.model %in% c(0,4,11) & Area==my.area,
     select=c(Predator,Quarter,Year,Predator.length.class ,Predator.length,Prey,Prey.no,N.samples,Diri.like,stan.residual,Residual,pl.res)))
other<-subset(stom3,Prey=='Other',select=c( Quarter, Year, Predator.length.class , Prey, N.samples ))
head(other)
cod<-subset(stom3,Prey=='Cod',select=c( Quarter, Year, Predator.length.class ))
head(cod)
cod$present<-1
a<-merge(x=cod,y=other,all.y=T)
head(a)
a[is.na(a$present),'present']<-0
a$period<-'1977-1981'
a[a$Year>1981,'period']<-'1982-1992'
ftable(round(tapply(a$present,list(a$Year,a$Predator.length.class),mean),2))
ftable(round(tapply(a$present,list(a$period,a$Predator.length.class),mean),2))

##############################################################
# Box-plot of residuals by predator, prey and quarter
# prog box 1
Res.type<-3

nox<-3; noy<-4;
#cleanup()
#newplot(dev="screen",filename='stom_box',nox,noy,Portrait=F);
newplot(dev="png",filename='stom_box',nox,noy,Portrait=F);
 par(mar=c(3,2,3,2)) #c(bottom, left, top, right)
i<-0

if (Res.type==2) stom3$Residual<-stom3$stan.residual else if (Res.type==3) stom3$Residual<-stom3$pl.res

res.ylim<-c(-0.05,0.05)
res.ylim<-c(-0.05,0.05)
 res.ylim<-c(-0.1,0.1)

my.pred<-c("Cod")
stom3<-subset(stom,Predator %in% my.pred,drop=TRUE)
stom3$Length<-stom3$Predator.length/10
stom3$yq<-paste(stom3$Year,stom3$Quarter)
my.col<-"red"
by(stom3,list(stom3$Predator,stom3$Prey,stom3$Area),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 ;  par(mar=c(3,2,3,2)) }#c(bottom, left, top, right)
   if (x[1,"Prey"]=="Other" ) fac<-1 else fac<-1

   boxplot(Residual~yq,data=x,ylim=6*fac*res.ylim)
   abline(h=0,col=my.col)
 #  title(main=paste(area.names[x[1,'Area']],x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   title(main=paste(x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   i<<-i+1

   boxplot(Residual~Year,data=x,ylim=6*fac*res.ylim)
   abline(h=0,col=my.col)
   title(main=paste(x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   i<<-i+1

   boxplot(Residual~Quarter,data=x,ylim=3*fac*res.ylim)
   abline(h=0,col=my.col)
   title(main=paste(x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   i<<-i+1

   boxplot(Residual~Length,data=x,ylim=3*fac*res.ylim)
   abline(h=0,col=my.col)
   title(main=paste(x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   i<<-i+1

})

cleanup()

##############################################################
# Box-plot of residuals by predator, prey and quarter
# prog box 1
Res.type<-3

nox<-no.areas; noy<-1;
cleanup()
newplot(dev="screen",filename='stom_box',nox,noy,Portrait=F);
#newplot(dev="png",filename='stom_box',nox,noy,Portrait=F);
 par(mar=c(3,2,3,2)) #c(bottom, left, top, right)
i<-0

if (Res.type==2) stom3$Residual<-stom3$stan.residual else if (Res.type==3) stom3$Residual<-stom3$pl.res

if (Res.type==2) res.ylim<-c(-3,3)
if (Res.type==3)res.ylim<-c(-0.04,0.04)

my.pred<-c("Cod")
stom3<-subset(stom,Predator %in% my.pred,drop=TRUE)
stom3$Length<-stom3$Predator.length/10
stom3$yq<-paste(stom3$Year,stom3$Quarter)
my.col<-"red"
by(stom3,list(stom3$Area,stom3$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   if (x[1,"Prey"]=="Other" ) fac<-5 else fac<-1

   boxplot(Residual~Prey,data=x,main=area.names[x[1,'Area']])
   abline(h=0,col=my.col)
   title(main='')
   i<<-i+1
})

 ##############################################################
#Dirichlet
##

cleanup()
nox<-2; noy<-2;
newplot(dev,nox,noy);
i<-0

a<-subset(stom,Quarter.no>0)
a<-unique(a)
xyplot(Diri.sum.p~N.samples,
      auto.key = list(space = "right", points = T, lines = TRUE),data=a)

xyplot(Diri.like~N.samples,
      auto.key = list(space = "right", points = T, lines = TRUE),data=a)

xyplot(Diri.like~N.samples|Predator,group=Predator.length.class,
      auto.key = list(space = "right", points = T, lines = TRUE),data=a)

xyplot(stomcon.hat*(1-stomcon.hat)/(Diri.sum.p+1)*N.haul ~stomcon.hat,group=Predator, ylab="VAR(STOM)",
      auto.key = list(space = "right", points = T, lines = TRUE),data=a)

##############################################################
#observed and predicted stomach contents by Predator and prey
# prog stom 1

cleanup()
nox<-2; noy<-2;
newplot(dev="screen",filename='Stom_obs_predicted',nox,noy,Portrait=F);
newplot(dev="png",filename='Stom_obs_predicted',nox,noy,Portrait=F);

i<-0
stom2<-subset(stom,stomcon>0)
by(stom2,list(stom2$Prey,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-(x$stomcon)
   bb<-(x$stomcon.hat)
   max.val<-max(aa,bb)
   min.val<-min(aa,bb)
   plot(bb,aa,xlab='Expected stomach content',ylab='observed',ylim=c(min.val,max.val),xlim=c(min.val,max.val))
   if (var(bb)>0) abline(lm(aa~bb), lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##########################################################
stom3<-droplevels(subset(stom,  (Size.model==1 | Size.model==11) &  Prey.no>0) )

# use the individual data points (not the liklihood data) when size mode is 11
stom3[stom3$Size.model==11,]$stomcon<-    stom3[stom3$Size.model==11,]$stom.input
stom3[stom3$Size.model==11,]$stomcon.hat<-stom3[stom3$Size.model==11,]$stomcon.hat.part

# start with a high fac for calc of mean and var
fac<-50
a<-aggregate(list(stom=stom3$stomcon*5000,stom.hat=stom3$stomcon.hat*5000)
             ,list(Predator=stom3$Predator,PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)

# by(a,list(a$Predator),function(x) weighted.mean(x$PredPrey, x$stom))

bb<-data.frame(size=rep(a$PredPrey,trunc(a$stom)),Predator=rep(a$Predator,trunc(a$stom)))
k1<-aggregate(list(mean=bb$size),list(Predator=bb$Predator),mean)
k2<-aggregate(list(var=bb$size),list(Predator=bb$Predator),var)
stat<-merge(k1,k2)

bb<-data.frame(size=rep(a$PredPrey,trunc(a$stom.hat)),Predator=rep(a$Predator,trunc(a$stom.hat)))
k1<-aggregate(list(mean.hat=bb$size),list(Predator=bb$Predator),mean)
k2<-aggregate(list(var.hat=bb$size),list(Predator=bb$Predator),var)
stat.hat<-merge(k1,k2)

stat<-merge(stat,stat.hat)
stat

# decrease fac for a  nice plot
fac<-2
a<-aggregate(list(stom=stom3$stomcon, stomNo=stom3$stomcon/stom3$Prey.weight,stom.hat=stom3$stomcon.hat),list(Predator=stom3$Predator,
                                      PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)
b<-aggregate(list(sumstom=a$stom, sumstomNo=a$stomNo, sumstom.hat=a$stom.hat),list(Predator=a$Predator),sum)
a<-merge(a,b)
a<-merge(a,stat)
a$stom<-a$stom/a$sumstom
a$stomNo<-a$stomNo/a$sumstomNo
a$stom.hat<-a$stom.hat/a$sumstom.hat

## observed
a$headt<-paste(a$Predator,", mean=",formatC(a$mean,digits=2,format='f')," variance=",formatC(a$var,digits=2,format='f'),sep='')

cleanup()
trellis.device(device = "windows",
               color = T, width=9, height=17,pointsize = 12,
               new = TRUE, retain = FALSE)
cleanup()
trellis.device(device = "windows",
               color = T, width=18, height=22,pointsize = 12,
               new = TRUE, retain = FALSE)

b1<-a
b1$type<-paste("a) ", a$headt,'\nObserved',sep='');

## predicted
a$headt<-paste(a$Predator," mean=",formatC(a$mean.hat,digits=2,format='f')," var=",formatC(a$var.hat,digits=2,format='f'),sep='')
b2<-a

b2$type<-paste("b) ", a$headt,'\nPredicted',sep='');

# both on the same plot
b2$stom<-b2$stom.hat
aa<-rbind(b1,b2)

trellis.device(device = "windows",
               color = T, width=7, height=7,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|type, data=aa,
     groups = Predator, stack = TRUE,      # this line is not needed, but it gives a nicer offset on the Y-axis

    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=1.5, lines=2),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(1, 1) ,col='grey')

#####################
# same as above, but with contributions from prey species

fac<-2
a<-aggregate(list(stom=stom3$stomcon, stomNo=stom3$stomcon/stom3$Prey.weight,stom.hat=stom3$stomcon.hat),list(Predator=stom3$Predator,
                                      Prey=stom3$Prey,
                                      PredPrey=trunc(log(stom3$Predator.size/stom3$Prey.size)*fac)/fac),sum)
b<-aggregate(list(sumstom=a$stom, sumstomNo=a$stomNo, sumstom.hat=a$stom.hat),list(Predator=a$Predator),sum)
a<-merge(a,b)
a<-merge(a,stat)
a$stom<-a$stom/a$sumstom
a$stomNo<-a$stomNo/a$sumstomNo
a$stom.hat<-a$stom.hat/a$sumstom.hat

## observed
a$headt<-paste(a$Predator,", mean=",formatC(a$mean,digits=2,format='f')," variance=",formatC(a$var,digits=2,format='f'),sep='')

#cleanup()
trellis.device(device = "windows",
               color = T, width=17, height=17,pointsize = 12,
               new = TRUE, retain = FALSE )

b<- tapply(stom3$stomcon,list(stom3$Prey),sum)
col<-1:3
lab<-dimnames(b)[[1]]

#cleanup()
trellis.device(device = "windows",
               color = T, width=7, height=9,pointsize = 2,
               new = TRUE, retain = FALSE)

b1<-a
b1$type<-paste("a) ",a$headt,'\nObserved',sep='');
b2<-a

## predicted
a$headt<-paste(a$Predator," mean=",formatC(a$mean.hat,digits=2,format='f')," var=",formatC(a$var.hat,digits=2,format='f'),sep='')
b2<-a
b2$type<-paste("b) ",a$headt,'\nPredicted',sep='');

# BALTIC both on the same plot b
b2$stom<-b2$stom.hat
aa<-rbind(b1,b2)

trellis.device(device = "windows",
               color = T, width=10, height=7,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|type, data=aa,
      groups = Prey, stack = TRUE,  col=1:3,    # this line is not needed, but it gives a nicer offset on the Y-axis
    xlab='log(predator weight/prey weight)',ylab='Proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=1, lines=2),
    key = list(text = list(label = lab,col=1), rectangles = TRUE, space = "right", col=1:3),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 1) )


# Import cancer data
dataset_filepath = 'Documents/github/Fun/AI/coursera/PublicHeatlh/w2_r_scripts/dataset.csv'
g <- read.csv(file = dataset_filepath, header=TRUE, sep=',')

# Display first/last rows
head(g)
tail(g)

# Display dimensions of dataset
dim(g)

# Display unique cnt
table(gender)  # for discrete variables
summary(bmi)  # for continuous variables

# Display specific rows/columns
g[4,]
g[,4]
g[1,2]
g[1:5,]
g[,'gender']
g$gender

# Cast to categorical
gender <- g['gender']
gender <- as.factor(g['gender'])

# Sum variables
fruit <- g[,'fruit']
veg <- g[,'veg']g
fruit_veg = fruit + veg
table(fruit_veg)
g$fruit_veg = g$fruit + g$veg

# Draw a histogram
hist(fruit_veg)

# Display aggregates
sum(g$fruit)
mean(g$fruit)
median(g$fruit)
quantile(g$fruit)

# Display data types
sapply(g, class)
unique(sapply(g, class))

# Display missing values
summary(is.na(g))
table(is.na(g))

table(g$smoking, exclude = NULL)  # NULL = “do not exclude anything”

# Dichotomize patients
g$five_a_day <- ifelse(g$fruit_veg >= 5, 1, 0)
summary(g$five_a_day)
table(g$five_a_day)

g$not_normal_bmi <- ifelse(g$bmi < 18.5 | g$bmi > 25, 1, 0)
table(g$not_normal_bmi)


a -> b (5)
b -> c (6)
c -> e (3)
a -> d (1)


step <- function() {
    success <- runif(1) > p
    ## Requires that the "robot" is a variable named "level"
    level <<- level - 1 + (2 * success)
    success
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 12, 2016
# ref: http://harding.edu/fmccown/r/
# clear; Rscript autosPlot2.r

# inputs: data/autos.dat
# outputs: figures/autosPlot2.pdf

# set the working directory
setwd("~/Copy/Programming/R/rprograms/plotting/2dplots/")

# Start PDF device driver to save output to figure.pdf
#pdf(file="figures/auotsPlot2.pdf", height=3.5, width=5)

# Read car and truck values from tab-delimited autos.dat
autos_data <- read.table("data/autos.dat", header=T, sep="\t")

# Define colors to be used for cars, trucks, suvs
plot_colors <- c(rgb(r=0.0,g=0.0,b=0.9), "red", "forestgreen")

# Trim off excess margin space (bottom, left, top, right)
par(mar=c(4.2, 3.8, 0.2, 0.2))

# Graph autos using a y axis that uses the full range of value
# in autos_data. Label axes with smaller font and use larger
# line widths.
plot(autos_data$cars, type="l", col=plot_colors[1],
   ylim=range(autos_data), axes=F, ann=T, xlab="Days",
   ylab="Total", cex.lab=0.8, lwd=2)

# Make x axis tick marks without labels
axis(1, lab=F)

# Plot x axis labels at default tick marks with labels at
# 45 degree angle
text(axTicks(1), par("usr")[3] - 2, srt=45, adj=1,
          labels=c("Mon", "Tue", "Wed", "Thu", "Fri"),
          xpd=T, cex=0.8)

# Plot y axis with smaller horizontal labels
axis(2, las=1, cex.axis=0.8)

# Create box around plot
box()

# Graph trucks with thicker red dashed line
lines(autos_data$trucks, type="l", lty=2, lwd=2,
  col=plot_colors[2])

# Graph suvs with thicker green dotted line
lines(autos_data$suvs, type="l", lty=3, lwd=2,
  col=plot_colors[3])

# Create a legend in the top-left corner that is slightly
# smaller and has no border
legend("topleft", names(autos_data), cex=0.8, col=plot_colors,
   lty=1:3, lwd=2, bty="n");

# Turn off device driver (to flush output to PDF)
#dev.off()

# Restore default margins
par(mar=c(5, 4, 4, 2) + 0.1)


library(RColorBrewer)
library(plyr)
library(dplyr)
library(reshape2)
library(dtplyr)
library(data.table)
library(ggplot2)
library(ggmap)
library(stringr)
library(zipcode)
library(scales)
library(animation)
library(magick)

# import zipcode location data
data(zipcode)

# subset to california, and then norcal
cali_zip = filter(zipcode, state == 'CA')
norcal_zip = filter(cali_zip, latitude >= 36 & latitude <= 39 & longitude >= -123 & longitude <= -119)

## import and clean single family home data for california
setwd('~/tgwhite_github/Public_Policy/Data')
ca_zip_zhvi_single_family = fread('Zip_Zhvi_SingleFamilyResidence.csv') %>%
  melt(
    id = c('RegionID', 'RegionName', 'City', 'State', 'Metro', 'CountyName', 'SizeRank')
  ) %>%
  mutate(
    date = as.Date(paste0(variable, '-01')),
    year = year(date),
    month = month(date),
    variable = NULL
  ) %>%
  rename(
    zip = RegionName
  ) %>%
  filter(
    State == 'CA'
  ) %>%
  arrange(zip, date) %>%
  data.table()

## compute year on year changes (from the same month in the prior year)

ca_year_on_year_changes = ca_zip_zhvi_single_family[, {
  last_year_val = lag(value, 1)
  pct_change = c(NA, diff(value, 1)) / last_year_val

  list(
    year = year,
    date = date,
    yoy_change = pct_change,
    last_year_val = last_year_val,
    this_year_val = value
  )
}, by = list(zip, month)] %>%
  arrange(zip, date) %>%
  as.data.frame()

# get quantiles for binning on maps
overall_quantiles = quantile(ca_year_on_year_changes$yoy_change, probs = seq(0, 1, by = 1/7), na.rm = T)
ca_year_on_year_changes$yoy_change_bin = with(ca_year_on_year_changes, cut(yoy_change * 100, breaks = overall_quantiles * 100, include.lowest = T))

### plot time series across all zips
time_series_plot = ggplot(ca_year_on_year_changes %>% filter(!is.na(yoy_change)), aes(date, yoy_change, group = zip)) +
  scale_y_continuous(labels = percent) +
  labs(
    x = '\nTaylor G. White\ngithub: tgwhite, twitter: t_g_white', y = 'Year on Year Change (%)\n',
    title = 'Tracking Prices of Single Family Residences in CA',
    subtitle = 'Monthly Zip-Level Zillow Home Value Index\nApril 1997-Feburary 2017'
  ) +
  theme(
    text = element_text(size = 12),
    title = element_text(size = 16),
    axis.text = element_text(size = 10),
    axis.title = element_text(size = 12)
  ) +
  geom_line(alpha = 0.25) +
  geom_hline(aes(yintercept = 0), linetype = 'dashed', colour = 'blue', size = 1) +
  stat_smooth(aes(group = NA), colour = 'orange', size = 1.5)

ggsave('ca_single_family_prices_plot.png', height = 6, width = 8, units = 'in', dpi = 400, plot = time_series_plot)

### create gifs of changes over time
# inner join with norcal zipcodes to get lat/lon and subset to desired vals
norcal_year_on_year_changes =
  inner_join(ca_year_on_year_changes, norcal_zip)

# get vector of dates to loop over
unique_dates = unique(ca_year_on_year_changes$date[!is.na(ca_year_on_year_changes$yoy_change)])

# get color scales
the_colors = RColorBrewer::brewer.pal(7, 'PiYG')
names(the_colors) = levels(ca_year_on_year_changes$yoy_change_bin)

# get map of Modesto via google maps
mod_map = get_map('modesto', zoom = 8, maptype = 'hybrid', color='bw')

# create a blank map for the start of the gifs
blank_map <- ggmap(mod_map) +
  geom_point(data = norcal_year_on_year_changes %>% filter(!is.na(yoy_change_bin)) %>% head(1), aes(longitude, latitude, colour = yoy_change_bin), size = 0) +
  scale_colour_manual(name='YOY Percent Change', values = the_colors, drop = F) +
  scale_alpha(guide = F, name = '') +
  labs(
    x = '\nTaylor G. White\ngithub: tgwhite, twitter: t_g_white', y = '',
    title = 'Tracking Prices of Single Family Residences in CA\nMonthly Zip-Level Zillow Home Value Index',
    subtitle = "Can't see this!" # use for spacing purposes
  ) +
  theme(
    plot.subtitle = element_text(colour = 'white', size = 12),
    axis.text = element_blank(),
    axis.ticks = element_blank()
  ) +
  guides(colour = guide_legend(override.aes = list(size = 2)))

# save month level plots into a list
date_plots = lapply(unique_dates, function(this_date){

  the_sub = filter(norcal_year_on_year_changes, date == this_date & !is.na(yoy_change_bin))
  date_pretty = format(this_date, '%b-%Y')

  the_plot <- ggmap(mod_map) +
    geom_point(data = the_sub, aes(longitude, latitude, colour = yoy_change_bin), size = 2) +
    scale_colour_manual(name='YOY Percent Change', values = the_colors, drop = F) +
    labs(
      x = '\nTaylor G. White\ngithub: tgwhite, twitter: t_g_white', y = '',
      title = 'Tracking Prices of Single Family Residences in CA\nMonthly Zip-Level Zillow Home Value Index',
      subtitle = date_pretty
    ) +
    theme(
      plot.subtitle = element_text(size = 12),
      axis.text = element_blank(),
      axis.ticks = element_blank()
    )

  return(the_plot)
})

# gif is too large in one file (and takes to long to view). Get indices to create  gifs in chunks
early_epoch = which(unique_dates <= as.Date('2001-12-31'))
up_to_housing_crisis = which(unique_dates >= as.Date('2002-01-01') & unique_dates <= as.Date('2005-12-31'))
housing_crisis = which(unique_dates >= as.Date('2006-01-01') & unique_dates <= as.Date('2011-12-31'))
post_crisis = which(unique_dates >= as.Date('2012-01-01'))

overall_plot_list = list(
  early_epoch = date_plots[early_epoch],
  up_to_housing_crisis = date_plots[up_to_housing_crisis],
  housing_crisis = date_plots[housing_crisis],
  post_crisis = date_plots[post_crisis]
)

# loop over overall plot list and then within each lists to print plots and convert to gif
dir.create('the_plots')
setwd('the_plots')

for (list_it in 1:length(overall_plot_list)) {

  plot_list = overall_plot_list[[list_it]]

  # save down blank map for first image
  ggsave(paste0('plot_', 0, '.png'), height = 6, width = 6, units = 'in', dpi = 250, plot = blank_map)

  for (it in 1:length(plot_list)) {
    the_plot = plot_list[[it]]
    ggsave(paste0('plot_', it, '.png'), height = 6, width = 6, units = 'in', dpi = 250, plot = the_plot)
  }

  gif_command = paste0("convert -size 800x800 -loop 0 -delay 50 ", paste(paste0('plot_', 0:length(plots_to_save), '.png'), collapse = ' '), sprintf(' house_prices_change_%s.gif', list_it))
  shell(gif_command)
  plot_files = list.files(pattern = '^(plot_)')
  lapply(plot_files, file.remove)
}


# Define UI for application

shiny::shinyUI(shiny::fluidPage(

  # Application title
  shiny::titlePanel("Response to selection with several locations in two steps"),

  # Input values
  shiny::fluidRow(
    shiny::column(4,
      shiny::wellPanel(
        shiny::h3("Number of genotypes, locations and replications at each step:"),
        shiny::numericInput("g", "Number of genotypes at begining:", 1000),
        shiny::numericInput("k1", "Number of locations at step 1:", 2),
        shiny::numericInput("r1", "Number of replications at step 1:", 2),
        shiny::numericInput("sg1", "Selected genotypes at step 1:", 100),
        shiny::numericInput("k2", "Number of locations at step 2:", 5),
        shiny::numericInput("r2", "Number of replications at step 2:", 3),
        shiny::numericInput("sg2", "Selected genotypes at step 2:", 10)
      )),
    shiny::column(3,
      shiny::wellPanel(
        shiny::h3("Estimated variances:"),
        shiny::numericInput("sigmaG2", "G variance:", 1),
        shiny::numericInput("sigmaGL2", "GxL variance:", 1),
        shiny::numericInput("sigmaGY2", "GxY variance:", 1),
        shiny::numericInput("sigmaGLY2", "GxLxY variance:", 1),
        shiny::numericInput("sigmaE2", "Error variance:", 1)
      )),
    shiny::column(3,
      shiny::wellPanel(
        shiny::h3("Response to selection:"),
        # Show the plot
        shiny::tableOutput("rtstable4")
        )
      )
    )
  )
)


install.packages("tidyverse")
install.packages("cluster")
install.packages("factoextra")
install.packages("ggthemes") # gerekli olan paketlerin yüklenmesi
install.packages("ggplot2")
install.packages("FactoMineR")

library(tidyverse)
library(cluster)
library(ggthemes)
library(ggplot2)
library(factoextra)
library(FactoMineR)
tma<-theme_igray()
asil <- read.csv('winemag-data_first150k.csv') # Veri setinin değişkene atanma işlemi

asil[1] <- NULL
asil[2] <- NULL
asil[2] <- NULL       # Veri setinden kullanmak istediğim satırlar haricini siliyorum.
asil[4] <- NULL
asil[5] <- NULL
asil[6] <-  NULL

summary(asil) # Veri setinin değerlerinin özetini basmaktadır.

df <- na.omit(asil)            # NA, NULL veya anlamsız bulunan verilerin çıkarılma işlemini yapar.
df$points <- scale(df$points)  # Scale standartlaştırma işlemi yapılmaktadır.
df$price <- scale(df$price)	   # Veri seti içinde string olduğu için ayrı oldu.

library(factoextra) # factoextra adlı kütüphaneyi aktif edildi.

set.seed(123) # Random atanacak değerlerin tutarlı olması için yapılan işlemdir.

#fviz_nbclust(df, kmeans, method="wss") # k değerinin hangi değerlerde verimli olacağını hesaplanması için
# Fakat hata alıyorum : Error: cannot allocate vector of size 70.2 Gb
# Bu yüzden veri setini 20000 binlik rastgele seçilen elemanlardan tekrar oluşturup yaptım.
# Bu nedenle değerler sizde farklı çıkabilir. Nedeni rastgele satırların seçilmesi ve yeterli ram miktarına sahip olmamam

df1 <- df[sample(nrow(df), 10000), ] # rastgele seçilen satırlar df1 değişkenine atanır.

fviz_nbclust(df1[,2:3], kmeans, method = 'wss') # Burada seçilen sütünların k değerinin hangi değerleri sağladığını göstermek
# için grafik çizmektedir.

set.seed(123)

km.res<-kmeans(df1[2:3], 2, nstart=25) # 2 değeri için k yakınlık değerleri ve kümeler belirlenir.
print("k=2 icin \n")
print(km.res) # Bastırılır.
k2 <- fviz_cluster(km.res, data=df1[,2:3])+ tma # Kümelenmiş olarak grafik bastırır.

# k = 5 değeri için ayrıca yaptım.

km.res1<-kmeans(df1[2:3], 5, nstart=25)
k5 <- fviz_cluster(km.res1, data=df1[,2:3])+ tma
print("k=5 icin \n" )
print(km.res) # Bastırılır.

#k=4 degeri icin de ayrica yaptim.
k4 <- fviz_cluster(km.res1, data=df1[,2:3])+ tma
print("k=4 icin \n")

print(km.res) # Bastırılır.

t2=c('US','Italy','France','Spain','Chile','Argentine','Other') 	# Ülkeri karakter dizisine aldım.
t3=c(62139,18784,14785,8160,5766,5587,22014)		                  # 150 bin değer üzerinden bulunan değer alıp karakter dizisine atadım.
pct <- round(t3/sum(t3)*100)	                                    # pct değişkenine yüzde değerlerini alabilmek için, her değerin toplamının 100 ile çarpımına böldüm.
lbls <- paste(t2, pct)                                            # Ülkelerin isimleriyle pct değerlerini eşleştirdim.
lbls <- paste(lbls,"%",sep="")                                    # Her değerin başına yüzde işareti ve boşluksuz yazılmasını sağladım.
pie(t3,labels = lbls, col=rainbow(length(lbls)),main="Ülkelerin şarap üretimi")

Puanlandirma.ve.Fiyat <- qplot(asil$country,asil$points,data=asil,geom=c("boxplot", "jitter"),xlab = "Ülkeler",ylab = "Şarap Puanlaması",main = "Şarap puanlaması ve üretildiği ülkeler") + theme(axis.title=element_text(face="bold", size="24",color="red"), legend.position="top")


require(ncdf4)
require(abind)

##########################################################
# Interpolate HadDTR to all values in CMIP5 at 1.25x1.25
##########################################################
# Read in DTR
load('temp/dtrclimatology1.25.rdata') # dtr125 at 1.25x1.25
# load('dtrclimatology1.25.rdata') # dtr125 at 1.25x1.25 (Amphiprion)

# Read in CMIP5
infile <- nc_open('data_dl/cmip5/tos_Omon_modmean_rcp85_ave.nc') # tos for each month
# infile <- nc_open('tos_Omon_modmean_rcp85_ave.nc') # tos for each month (Amphiprion)
	# print(infile)
	tos <- ncvar_get(infile, 'tos', start=c(1,1,1,1), count=c(-1,-1,1,1)) # tos 288 x 144 x 2800 lon x lat x months 1861-2100 (level is 4th dimension, length 1)
	dim(tos)
	dimnames(tos) <- list(lon=1:288, lat=1:144)
	dimnames(tos)[[1]] <- infile$var[['tos']]$dim[[1]]$vals # add lon
	dimnames(tos)[[2]] <- infile$var[['tos']]$dim[[2]]$vals # add lat
	nc_close(infile)

# rotate cmip5 columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
tos <- aperm(tos, c(2,1))

lats <- as.numeric(rownames(tos))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)
tos <- tos[newlatord, ]

#	image(tos[,])

# make tos 12 layers to match dtr125
tosl <- abind(list(tos)[rep(1,12)], along=3)
	dim(tosl)

# interpolate dtr to all values in tos
# PARALLEL version. Takes an hour maybe?
require(parallel)
require(iterators)
require(doMC)
require(doParallel)
require(doSNOW)

	# start cluster
cl <- makeCluster(rep('localhost', 3), type='SOCK') # make the cluster on the localhost
# cl <- makeCluster(rep('localhost', 20), type='SOCK') # make the cluster on the localhost (Amphiprion)
registerDoSNOW(cl) # register the cluster so accessible to foreach

	# set up parameters
rg <- 30 # how many lat/lon grids in each direction to average over
inds <- as.matrix(which(is.na(dtr125) & !is.na(tosl), arr.ind=TRUE)) # find missing values that shouldn't be missing
	nrow(inds) # 43462
whichinds <- 1:nrow(inds) # if I only want to run some rows of inds
#whichinds <- 1:10 # if I only want to run some rows of inds
	length(whichinds)
iterator <- iter(inds[whichinds,], by='row') # make an iterator object to step through
pb <- txtProgressBar(max = length(whichinds), style = 3) # https://stackoverflow.com/questions/5423760/how-do-you-create-a-progress-bar-when-using-the-foreach-function-in-r
progress <- function(n) setTxtProgressBar(pb, n)
opts <- list(progress = progress)

	# run loop
res <- foreach(i=iterator, .combine=c, .options.snow=opts) %dopar% {
	averng <- expand.grid(lat=(i[,1]-rg):(i[,1]+rg), lon=(i[,2]-rg):(i[,2]+rg)) # define grid over which to average
	averng <- averng[averng$lat>0 & averng$lat<dim(dtr125)[1] & averng$lon>0 & averng$lon<dim(dtr125)[2],] # remove out-of-range indices into dtr
	averng$mo <- i[,3] # average within same mo and year
	averng$w <- sqrt((averng$lat-i[,1])^2 + (averng$lon-i[,2])^2) # calculate Euclidean distance to each grid cell
	averng <- averng[averng$w>0,] # trim out self-reference
	averng <- as.matrix(averng) # so that we can use it as an index
	av <- weighted.mean(x=dtr125[averng[,1:3]], w=1/averng[,4], na.rm=TRUE) # inverse distance weighting. use vectorized selection with first 4 columns of averng
	return(av)
}

	# stop cluster
	close(pb)
	stopCluster(cl)

	# how many missing?
	sum(is.na(res))

	# add results back into array
	dtr125[inds[whichinds,,drop=FALSE]] <- res # drop=FALSE so that 1-row matrix would still be a matrix we can use for vectorized selection

	# set NAs in tosl to missing in DTR
	nas <- is.na(tosl)
	dtr125[nas] <- NA

	# check if any values still missing
	sum(is.na(dtr125))
	sum(is.na(tosl)) # should match: not quite
	sum(!is.na(tosl) & is.na(dtr125)) # dtr125 is missing 24

		image(dtr125[,,1])
		image(tos)

save(dtr125, file='temp/dtrclimatology_interp1.25.rdata')
# save(dtr125, file='dtrclimatology_interp1.25.rdata') # Amphiprion

##########################################################
# Interpolate HadDTR to all values in OISST at 0.5x0.5
##########################################################
# Read in
load('temp/oisst0.5deg_1986_2005.rdata') # tempsarray at 0.5x0.5 1986-2005
load('temp/dtrclimatology.rdata') # dtr at 0.5x0.5

nms <- dimnames(tempsarray)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(tempsarray)
tempsarraybymo <- array(tempsarray, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

# rotate sst monthly temps 1986-2005 so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(nms[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(nms[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstbymo <- tempsarraybymo[newlatord, newlonord,,] # lat x lon (0-360) x month x year
dimnames(sstbymo)[[2]] <- newcolnms

	image(sstbymo[,,1,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstbymo)), labels=rownames(sstbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(sstbymo)), labels=colnames(sstbymo), cex.axis=0.4)

# interpolate dtr to all values in sstbymo
# PARALLEL version. Takes an hour maybe?
require(parallel)
require(iterators)
require(doMC)
require(doParallel)
require(doSNOW)

	# start cluster
cl <- makeCluster(rep('localhost', 3), type='SOCK') # make the cluster on the localhost
registerDoSNOW(cl) # register the cluster so accessible to foreach

	# set up parameters
rg <- 75 # how many lat/lon grids in each direction to average over
inds <- as.matrix(which(is.na(dtr) & !is.na(sstbymo[,,,1]), arr.ind=TRUE)) # find missing values that shouldn't be missing
	nrow(inds) # 231096
whichinds <- 1:nrow(inds) # if I only want to run some rows of inds
#whichinds <- 1:10 # if I only want to run some rows of inds
	length(whichinds)
iterator <- iter(inds[whichinds,], by='row') # make an iterator object to step through
pb <- txtProgressBar(max = length(whichinds), style = 3) # https://stackoverflow.com/questions/5423760/how-do-you-create-a-progress-bar-when-using-the-foreach-function-in-r
progress <- function(n) setTxtProgressBar(pb, n)
opts <- list(progress = progress)

	# run loop
res <- foreach(i=iterator, .combine=c, .options.snow=opts) %dopar% {
	averng <- expand.grid(lat=(i[,1]-rg):(i[,1]+rg), lon=(i[,2]-rg):(i[,2]+rg)) # define grid over which to average
	averng <- averng[averng$lat>0 & averng$lat<dim(dtr)[1] & averng$lon>0 & averng$lon<dim(dtr)[2],] # remove out-of-range indices into dtr
	averng$mo <- i[,3] # average within same mo and year
	averng$w <- sqrt((averng$lat-i[,1])^2 + (averng$lon-i[,2])^2) # calculate Euclidean distance to each grid cell
	averng <- averng[averng$w>0,] # trim out self-reference
	averng <- as.matrix(averng) # so that we can use it as an index
	av <- weighted.mean(x=dtr[averng[,1:3]], w=1/averng[,4], na.rm=TRUE) # inverse distance weighting. use vectorized selection with first 4 columns of averng
	return(av)
}

	# stop cluster
	close(pb)
	stopCluster(cl)

	# how many missing?
	sum(is.na(res))

	# add results back into array
	dtr[inds[whichinds,,drop=FALSE]] <- res # drop=FALSE so that 1-row matrix would still be a matrix we can use for vectorized selection

	# set NAs in sstbymo to missing in DTR
	nas <- is.na(sstbymo[,,,1])
	dtr[nas] <- NA

	# check if any values still missing
	sum(is.na(dtr))
	sum(is.na(sstbymo[,,,1])) # should match: dtr is missing 2

		image(dtr[,,1])
		image(sstbymo[,,1,1])

save(dtr, file='temp/dtrclimatology_interp.rdata')

##########################################################
# Interpolate HadDTR to all values in OISST at 0.25x0.25
##########################################################
# Read in (for MacBook)
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25 1986-1990
load('temp/dtrclimatology0.25.rdata') # dtr025
ncores=3

# Read in (if on Amphiprion)
# load('oisst1986_1990.rdata') # tempsarray at 0.25x0.25 1986-1990
# load('dtrclimatology0.25.rdata') # dtr025
# ncores=20

nms <- dimnames(tempsarray)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(tempsarray)
tempsarraybymo <- array(tempsarray, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

# rotate sst monthly temps 1986-2005 so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(nms[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(nms[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstbymo <- tempsarraybymo[newlatord, newlonord,,] # lat x lon (0-360) x month x year
dimnames(sstbymo)[[2]] <- newcolnms

	image(sstbymo[,,1,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstbymo)), labels=rownames(sstbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(sstbymo)), labels=colnames(sstbymo), cex.axis=0.4)

# interpolate dtr to all values in sstbymo
# PARALLEL version. Takes an hour maybe?
require(parallel)
require(iterators)
require(doMC)
require(doParallel)
require(doSNOW)

	# start cluster
cl <- makeCluster(rep('localhost', ncores), type='SOCK') # make the cluster on the localhost
registerDoSNOW(cl) # register the cluster so accessible to foreach

	# set up parameters
rg <- 150 # how many lat/lon grids in each direction to average over
inds <- as.matrix(which(is.na(dtr025) & !is.na(sstbymo[,,,1]), arr.ind=TRUE)) # find missing values that shouldn't be missing
	nrow(inds) # 972382
whichinds <- 1:nrow(inds) # if I only want to run some rows of inds
#whichinds <- 1:10 # if I only want to run some rows of inds
	length(whichinds)
iterator <- iter(inds[whichinds,], by='row') # make an iterator object to step through
pb <- txtProgressBar(max = length(whichinds), style = 3) # https://stackoverflow.com/questions/5423760/how-do-you-create-a-progress-bar-when-using-the-foreach-function-in-r
progress <- function(n) setTxtProgressBar(pb, n)
opts <- list(progress = progress)

	# run loop
res <- foreach(i=iterator, .combine=c, .options.snow=opts) %dopar% {
	averng <- expand.grid(lat=(i[,1]-rg):(i[,1]+rg), lon=(i[,2]-rg):(i[,2]+rg)) # define grid over which to average
	averng <- averng[averng$lat>0 & averng$lat<dim(dtr025)[1] & averng$lon>0 & averng$lon<dim(dtr025)[2],] # remove out-of-range indices into dtr025
	averng$mo <- i[,3] # average within same mo and year
	averng$w <- sqrt((averng$lat-i[,1])^2 + (averng$lon-i[,2])^2) # calculate Euclidean distance to each grid cell
	averng <- averng[averng$w>0,] # trim out self-reference
	averng <- as.matrix(averng) # so that we can use it as an index
	av <- weighted.mean(x=dtr025[averng[,1:3]], w=1/averng[,4], na.rm=TRUE) # inverse distance weighting. use vectorized selection with first 4 columns of averng
	return(av)
}

	# stop cluster
	close(pb) # the progress bar
	stopCluster(cl)

	# how many missing?
	sum(is.na(res)) # 590

	# add results back into array
	dtr025[inds[whichinds,,drop=FALSE]] <- res # drop=FALSE so that 1-row matrix would still be a matrix we can use for vectorized selection

	# set NAs in sstbymo to missing in dtr025
	nas <- is.na(sstbymo[,,,1])
	dtr025[nas] <- NA

	# check if any values still missing
	sum(is.na(dtr025))
	sum(is.na(sstbymo[,,,1])) # should match
	sum(!is.na(sstbymo[,,,1]) & is.na(dtr025)) # dtr025 is missing 590

		image(dtr025[,,1])
		image(sstbymo[,,1,1])

save(dtr025, file='temp/dtrclimatology_interp0.25.rdata')
# save(dtr025, file='dtrclimatology_interp0.25.rdata') # on Amphiprion


###############################################################################
# NMDS_bioenv
#------------------------------------------------------------------------------
# by Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
#
###############################################################################

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(vegan)
library(ggplot2)
library(grid)

#==============================================================================
# Let's rock'n'roll!
#==============================================================================
#
# Tutorial on plotting significant taxa and environmental variables on an NMDS
# plot using ggplot2.
# by Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
#

# This R script is an extension of vegan library's bioenv()
# function and uses the bio.env() and bio.step() of
#	http://menugget.blogspot.co.uk/2011/06/clarke-and-ainsworths-bioenv-and-bvstep.html
#	The original author suggested these functions to overcome
#	the inflexibility of the bioenv() function which uses
#	a similarity matrix based on normalized "euclidean" distance.
# The new functions are given below and implement the following algorithms:
# Clarke, K. R & Ainsworth, M. 1993. A method of linking multivariate community structure to environmental variables. Marine Ecology Progress Series, 92, 205-219.
# Clarke, K. R., Gorley, R. N., 2001. PRIMER v5: User Manual/Tutorial. PRIMER-E, Plymouth, UK.
# Clarke, K. R., Warwick, R. M., 2001. Changes in Marine Communities: An Approach to Statistical Analysis and Interpretation, 2nd edition. PRIMER-E Ltd, Plymouth, UK.
# Clarke, K. R., Warwick, R. M., 1998. Quantifying structural redundancy in ecological communities. Oecologia, 113:278-289.

bv.step  <-  function(fix.mat, var.mat,
                    fix.dist.method="bray", var.dist.method="euclidean", correlation.method="spearman",
                    scale.fix=FALSE, scale.var=TRUE,
                    max.rho=0.95,
                    min.delta.rho=0.001,
                    random.selection=TRUE,
                    prop.selected.var=0.2,
                    num.restarts=10,
                    var.always.include=NULL,
                    var.exclude=NULL,
                    output.best=10
){

  if(dim(fix.mat)[1] != dim(var.mat)[1]){stop("fixed and variable matrices must have the same number of rows")}
  if(sum(var.always.include %in% var.exclude) > 0){stop("var.always.include and var.exclude share a variable")}
  require(vegan)

  if(scale.fix){fix.mat <- scale(fix.mat)}else{fix.mat <- fix.mat}
  if(scale.var){var.mat <- scale(var.mat)}else{var.mat <- var.mat}

  fix.dist  <-  vegdist(as.matrix(fix.mat), method=fix.dist.method)

  # an initial removal phase
  var.dist.full  <-  vegdist(as.matrix(var.mat), method=var.dist.method)
  full.cor  <-  suppressWarnings(cor.test(fix.dist, var.dist.full, method=correlation.method))$estimate
  var.comb  <-  combn(1:ncol(var.mat), ncol(var.mat)-1)
  RES  <-  data.frame(var.excl=rep(NA,ncol(var.comb)), n.var=ncol(var.mat)-1, rho=NA)
  for(i in 1:dim(var.comb)[2]){
    var.dist  <-  vegdist(as.matrix(var.mat[,var.comb[,i]]), method=var.dist.method)
    temp  <-  suppressWarnings(cor.test(fix.dist, var.dist, method=correlation.method))
    RES$var.excl[i]  <-  c(1:ncol(var.mat))[-var.comb[,i]]
    RES$rho[i]  <-  temp$estimate
  }
  delta.rho  <-  RES$rho - full.cor
  exclude  <-  sort(unique(c(RES$var.excl[which(abs(delta.rho) < min.delta.rho)], var.exclude)))

  if(random.selection){
    num.restarts=num.restarts
    prop.selected.var=prop.selected.var
    prob <- rep(1,ncol(var.mat))
    if(prop.selected.var< 1){
      prob[exclude] <- 0
    }
    n.selected.var  <-  min(sum(prob),prop.selected.var*dim(var.mat)[2])
  } else {
    num.restarts=1
    prop.selected.var=1
    prob <- rep(1,ncol(var.mat))
    n.selected.var  <-  min(sum(prob),prop.selected.var*dim(var.mat)[2])
  }

  RES_TOT  <-  c()
  for(i in 1:num.restarts){
    step=1
    RES  <-  data.frame(step=step, step.dir="F", var.incl=NA, n.var=0, rho=0)
    attr(RES$step.dir, "levels")  <-  c("F","B")
    best.comb  <-  which.max(RES$rho)
    best.rho  <-  RES$rho[best.comb]
    delta.rho  <-  Inf
    selected.var  <-  sort(unique(c(sample(1:dim(var.mat)[2], n.selected.var, prob=prob), var.always.include)))
    while(best.rho < max.rho & delta.rho > min.delta.rho & RES$n.var[best.comb] < length(selected.var)){
      # forward step
      step.dir="F"
      step=step+1
      var.comb  <-  combn(selected.var, RES$n.var[best.comb]+1, simplify=FALSE)
      if(RES$n.var[best.comb] == 0){
        var.comb.incl <- 1:length(var.comb)
      } else {
        var.keep  <-  as.numeric(unlist(strsplit(RES$var.incl[best.comb], ",")))
        temp  <-  NA*1:length(var.comb)
        for(j in 1:length(temp)){
          temp[j]  <-  all(var.keep %in% var.comb[[j]])
        }
        var.comb.incl  <-  which(temp==1)
      }

      RES.f  <-  data.frame(step=rep(step, length(var.comb.incl)), step.dir=step.dir, var.incl=NA, n.var=RES$n.var[best.comb]+1, rho=NA)
      for(f in 1:length(var.comb.incl)){
        var.incl  <-  var.comb[[var.comb.incl[f]]]
        var.incl  <-  var.incl[order(var.incl)]
        var.dist  <-  vegdist(as.matrix(var.mat[,var.incl]), method=var.dist.method)
        temp  <-  suppressWarnings(cor.test(fix.dist, var.dist, method=correlation.method))
        RES.f$var.incl[f]  <-  paste(var.incl, collapse=",")
        RES.f$rho[f]  <-  temp$estimate
      }

      last.F  <-  max(which(RES$step.dir=="F"))
      RES  <-  rbind(RES, RES.f[which.max(RES.f$rho),])
      best.comb  <-  which.max(RES$rho)
      delta.rho  <-  RES$rho[best.comb] - best.rho
      best.rho  <-  RES$rho[best.comb]

      if(best.comb == step){
        while(best.comb == step & RES$n.var[best.comb] > 1){
          # backward step
          step.dir="B"
          step  <-  step+1
          var.keep  <-  as.numeric(unlist(strsplit(RES$var.incl[best.comb], ",")))
          var.comb  <-  combn(var.keep, RES$n.var[best.comb]-1, simplify=FALSE)
          RES.b  <-  data.frame(step=rep(step, length(var.comb)), step.dir=step.dir, var.incl=NA, n.var=RES$n.var[best.comb]-1, rho=NA)
          for(b in 1:length(var.comb)){
            var.incl  <-  var.comb[[b]]
            var.incl  <-  var.incl[order(var.incl)]
            var.dist  <-  vegdist(as.matrix(var.mat[,var.incl]), method=var.dist.method)
            temp  <-  suppressWarnings(cor.test(fix.dist, var.dist, method=correlation.method))
            RES.b$var.incl[b]  <-  paste(var.incl, collapse=",")
            RES.b$rho[b]  <-  temp$estimate
          }
          RES  <-  rbind(RES, RES.b[which.max(RES.b$rho),])
          best.comb  <-  which.max(RES$rho)
          best.rho <-  RES$rho[best.comb]
        }
      } else {
        break()
      }

    }

    RES_TOT  <-  rbind(RES_TOT, RES[2:dim(RES)[1],])
    print(paste(round((i/num.restarts)*100,3), "% finished"))
  }

  RES_TOT  <-  unique(RES_TOT[,3:5])

  if(dim(RES_TOT)[1] > output.best){
    order.by.best  <-  RES_TOT[order(RES_TOT$rho, decreasing=TRUE)[1:output.best],]
  } else {
    order.by.best  <-   RES_TOT[order(RES_TOT$rho, decreasing=TRUE), ]
  }
  rownames(order.by.best) <- NULL

  order.by.i.comb  <-  c()
  for(i in 1:length(selected.var)){
    f1  <-  which(RES_TOT$n.var==i)
    f2  <-  which.max(RES_TOT$rho[f1])
    order.by.i.comb  <-  rbind(order.by.i.comb, RES_TOT[f1[f2],])
  }
  rownames(order.by.i.comb) <- NULL

  if(length(exclude)<1){var.exclude=NULL} else {var.exclude=exclude}
  out  <-  list(
    order.by.best=order.by.best,
    order.by.i.comb=order.by.i.comb,
    best.model.vars=paste(colnames(var.mat)[as.numeric(unlist(strsplit(order.by.best$var.incl[1], ",")))], collapse=","),
    best.model.rho=order.by.best$rho[1],
    var.always.include=var.always.include,
    var.exclude=var.exclude
  )
  out

}

bio.env  <-  function(fix.mat, var.mat,
                    fix.dist.method="bray", var.dist.method="euclidean", correlation.method="spearman",
                    scale.fix=FALSE, scale.var=TRUE,
                    output.best=10,
                    var.max=ncol(var.mat)
){
  if(dim(fix.mat)[1] != dim(var.mat)[1]){stop("fixed and variable matrices must have the same number of rows")}
  if(var.max > dim(var.mat)[2]){stop("var.max cannot be larger than the number of variables (columns) in var.mat")}

  require(vegan)

  combn.sum  <-  sum(factorial(ncol(var.mat))/(factorial(1:var.max)*factorial(ncol(var.mat)-1:var.max)))

  if(scale.fix){fix.mat <- scale(fix.mat)}else{fix.mat <- fix.mat}
  if(scale.var){var.mat <- scale(var.mat)}else{var.mat <- var.mat}
  fix.dist  <-  vegdist(fix.mat, method=fix.dist.method)
  RES_TOT  <-  c()
  best.i.comb  <-  c()
  iter  <-  0
  for(i in 1:var.max){
    var.comb  <-  combn(1:ncol(var.mat), i, simplify=FALSE)
    RES  <-  data.frame(var.incl=rep(NA, length(var.comb)), n.var=i, rho=0)
    for(f in 1:length(var.comb)){
      iter  <-  iter+1
      var.dist  <-  vegdist(as.matrix(var.mat[,var.comb[[f]]]), method=var.dist.method)
      temp  <-  suppressWarnings(cor.test(fix.dist, var.dist, method=correlation.method))
      RES$var.incl[f]  <-  paste(var.comb[[f]], collapse=",")
      RES$rho[f]  <-  temp$estimate
      if(iter %% 100 == 0){print(paste(round(iter/combn.sum*100, 3), "% finished"))}
    }

    order.rho  <-  order(RES$rho, decreasing=TRUE)
    best.i.comb  <-  c(best.i.comb, RES$var.incl[order.rho[1]])
    if(length(order.rho) > output.best){
      RES_TOT  <-  rbind(RES_TOT, RES[order.rho[1:output.best],])
    } else {
      RES_TOT  <-  rbind(RES_TOT, RES)
    }
  }
  rownames(RES_TOT) <- NULL

  if(dim(RES_TOT)[1] > output.best){
    order.by.best  <-  order(RES_TOT$rho, decreasing=TRUE)[1:output.best]
  } else {
    order.by.best  <-  order(RES_TOT$rho, decreasing=TRUE)
  }
  OBB  <-  RES_TOT[order.by.best,]
  rownames(OBB)  <-  NULL

  order.by.i.comb  <-  match(best.i.comb, RES_TOT$var.incl)
  OBC  <-  RES_TOT[order.by.i.comb,]
  rownames(OBC)  <-  NULL

  out  <-  list(
    order.by.best=OBB,
    order.by.i.comb=OBC,
    best.model.vars=paste(colnames(var.mat)[as.numeric(unlist(strsplit(OBB$var.incl[1], ",")))], collapse=",") ,
    best.model.rho=OBB$rho[1]
  )
  out
}

abund_table <- read.csv("SPE_pitlatrine.csv",row.names=1,check.names=FALSE)

# Transpose the data to have sample names on rows
abund_table <- t(abund_table)
meta_table <- read.csv("ENV_pitlatrine.csv",row.names=1,check.names=FALSE)

# Just a check to ensure that the samples in meta_table are in the same order as in abund_table
meta_table <- meta_table[rownames(abund_table),]

# Get grouping information
grouping_info <- data.frame(row.names=rownames(abund_table),t(as.data.frame(strsplit(rownames(abund_table),"_"))))

# Parameters
cmethod <- "pearson" # Correlation method to use: pearson, pearman, kendall
fmethod <- "bray" # Fixed distance method: euclidean, manhattan, gower, altGower, canberra, bray, kulczynski, morisita,horn, binomial, and cao
vmethod <- "bray" # Variable distance method: euclidean, manhattan, gower, altGower, canberra, bray, kulczynski, morisita,horn, binomial, and cao
nmethod <- "bray" # NMDS distance method:  euclidean, manhattan, gower, altGower, canberra, bray, kulczynski, morisita,horn, binomial, and cao

res  <-  bio.env(wisconsin(abund_table), meta_table,fix.dist.method=fmethod, var.dist.method=vmethod, correlation.method=cmethod,
               scale.fix=FALSE, scale.var=TRUE)

# Get the 10 best subset of environmental variables
envNames <- colnames(meta_table)
bestEnvFit <- ""
for(i in (1:length(res$order.by.best$var.incl)))
{
  bestEnvFit[i] <- paste(paste(envNames[as.numeric(unlist(strsplit(res$order.by.best$var.incl[i], split=",")))],collapse=' + '), " = ",res$order.by.best$rho[i],sep="")
}
bestEnvFit <- data.frame(bestEnvFit)
colnames(bestEnvFit) <- "Best combination of environmental variables with similarity score"

res.bv.step.biobio  <-  bv.step(wisconsin(abund_table), wisconsin(abund_table),
                              fix.dist.method=fmethod, var.dist.method=vmethod,correlation.method=cmethod,
                              scale.fix=FALSE, scale.var=FALSE,
                              max.rho=0.95, min.delta.rho=0.001,
                              random.selection=TRUE,
                              prop.selected.var=0.3,
                              num.restarts=10,
                              output.best=10,
                              var.always.include=NULL)

# Get the 10 best subset of taxa
taxaNames <- colnames(abund_table)
bestTaxaFit <- ""
for(i in (1:length(res.bv.step.biobio$order.by.best$var.incl)))
{
  bestTaxaFit[i] <- paste(paste(taxaNames[as.numeric(unlist(strsplit(res.bv.step.biobio$order.by.best$var.incl[i], split=",")))],collapse=' + '), " = ",res.bv.step.biobio$order.by.best$rho[i],sep="")
}
bestTaxaFit <- data.frame(bestTaxaFit)
colnames(bestTaxaFit) <- "Best combination of taxa with similarity score"

# > bestTaxaFit
# Best combination of taxa with similarity score
# 1                             Bacilli + Bacteroidia + Chrysiogenetes + Clostridia + Dehalococcoidetes + Fibrobacteria + Flavobacteria + Fusobacteria + Gammaproteobacteria + Methanomicrobia + Mollicutes + Opitutae + Synergistia + Thermomicrobia + Unknown = 0.900998476657462
# 2                                              Bacilli + Bacteroidia + Clostridia + Dehalococcoidetes + Fibrobacteria + Flavobacteria + Fusobacteria + Gammaproteobacteria + Methanomicrobia + Mollicutes + Opitutae + Synergistia + Thermomicrobia + Unknown = 0.899912718316228
# 3                                                        Bacilli + Bacteroidia + Clostridia + Dehalococcoidetes + Fibrobacteria + Flavobacteria + Fusobacteria + Gammaproteobacteria + Methanomicrobia + Mollicutes + Opitutae + Synergistia + Thermomicrobia = 0.896821772937576
# 4  Clostridia + Dehalococcoidetes + Deltaproteobacteria + Epsilonproteobacteria + Erysipelotrichi + Flavobacteria + Fusobacteria + Methanobacteria + Mollicutes + Opitutae + Planctomycetacia + Sphingobacteria + Subdivision3 + Synergistia + Thermomicrobia = 0.892670058822226
# 5                                                                     Bacilli + Bacteroidia + Clostridia + Dehalococcoidetes + Fibrobacteria + Flavobacteria + Fusobacteria + Gammaproteobacteria + Methanomicrobia + Opitutae + Synergistia + Thermomicrobia = 0.892533063335985
# 6                   Clostridia + Dehalococcoidetes + Deltaproteobacteria + Epsilonproteobacteria + Erysipelotrichi + Flavobacteria + Fusobacteria + Methanobacteria + Mollicutes + Opitutae + Planctomycetacia + Sphingobacteria + Subdivision3 + Synergistia = 0.891217789278463
# 7                                     Clostridia + Dehalococcoidetes + Deltaproteobacteria + Epsilonproteobacteria + Erysipelotrichi + Flavobacteria + Fusobacteria + Mollicutes + Opitutae + Planctomycetacia + Sphingobacteria + Subdivision3 + Synergistia = 0.888669881927483
# 8                                                                                Bacilli + Bacteroidia + Clostridia + Dehalococcoidetes + Fibrobacteria + Flavobacteria + Fusobacteria + Gammaproteobacteria + Opitutae + Synergistia + Thermomicrobia = 0.887052815492516
# 9                                                  Clostridia + Dehalococcoidetes + Deltaproteobacteria + Epsilonproteobacteria + Erysipelotrichi + Flavobacteria + Fusobacteria + Opitutae + Planctomycetacia + Sphingobacteria + Subdivision3 + Synergistia = 0.885880090785632
# 10                             Acidobacteria_Gp4 + Actinobacteria + Bacilli + Betaproteobacteria + Clostridia + Dehalococcoidetes + Erysipelotrichi + Fibrobacteria + Lentisphaeria + Methanomicrobia + Opitutae + Sphingobacteria + Thermomicrobia + Unknown = 0.882956559638505

# Generate NMDS plot
MDS_res=metaMDS(abund_table, distance = nmethod, k = 2, trymax = 50)

bio.keep  <-  as.numeric(unlist(strsplit(res.bv.step.biobio$order.by.best$var.incl[1], ",")))
bio.fit  <-  envfit(MDS_res, abund_table[,bio.keep,drop=F], perm = 999)

# use the best set of environmental variables in env.keep
eval(parse(text=paste("env.keep  <-  c(",res$order.by.best$var.incl[1],")",sep="")))
env.fit  <-  envfit(MDS_res, meta_table[,env.keep,drop=F], perm = 999)

# Get site information
df <- scores(MDS_res,display=c("sites"))

# Add grouping information
df <- data.frame(df,Type=grouping_info[rownames(df),1])

# Get the vectors for bioenv.fit
df_biofit <- scores(bio.fit,display=c("vectors"))
df_biofit <- df_biofit*vegan:::ordiArrowMul(df_biofit)
df_biofit <- as.data.frame(df_biofit)

# Get the vectors for env.fit
df_envfit <- scores(env.fit,display=c("vectors"))
df_envfit <- df_envfit*vegan:::ordiArrowMul(df_envfit)
df_envfit <- as.data.frame(df_envfit)

#==============================================================================
# Draw samples
#==============================================================================

p <- ggplot()
p <- p+geom_point(data=df,aes(NMDS1,NMDS2,colour=Type))
# Draw taxas
p <- p+geom_segment(data=df_biofit, aes(x = 0, y = 0, xend = NMDS1, yend = NMDS2),
                  arrow = arrow(length = unit(0.2, "cm")),color="# 808080",alpha=0.5)

p <- p+geom_text(data=as.data.frame(df_biofit*1.1),aes(NMDS1, NMDS2, label = rownames(df_biofit)),color="# 808080",alpha=0.5)
# Draw environmental variables
p <- p+geom_segment(data=df_envfit, aes(x = 0, y = 0, xend = NMDS1, yend = NMDS2),
                  arrow = arrow(length = unit(0.2, "cm")),color="# 4C005C",alpha=0.5)

p <- p+geom_text(data=as.data.frame(df_envfit*1.1),aes(NMDS1, NMDS2, label = rownames(df_envfit)),color="# 4C005C",alpha=0.5)
p <- p+theme_bw()
pdf("NMDS_bioenv.pdf")
print(p)
dev.off()


generate_shapelets<-function(train_data,train_label,nofsample=50){
	difftrain_data=t(apply(train_data,1,diff))
	doubdifftrain_data = t(apply(difftrain_data,1,diff))
	train_dict = prepare_data(train_data,train_label)
	trainobs = train_dict$data
	classes = train_dict$class
	difftrain_dict = prepare_data(difftrain_data,train_label)
	difftrainobs = difftrain_dict$data
	doubdifftrain_dict = prepare_data(doubdifftrain_data,train_label)
	doubdifftrainobs = doubdifftrain_dict$data

	first=TRUE
	nsample=1
	for(repl in 1:nofsample){
		sec=unlist(lapply(classes,function(x) { ind=which(train_label==x);
			if(length(ind)<=nsample) { ind }	else {
				sample(ind,nsample);
		}}))
		inputtrain=as.data.frame(trainobs[tid %in% sec,c(2:4),with=F])
		diffinputtrain=as.data.frame(difftrainobs[tid %in% sec,c(2:4),with=F])
		doubdiffinputtrain=as.data.frame(doubdifftrainobs[tid %in% sec,c(2:4),with=F])

		fit=randomForest(inputtrain[,c(1,3)],inputtrain$obs,ntree=1,replace=F,sampsize=nrow(inputtrain))
		difffit=randomForest(diffinputtrain[,c(1,3)],diffinputtrain$obs,ntree=1,replace=F,sampsize=nrow(diffinputtrain))
		doubdifffit=randomForest(doubdiffinputtrain[,c(1,3)],doubdiffinputtrain$obs,ntree=1,replace=F,sampsize=nrow(doubdiffinputtrain))

		doubdifftrain_terminal=attr(predict(doubdifffit, as.matrix(doubdiffinputtrain[,c(1,3)]),nodes=TRUE), "nodes")
		difftrain_terminal=attr(predict(difffit, as.matrix(diffinputtrain[,c(1,3)]),nodes=TRUE), "nodes")
		train_terminal=attr(predict(fit, as.matrix(inputtrain[,c(1,3)]),nodes=TRUE), "nodes")

		inputtrain=data.table(inputtrain)
		inputtrain[,TerminalNodes:=train_terminal]
		newinput=inputtrain[,list(Start=min(times),End=max(times),Level=mean(obs),Times=times),by=list(TerminalNodes,cls)]#cls by
		diffinputtrain=data.table(diffinputtrain)
		diffinputtrain[,TerminalNodes:=difftrain_terminal]

		doubdiffinputtrain=data.table(doubdiffinputtrain)
		doubdiffinputtrain[,TerminalNodes:=doubdifftrain_terminal]

		adjust=diffinputtrain[times == max(diffinputtrain$times)]
		adjust$times=adjust$times+1
		diffinputtrain=rbind(diffinputtrain,adjust)
		diffnewinput=diffinputtrain[,list(DStart=min(times),DEnd=max(times),DLevel=mean(obs),Times=times),by=list(TerminalNodes,cls)]

		doubadjust=doubdiffinputtrain[times == max(doubdiffinputtrain$times)]
		doubadjust$times=doubadjust$times+1
		doubdiffinputtrain=rbind(doubdiffinputtrain,doubadjust)
		doubadjust$times=doubadjust$times+1
		doubdiffinputtrain=rbind(doubdiffinputtrain,doubadjust)
		doubdiffnewinput=doubdiffinputtrain[,list(DStart=min(times),DEnd=max(times),DLevel=mean(obs),Times=times),by=list(TerminalNodes,cls)]

		fulldata=merge(newinput,diffnewinput,by=c("cls","Times"),all=T)
		fulldata=merge(fulldata,doubdiffnewinput,by=c("cls","Times"),all=T)
		fulldata=fulldata[,by=list('cls','Times')]
		fulldata = fulldata[,list(Class=cls, Times=Times, TerminalNodes = TerminalNodes.x,Start=Start, End=End,Level=Level,Trial = mean(DLevel.x),DStart=DStart.x,DEnd=DEnd.x,Curvature=mean(DLevel.y),Length=End-Start+1,Consta=(Start-(Start+End)/2)+(Times-Start),DConsta=(DStart.x-(DStart.x+DEnd.x)/2)+(Times-DStart.x)),by=list(TerminalNodes.x)]

		fulldata[,a:=Curvature/2,by=list(TerminalNodes,Class,Times)]
		fulldata[,b:=Trial-a*(Length+1),by=list(TerminalNodes,Class,Times)]
		fulldata[,c:=Level-a*(Length+1)*(2*Length+1)/6-b*(Length+1)/2,by=list(TerminalNodes,Class,Times)]
		fulldata[,RealLevel:=a*(Times-Start+1)*(Times-Start+1)+b*(Times-Start+1)+c,by=list(TerminalNodes,Class,Times)]

		if(first){
		completefulldata=fulldata

		first=FALSE
		} else {
		completefulldata=rbind(completefulldata,fulldata)

		}
	}
	tempfulldata=completefulldata
	tempfulldata=tempfulldata[,by=list(Class,Level,Start,End)]
	tempfulldata[,Len:=End-Start+1]
	tempfulldata=tempfulldata[Len > 5]
	tempfulldata=tempfulldata[Len < 0.75*max(inputtrain$times)]
	if(nrow(tempfulldata)<1){
	  next
	}
	shapelet_temp = tempfulldata[,list(Len=Len),by=list(Class,Start,End)]

	if(nrow(shapelet_temp)<1){
	  next
	}
	shapelet_features=shapelet_temp[,list(Len=.N),by=list(Start,End,Class)]
	maxLen=max(shapelet_features$Len)
	minLen=min(shapelet_features$Len)
	meanLen=mean(shapelet_features$Len)
	shapeletLength =shapelet_features$Len
	shapeletNum = nrow(shapelet_features)

	shapelet = matrix(-999,shapeletNum,maxLen)

	shapeletId=rep(c(1:shapeletNum),shapeletLength)

	timeId = unlist(lapply(c(1:shapeletNum),function(x){
	  c(1:(shapeletLength[x]))
	}))
	temp=NULL
	shapelet[cbind(shapeletId,timeId)]=tempfulldata$RealLevel
	return(list("shapelets"=shapelet,"shapelet_length"= shapeletLength))
}


#Set working directory to file directory with data
setwd("E:/Garg Lab/Server output 1/Final Figure Subset")

#Set the desired volume cutoff (cubic microns)
minAreaCutoff<-700

#This function counts the total number of bundles in each file and returns the count
countObjects<-function(fileName){
	#Load the file into a temporary matrix
	fileMatrix<-read.table(fileName, sep="\t", header=TRUE)

	#Return the number of samples in the file
	count<-nrow(fileMatrix)
	return(count)
}

#This function fills a matrix with the corresponding measurements in an excel file
excelToMatrix<-function(fileName, maxCount){
	#Load the file into a temporary matrix
	fileMatrix<-read.table(fileName, sep="\t", header=TRUE)

	#Retrieve the desired measurements
	volumeVector<-fileMatrix$Volume
	boundingBoxWidthVector<-fileMatrix$B.width #Hyphens are replaced with "."
	boundingBoxHeightVector<-fileMatrix$B.height #Hyphens are replaced with "."

	#Fill the remaining vector with NA so that sapply creates a matrix (all returned vectors are of equal length)
	for (a in length(volumeVector):maxCount){
		volumeVector[a+1]<-NA
		boundingBoxWidthVector[a+1]<-NA
		boundingBoxHeightVector[a+1]<-NA
	}

	#Calculate the area and aspect ration of each bounding box
	boundingBoxArea<-boundingBoxWidthVector*boundingBoxHeightVector
	boundingBoxAspectRatio<-boundingBoxHeightVector/boundingBoxWidthVector

	#Concatenate the results into one vector
	resultsVector<-cbind(volumeVector, boundingBoxArea, boundingBoxAspectRatio)

	#Return the desired measurements as one concatenated vector
	return(resultsVector)
}

createBoxplot<-function(fileNameList, dataMatrix, measurement, logAxis, outlierBoolean, yLimits){
	#Extract the sample ID for each file by removing the prefix and extension and set as the column names in the new matrix
	sampleIDvector<-sapply(fileNameList, gsub, pattern="\\.xls$", replacement="")
	sampleIDvector<-sapply(sampleIDvector, gsub, pattern="\\.lif", replacement="")
	colnames(dataMatrix)<-sampleIDvector

	#Create a vector of all sample IDs so that replicates can be pooled together
	#initize variables and vectors
	index<-1
	sampleNameVector<-vector(,0)
	sampleDataList<-list()

	for(a in 1:length(sampleIDvector)){
		#Remove the numeric sample identifier suffix from the name
		sampleID<-gsub(" - Series [0-9]+", "", sampleIDvector[a])
		#On the first iteration, add the sample and count up the index
		if(a == 1){
			sampleNameVector[index]<-sampleID
			sampleDataList<-dataMatrix[,a]
		}

		#On all following iterations, check to see if the same sample is found, and if so, add it to the vector
		else if(sampleID == sampleNameVector[index]){
			sampleDataList<-c(sampleDataList, dataMatrix[,a])
		}

		#If a new sample is found, create a new list and add it to the list of lists
		else{
			#If index is 1 then create a new list of lists
			if(index == 1){
				listOfLists<-list(sampleDataList)
			}
			#Otherwise, add the current list to the list of lists
			else{
				listOfLists[[length(listOfLists)+1]]<-sampleDataList
			}

			#Increase the index counter
			index<-index+1
			sampleNameVector[index]<-sampleID
			sampleDataList<-dataMatrix[,a]

		}
	}
	#Add the last list to the list of lists
	listOfLists[[length(listOfLists)+1]]<-sampleDataList

	#convert the list of lists to a matrix
	sampleDataMatrix<-do.call(cbind, lapply(listOfLists, unlist))
	colnames(sampleDataMatrix)<-sampleNameVector

	#Remove all volume measurements that are below the set cutoff
	sampleDataMatrix<-replace(sampleDataMatrix, sampleDataMatrix < minVolumeCutoff, NA)

	#Create a notched box plot for each sample
	dev.new()
	par(mar = c(15,6,3,3))
	boxplot(sampleDataMatrix, log=logAxis, outline = outlierBoolean, las = 2, names = sampleNameVector, notch = TRUE, ylim = yLimits, ps = 1, cex.lab=1, cex.axis=1, cex.main=1, cex.sub=1, bty="n")
	mtext( measurement, side=2, line = 3, cex = 1)
}

#Get all file names that end with a *.xls file extension
fileNameList<-list.files(pattern = "\\.xls$",  ignore.case=TRUE)

#Count the number of results in each file
fileObjectCounts<-sapply(fileNameList, countObjects, simplify = TRUE)

#Find the largest number of object counts (this value will be used to setup a matrix to store all volume measurements)
maxCount<-max(fileObjectCounts)

#Add the volume measurements to  each corresponding column in the a new matrix
allResultsMatrix<-sapply(fileNameList, excelToMatrix, maxCount, simplify = TRUE, USE.NAMES = FALSE)

#Parse the results matrix into sub matrices containing single measurements
allVolumeMatrix<-allResultsMatrix[1:(maxCount+1),]
allAreaMatrix<-allResultsMatrix[(maxCount+2):(2*(maxCount+1)),]
allAspectRatioMatrix<-allResultsMatrix[(2*(maxCount+1)+1):(3*(maxCount+1)),]

#Remove all mesurements the correspond to below the bounding box minimum area cutoff
for(a in 1:nrow(allVolumeMatrix)){
	for(b in 1:ncol(allVolumeMatrix)){
		area<-allAreaMatrix[a,b]
		if(is.na(area)){
			area<-0
		}
		if (area < minAreaCutoff){
			allAreaMatrix[a,b]<-NA
			allAspectRatioMatrix[a,b]<-NA
		}
	}
}

#Scale the area to microns
allAreaMatrix<-allAreaMatrix*0.0144

createBoxplot(fileNameList, allAspectRatioMatrix, "Aspect Ratio Distribution", "", FALSE, c(1,5))
createBoxplot(fileNameList, allAreaMatrix, expression(paste(plain("Graphene Particle Bounding Box Area (μm") ^ plain(" 2"), plain(")"))), "y", FALSE, c(10, 200))

#c(min(sampleDataMatrix, na.rm = TRUE), max(sampleDataMatrix, na.rm = TRUE))

Aspect Ratio and volume comparator - draft 2 - min area cutoff.r


library(randomForest)
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)
# drop possible all NA columns
finalData <- finalData[, !apply(is.na(finalData), 2, all)]
# keep way from 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 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/rfClassDistribution.png", width = 15, height = 15, units = "cm")
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# split to training and testing datasets
rndsplt <- sample(x = 2, size = nrow(finalData), replace = TRUE, prob = c(0.7,0.3))
trainingData <- finalData[rndsplt == 1, ]
testingData <- finalData[rndsplt == 2, ]
# create search grid
rfGrid <- expand.grid(ntreeArg = (1:5)*500,
                      replaceAge = c(TRUE, FALSE),
                      mtryArg = (round(sqrt(length(trainingData))) + (-2:2)),
                      sampsizeArg  = c(nrow(trainingData), round(nrow(trainingData)*.9), round(nrow(trainingData)*.8), round(nrow(trainingData)*.75)),
                      nodesize = c(1, 3, 5, 7)
                      )
colnames(rfGrid) <- c("ntree", "replace", "mtry", "sampsize", "nodesize")
numModels <- 10; # increase
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(rfGrid) + 3))
colnames(currParams) <- c(colnames(rfGrid), "Accuracy", "AUC", "F1score")
# loop for numModels
for (i in 1:numModels){
  currParams[i,] <- rfGrid[sample(nrow(rfGrid), size = 1),] # sample random combination and train the forest
  # Train Model
  rfModel <- randomForest(x = trainingData[,-ncol(trainingData)], y = trainingData$DE,
                          ntree = currParams[i,'ntree'],
                          replace = currParams[i,'replace'],
                          mtry = currParams[i,'mtry'],
                          sampsize = currParams[i,'sampsize'],
                          nodesize = currParams[i,'nodesize'])
  # Prediction
  pred <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'response')
  predprob <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'prob')
  # Evaluate model
  # confusion Matrix
  # confusionMatrix(data = pred, reference = testingData$DE, positive = 'TRUE')
  # Accuracy
  currParams[i,'Accuracy'] <- Accuracy(y_pred = pred, y_true = testingData[,ncol(testingData)])
  pred_obj = prediction(predprob[,2], testingData[,ncol(testingData)], label.ordering = c("FALSE", "TRUE"))
  # AUC
  currParams[i,'AUC'] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  # F1 score
  currParams[i,'F1score'] <- F1_Score(y_true = testingData$DE, y_pred = pred, positive = 'TRUE')
}
# best model
bestModel <- currParams[which(currParams$Accuracy == max(currParams$Accuracy)),]
bestModel <- bestModel[which(bestModel$F1score == max(bestModel$F1score)),]
bestModel <- bestModel[which(bestModel$AUC == max(bestModel$AUC)),]
# Take best model Parameters
bestParams <- bestModel[1,c(1:5)]
# Stability Analysis permuting FinalData
# Create 10 equally size folds
folds <- cut(seq(1,nrow(finalData)),breaks=10,labels=FALSE)
acc <- list()
# Perform 10 fold cross validation
for(i in 1:10){
  # Randomly shuffle the data
  finalData <- finalData[sample(nrow(finalData)),]
  # Segement data by fold using the which() function
  Indexes <- which(folds==i,arr.ind=TRUE)
  testingData <- finalData[Indexes, ]
  trainingData <- finalData[-Indexes, ]
  pred <- data.frame(matrix(data = NA, nrow = nrow(testingData), ncol = 1))
  # Train Model
  rfModel <- randomForest(x = trainingData[,-ncol(trainingData)], y = trainingData$DE,
                          ntree = bestParams[1,'ntree'],
                          replace = bestParams[1,'replace'],
                          mtry = bestParams[1,'mtry'],
                          sampsize = bestParams[1,'sampsize'],
                          nodesize = bestParams[1,'nodesize'])
  # Predict
  pred <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'response')
  predprob <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'prob')
  # Accuracy
  acc[i] <- Accuracy(y_pred = pred, y_true = testingData[,ncol(testingData)])
}
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("Stability Analysis") +
  theme_bw()
p1
ggsave(filename = "./test/rfStability.png", width = 15, height = 15, units = "cm")


library(neuralnet)
set.seed(42)
data(mtcars)

df <- mtcars[c('mpg', 'hp', 'drat', 'vs')]
names(df) <- c('y', 'x1', 'x2', 'x3')

nn <- neuralnet(y ~ x1 + x2 + x3, data=df, hidden=3, linear.output=TRUE)
plot(nn)
dev.copy(png, 'img.png')
dev.off()


#' PMV_custom
#'
#'  Calculate Predicted Mean Vote (PMV) following ISO 7730 customizing some individual features.
#'
#' @param numeric t Air temperature in Celsius degrees.
#' @param numeric rh Air Relative humidity in %.
#' @param numeric wind Windspeed in meter per second [m/s].
#' @param numeric tr Air temperature in Celsius degrees.
#' @param numeric M Metabolic rate of subject [W/mq].
#' @param numeric clo Clothing insulation level in clo.
#' @param numeric age Age in years.
#' @param numeric mbody Body Mass in kg.
#' @param numeric ht Heigth of subject in meters.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords PMV customized ISO 7730.
#'
#' @export
#'
#'
#'
#'

PMV_custom <- function(t, rh, wind, tr, M, age, mbody,  ht,clo) {
    mtrad=tr;
    iclo=clo;
    .Call('biometeoR_pmv_custom', PACKAGE = 'biometeoR', t, rh, wind, mtrad, met, age, ht, mbody, iclo)
}


##CTE534_Índices=group
##Imagen=raster
##RedEdge=number 4
##Red=number 3
##NDVIre=output raster
##showplots

NDVIre <- raster::overlay(Imagen[[RedEdge]],
                          Imagen[[Red]],
                          fun=function(x,y){(x-y)/(x+y)})
plot(NDVIre)


library(doParallel)

num_cpus <- strtoi(Sys.getenv('SLURM_CPUS_PER_TASK', unset = "1"))
size_array <- 20000

registerDoParallel(num_cpus)

sprintf("Using %i cpus to sum [ %e x %e ] matrix.",num_cpus,size_array,size_array)

results <- foreach(z=0:size_array) %dopar% {
    p_complete= z*100/size_array
    if (p_complete%%1==0){
        print(sprintf("%i%% done...", p_complete))
    }
    sum(rnorm(size_array))
}
sprintf("Sum is '%f'.", Reduce("+",results))


# Partial least squares regression
library(pls)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("utils/accuracy-statistics.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r")

Data.df.orig = LoadTrainingAndCovariates()
Data.df.orig = st_set_geometry(Data.df.orig, NULL)
# Manually rescale
Data.df = Data.df.orig
#Data.df = RescaleBasedOn(Data.df.orig, Data.df.orig, GetAllPixelCovars())
#Data.df = NAToMean(Data.df, GetAllPixelCovars())
Data.df[is.na(Data.df)] = -9999
#Data.df[is.na(Data.df)] = 0
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.df.orig, GetAllPixelCovars())
#Data.val = NAToMean(Data.val, GetAllPixelCovars())
Data.val[is.na(Data.val)] = -9999
#Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

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

FullFormula = paste(paste0("cbind(", paste(Classes, collapse=","), ")"), paste0(GetAllPixelCovars(), collapse="+"), sep="~")

pm = plsr(FullFormula, data=Data.df, scale=TRUE)
pm_pred = predict(pm, Data.val)
pm_pred_n = pm_pred[,,55] # Somehow using predict(comps=) gives the wrong values, but this works
# If we increase the number of components, we get closer to just a single linear regression.
pm_pred_n[pm_pred_n < 0] = 0
pm_pred_n = ScalePredictions(pm_pred_n, FALSE)
AccuracyStatisticsPlots(pm_pred_n[,Classes], Data.val[,Classes]) # RMSE 21.8, MAE 12.9
SCM(pm_pred_n[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 55±0.04 kappa 0.42±0.06
NSE(unlist(as.data.frame(pm_pred_n[,Classes]))/100, unlist(Truth[,Classes]/100)) # 0.47
PlotHex(as.data.frame(pm_pred_n[,Classes]), Truth[,Classes], "PLS regression, 55 components")
PlotBox(as.data.frame(pm_pred_n[,Classes]), Truth[,Classes], main="PLS regression, 55 components", binpredicted=TRUE)
write.csv(pm_pred_n[,Classes], "../data/pixel-based/predictions/plsr-55c.csv", row.names=FALSE)

#AccuracyStatisticsPlots(pm_pred[,,32], Data.df[,dimnames(pm_pred)[[2]]]) # 18 RMSE, now that used to be nice, but can't reproduce on the current version

for (i in 1:pm$ncomp) # Max is best and equal to lm
{
    pm_pred_n = pm_pred[,Classes,i]
    pm_pred_n[pm_pred_n < 0] = 0
    pm_pred_n = ScalePredictions(pm_pred_n, FALSE)
    print(AccuracyStats(pm_pred_n, Data.val[,Classes]))
}
pm = plsr(FullFormula, data=Data.df, center=FALSE) # This is even more terrible

#pm_scaled = ScaleNNPrediction(pm_pred[,,32])
#SCM(pm_scaled, Data.df[,dimnames(pm_pred)[[2]]]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.36±0.07, OA 47±5%, pretty bad
#AccuracyStatisticsPlots(pm_scaled, Data.df[,dimnames(pm_pred)[[2]]]/100) # 19 RMSE when scaled

#head(round(pm_scaled, 2)) # Way too fuzzy

# Can CV figure out that max is the best?
pmcv = plsr(FullFormula, data=Data.df, scale=TRUE, validation="CV")
#selectNcomp(pmcv, method="randomization") # Doesn't work with multiple response
plot(pmcv, plottype="validation") # 55 seems about optimal
plot(pmcv, newdata=Data.val, plottype="validation") # What is optimal in reality: max (67) or 62
plot(pmcv, newdata=Data.val) # 1:1 plots

# Other methods
# pm = plsr(FullFormula, data=Data.df, scale=TRUE, method="widekernelpls") # Indeed eats all memory and dies
pm = plsr(FullFormula, data=Data.df, scale=TRUE, method="simpls")
plot(pm, plottype="validation") # Still max is the best
pm = plsr(FullFormula, data=Data.df, scale=TRUE, method="oscorespls")
plot(pm, plottype="validation") # Still max is the best

# # With CV
# # Wrapper for predict to give matrices instead of arrays
# pred.plsr = function(model, newdata, ...)
# {
#     result = predict(model, newdata=newdata, ncomp=model$ncomp, ...)
#     return(result[,,1])
# }
#
# registerDoParallel(cores=10)
# pm_cv = CrossValidate(FullFormula, Data.df, plsr, pred.plsr)
# pm_cv_scaled = ScaleNNPrediction(pm_cv)
# SCM(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.36±0.07, OA 47±5%, so it's the same as without CV
# AccuracyStatisticsPlots(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100) # 19 RMSE
#
# # What about other methods? widekernelpls does not work (eats all memory and dies)
# pm_cv = CrossValidate(FullFormula, Data.df, plsr, pred.plsr, method="simpls")
# pm_cv_scaled = ScaleNNPrediction(pm_cv)
# SCM(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.35±0.07, OA 47±5%, just slightly worse
# AccuracyStatisticsPlots(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100) # 19 RMSE
#
# pm_cv = CrossValidate(FullFormula, Data.df, plsr, pred.plsr, method="oscorespls")
# pm_cv_scaled = ScaleNNPrediction(pm_cv)
# SCM(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.36±0.07, OA 47±5%, same as default
# AccuracyStatisticsPlots(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100) # 19 RMSE
#
# # PCR
# pm_cv = CrossValidate(FullFormula, Data.df, pcr, pred.plsr)
# pm_cv_scaled = ScaleNNPrediction(pm_cv)
# SCM(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.36±0.07, OA 47±5%, same as default
# AccuracyStatisticsPlots(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100) # 19 RMSE
#
# # What about uncorrelated covars
# FullFormula = paste(paste0("cbind(", paste(GetLargeClassNames(Data.df), collapse=","), ")"), paste0(GetUncorrelatedPixelCovars(), collapse="+"), sep="~")
# pm_cv = CrossValidate(FullFormula, Data.df, plsr, pred.plsr)
# pm_cv_scaled = ScaleNNPrediction(pm_cv)
# SCM(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100, plot=TRUE, totals=TRUE, scale=TRUE) # Kappa 0.31±0.07, OA 43±5%, so it's worse
# AccuracyStatisticsPlots(pm_cv_scaled, Data.df[,colnames(pm_cv_scaled)]/100) # 20 RMSE
# # This makes a lot of sense: PLSR is designed to cope with collinear variables


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

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

riv=st_read('./data/HydroRIVERS_v10_sa_shp')
riv_ce=riv %>% st_filter(CE)
rm(riv)

river_geometry=riv_ce %>% dplyr::select(HYRIV_ID,NEXT_DOWN,CATCH_SKM,UPLAND_SKM,HYBAS_L12) %>% st_transform(32724)
save(river_geometry,file='data/river_geometry.RData')

nodes=riv2nodes(river_geometry)
river_graph=riv2graph(nodes,river_geometry)
save(river_graph,file='data/river_graph.RData')


context("prepare_for_regression")

library(magrittr)
library(mnmacros)
#library(testthat)

rm(list = ls())
set.seed(0)

y1 <- 50 %>% rnorm(mean = 1, sd = 1)
y2 <- y1 %>% length() %>% rep('a', .)
y3 <- y1 %>% as.character()
y4 <- y1 %>% as.integer()
y5 <- y1 %>% length() %>% rep(1, .)

# single column factoring
actual <-
  data.frame(y2, stringsAsFactors = F) %>%
  prepare_for_regression()
expected <- data.frame(y2)
expect_equal(actual, expected)

# multi column factoring
actual <-
  data.frame(y2, y3, stringsAsFactors = F) %>%
  prepare_for_regression()
expected <- data.frame(y2, y3)
expect_equal(actual, expected)

# single column normalization
actual <-
  data.frame(y1) %>%
  prepare_for_regression()
expected <- data.frame(y1)
expected$y1 <- expected$y1 %>% apply_bcskew0() %>% scale() %>% .[,1]
expect_equal(actual, expected, tolerance = 0.001)

# multi column normalization
actual <- data.frame(y1, y4) %>% prepare_for_regression()
expected <- data.frame(y1, y4)
expected$y1 <- expected$y1 %>% apply_bcskew0() %>% scale() %>% .[,1]
expected$y4 <- expected$y4 %>% apply_bcskew0() %>% scale() %>% .[,1]
expect_equal(actual, expected, tolerance = 0.001)

# mixed column preparation
actual <-
  data.frame(y1, y2, y3, y4, stringsAsFactors = F) %>%
  prepare_for_regression()
expected <- data.frame(y1, y2, y3, y4)
expected$y1 <- expected$y1 %>% apply_bcskew0() %>% scale() %>% .[,1]
expected$y4 <- expected$y4 %>% apply_bcskew0() %>% scale() %>% .[,1]
expect_equal(actual, expected, tolerance = 0.001)

# non varying columns get skiped
actual <-
  data.frame(y5) %>%
  prepare_for_regression()
expected <- data.frame(y5)
expect_equal(actual, expected, tolerance = 0.001)

# short frames dont get bcskew0
actual <-
  data.frame(y1, y2) %>%
  .[1:7,]  %>%
  prepare_for_regression()
expected <-
  data.frame(y1, y2) %>%
  .[1:7,]
expected$y1 <- expected$y1 %>% scale() %>% .[,1]
expect_equal(actual, expected, tolerance = 0.001)


# Load data
data = read.table('tmp/data-reqs.ssv', header=T, sep=" ")
nservices = ncol(data) - 1
nrows = nrow(data)

# Sort column headers
data = data[,c(c(1), order(names(data[2:ncol(data)]))+c(1))]
headers = names(data)

# Get X range
xrange = range(data[1])

# Get Y range
ymax = 0
for (i in 1:nservices) {
  curmax = max(data[i + 1])
  if (curmax > ymax) {
    ymax = curmax
  }
}
yrange = c(0,ymax)

# Set up plot
png(paste(headers[1], ".png", sep=""), width=8, height=6, units = 'in', res=150)
colors = rainbow(nservices)

# Add lines
if (nrows < 2) {
  data.mx = as.matrix(data[2:ncol(data)])
  par(las=3, mar=c(5,5,3,1))
  barplot(data.mx, yaxp=c(0,ymax,4), beside=T, col=colors, xlab=paste(data[1,1], "dynos"), ylab="Responses per second", border=T, names.arg=rep("", nservices))
} else {
  plot(xrange, yrange, type="n", xlab="Dynos", ylab="Responses per second")
  for (i in 1:nservices) {
    if (nrows < 4) {
      lines(data[[1]], data[[i + 1]], type="l", lwd=3, lty=1, col=colors[i])
    } else {
      data.spl = smooth.spline(data[[1]], data[[i + 1]], spar=0.3)
      lines(predict(data.spl, seq(xrange[1], xrange[2], by=0.1)), type="l", lwd=3, lty=1, col=colors[i])
    }
  }
}

# Add title and legend
title(headers[1])
legend(xrange[1], yrange[2] * 0.95, headers[2:ncol(data)], cex=0.8, col=colors, bg='transparent', fill=colors, border=colors)


# Summary of t-test
#'
#' @importFrom stats printCoefmat
#'
summary.RCTtoolbox.ttest <- function(object, ...) {
  res <- object$result
  outcome <- unique(res$outcome)
  method <- unique(res$method)
  ctrl <- levels(res$arms)[1]
  cat("Mean Difference Test:", method, "\n")
  cat("Control arms: ", ctrl, "\n")
  for (y in outcome) {
    cat("Outcome: ", y, "\n")
    dt <- res[res$outcome == y, ]
    coef_mat <- as.matrix(dt[, c("mean1", "diff")])
    tvec <- if (method == "Welch t-test") dt$t else rep_len(NA, nrow(dt))
    pvec <- dt$pval
    show_mat <- cbind(coef_mat, tvec, pvec)
    colnames(show_mat) <- c("Average", "Difference", "t-value", "Pr(>|t|)")
    rownames(show_mat) <- dt$arms
    show_mat[rownames(show_mat) == ctrl, 2:4] <- NA
    printCoefmat(show_mat, digits = 4, na.print = "", signif.stars = FALSE)
    cat("\n")
  }
}

# Summary of power analysis
#'
#' @importFrom stats printCoefmat
#'
summary.RCTtoolbox.power.analysis <- function(object, ...) {
  res <- object$result
  ctrl <- res[res$arms == levels(res$arms)[1], ]
  treat <- res[res$arms != levels(res$arms)[1], ]
  cat("Post Power Analysis for Two-Sided T-Test\n")
  cat("Control Arm:", levels(res$arms)[1], "(N =", ctrl$n1, ")\n")
  alpha <- unique(treat$alpha)
  cat("Significant Size:", alpha, "\n")
  power <- unique(treat$power)
  cat("Power:", power, "\n")
  sd <- unique(treat$sd)
  cat("Std.dev:", sd)
  cat(" (Use transformation standardized effect to unstandardized one)\n")
  show <- as.matrix(treat[, c("n1", "d", "diff_mean")])
  colnames(show) <- c("Num.Obs.", "Standardized", "Unstandardized")
  rownames(show) <- treat$arms
  printCoefmat(show, cs.ind = 0)
  cat("\n")
}

# Summary of linear model
#'
summary.RCTtoolbox.lm <- function(object, ...) {
  lapply(object$result, summary, ...)
}


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Bubble chart
#==============================================================================
# Title          : Bubble chart.r
# Description    : Bubble chart plotting.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20180407
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : based on
# http://flowingdata.com/2010/11/23/how-to-make-bubble-charts/
#
# R version      : 3.4
#==============================================================================

#==============================================================================
# PACKAGE INSTALATION
#==============================================================================
install.packages("ggplot2")

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)

#------------------------------------------------------------------------------
# Data generation/preparation and pattern
#------------------------------------------------------------------------------
mydata2 <- read.table("..//Data//Tomatos.dat",  sep="\t", header=TRUE)
mydata3 <- data.frame(mydata2, Type =
c('OntarioRed Salsa','Ohio Red Breakfast Sandwich',
'Chicken & Pepper Cobb Salad','Tomato Jelly',
'Green Tomato Pie','Green Tomato Blueberry Jam'))

dbconn01 <- textConnection(
"Row PowerSource ProductSegment Price Model ManufacturingLocation Quantity
1 High SegmentA Low ModA LocationA 5000
2 Low SegmentB Low ModB LocationB 25000
3 High SegmentC Low ModC LocationC 15000
4 Low SegmentD High ModD LocationD 30000
5 High SegmentE High ModE LocationA 2500
6 Low SegmentA Low ModF LocationB 110000
7 High SegmentB Low ModG LocationC 20000
8 Low SegmentC Low ModH LocationD 3500
9 High SegmentD Low ModI LocationA 65500
10 Low SegmentE Low ModJ LocationB 145000
11 High SegmentA Low ModK LocationC 15000
12 Low SegmentB Low ModL LocationD 5000
13 High SegmentC Low ModM LocationA 26000
14 Low SegmentD Low ModN LocationB 14000
15 High SegmentE Mid ModO LocationC 75000
16 Low SegmentA High ModP LocationD 33000
17 High SegmentB Low ModQ LocationA 14000
18 Low SegmentC Mid ModR LocationB 33000
19 High SegmentD High ModS LocationC 95000
20 Low SegmentE Low ModT LocationD 4000
 ")
mydata <- read.table(dbconn01, header= TRUE)
close(zz) ; rm(mydata2) ; mydata

#------------------------------------------------------------------------------
# ggplot - bubble chart
#------------------------------------------------------------------------------
ggplot(mydata, aes(x = ManufacturingLocation, y = PowerSource, label = Model)) +
    geom_point(aes(size = Quantity, colour = Price)) +
    geom_text(hjust = 1, size = 2) +
    scale_size(range = c(1,15)) +
    theme_bw()

set.seed(666666)
x=sample(seq(1,50),50,T)
y=sample(seq(1,50),50,T)
value = rnorm(50,10,20)
plot_dat=data.frame(x=x,y=y,value=value)
ggplot(data=plot_dat, aes(x=x, y=y,colour=factor(sign(value)), size=abs(value))) +
      geom_point() +
      scale_color_manual(values=c("orange","blue"),guide=FALSE)+
      scale_size_continuous(breaks=c(10,10,20,20,30,30,40,40,50,50),
	  labels=c(-50,-40,-30,-20,-10,10,20,30,40,50),range = c(1,5))+
      guides(size = guide_legend(override.aes = list(colour =
	  list("orange","orange","orange","orange","orange","blue","blue","blue","blue","blue"),
           size=c(4.92,4.14,3.50,2.56,1.78,1.78,2.56,3.50,4.14,4.92))))
# bubbles ---------------------------------------------------------------------
data <- read.csv(
"https://raw.githubusercontent.com/plotly/datasets/master/school_earnings.csv")

p <- plot_ly(data, x = ~Women, y = ~Men, text = ~School, type = 'scatter',
	mode = 'markers', marker = list(size = ~gap, opacity = 0.5)) %>%
  layout(title = 'Gender Gap in Earnings per University',
         xaxis = list(showgrid = FALSE),
         yaxis = list(showgrid = FALSE))

# Create a shareable link to your chart
# Set up API credentials: https://plot.ly/r/getting-started
chart_link = api_create(p, filename="bubble-simple")
chart_link

# EOF