## prog ini 1
# read data from ASCII file and do some graphical initialisations
# you have to do this after every new SMS run
#################################################################
rm(stom)
stom<-Read.stomach.data(read.init.function=T)

#stom<-Read.stomach.data()

a<-aggregate(list(Pred.avail=stom$Prey.avail.part),
              list(Area=stom$SMS.area,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=''))

stomAll<-stom  # all stomach input irrespectiv of actually use
stom<-subset(stom,stom.used.all==1)  # used stomachs specified for input

write.csv(stom, file = file.path(data.path,'ASCII_stom_data.csv'),row.names = FALSE)

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
#################################################################

names(stom)

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

stom$ratio<-stom$Predator.size/stom$Prey.size
a<-subset(stom,Prey.no!=0)
a<-a[order(a$ratio),]
head(a)
###

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

if (F) { # test of output stom proportion=1 (or a serious errror some where)
  a<-aggregate(list(expec=stom$stomcon.hat),list(Year=stom$Year,Quarter=stom$Quarter,Predator.no=stom$Predator.no,Predator=stom$Predator,Predator.size=stom$Predator.length),sum)
  a$expec<-round(a$expec,2)
  a<-a[order(paste(a$Year,a$Quarter,a$Predator.no,a$Predator,a$Predator.size)),]
  a
}
###############################################################
#Number of stomachs;
ns<-unique(subset(stom,select=c(Predator,Predator.no,Predator.length,Predator.length.class,Year,Quarter, N.samples)))

#ns<-droplevels(subset(ns,Predator %in% c("W. mackerel","N. mackerel")))

a<-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)

##############################################################
## prog rel 1
# Observed relativ stomach contents by predator, year and quarter
 unique(stom$Predator)

cleanup()

dev<-"print"
#dev<-"screen"
dev<-"png"
nox<-2
noy<-3

i<-0
b<- tapply(stom$stomcon,list(stom$Prey.no),sum)
all.prey.col<-sort(as.numeric(dimnames(b)[[1]]),decreasing = TRUE)
all.names<-rep('aaa',length(all.prey.col))
for (s in (1:length(all.prey.col))) all.names[s]<-sp.other.names[all.prey.col[s]+1]
#stom<-droplevels(subset(stom,Predator=='H. porpoise'))
#stom<-droplevels(subset(stom,Predator %in% c('G. gurnards','R. radiata','Hake','W.horse mac','N.horse mac')))
#stom<-droplevels(subset(stom,Predator %in% c('W.horse mac','N.horse mac')))

#stom<-droplevels(subset(stom,Predator %in% c("W. mackerel","N. mackerel")))

stom<-subset(stom,stom.used.like==1)  # just used stomachs

a<-by(stom,list(stom$Quarter,stom$Year,stom$Predator.no),function(x) {
   if (dim(x)[[1]]>0) {
    b<- tapply(x$stomcon,list(x$Prey.no,x$Predator.length),sum)
    b[is.na(b)]<-0
    prey.names<-as.numeric(dimnames(b)[[1]])
    length.names<-dimnames(b)[[2]]
    #if (x[1,]$Quarter=="Q1") {
    if ((i %% (nox*noy-1))==0) {
      newplot(dev,nox,noy,Portrait=F,filename=paste(x[1,]$Year,x[1,]$Quarter,x[1,]$Predator,sep='-'));
      par(mar=c(3,5,3,2))
      plot.new(); legend(x=0,y=1,all.names,fill=all.prey.col,cex=1.0)
    }
    i<<-i+1
    barplot(b,names=length.names,col=prey.names)
    title(main=paste(x[1,]$Year,x[1,]$Quarter," Pred:",x[1,]$Predator))
   }
})
if (dev=='png') cleanup()

by(stom,list(stom$Predator),function(x) {
  ftable(round(tapply(x$stomcon,list(x$Year,x$Quarter,x$Predator.length,x$Prey),sum)*1000,0))
})

by(stom,list(stom$Predator,stom$Quarter),function(x) {
  ftable(round(tapply(x$stomcon,list(x$Year,x$Predator.length,x$Prey),sum)*1000,0))
})

##############################################################
## prog rel 3
# Observed length distibution of preys by predator, size, quarter and year

dev<-"print"
dev<-"screen"
nox<-2
noy<-3

# select subset
stom2<-subset(stom,Year==1978 & Quarter=="Q1" & Prey.no!=0)

cleanup()
i<-0

by(stom2,list(stom2$Year,stom2$Quarter,stom2$Predator.no),function(x) {

     b<- tapply(x$stomcon,list(x$Predator.length,x$Prey.length.mean,x$Prey),sum)

     b[is.na(b)]<-0
     for (l in (1:dim(b)[1])) {
       if ((i %% (nox*noy))==0) {
         newplot(dev,nox,noy,Portrait=TRUE);
         par(mar=c(3,5,3,2))
       }
       i<<-i+1
       bb<-b[l,,]
       print(b)
       barplot(bb,beside = TRUE,col=2)
       title(main=paste(x[1,]$Year,x[1,]$Quarter,x[1,]$Predator,dimnames(b)[[1]][l]))
     }
})

dev<-"print"
dev<-"screen"
nox<-2
noy<-3

tapply(stom$Prey.length.mean,list(stom$Predator,stom$Prey),min)

# select subset, ONE prey only
stom2<-subset(stom,Quarter=="Q3" & Prey=='Sandeel'    & Predator=='Whiting')
stom2<-subset(stom,Quarter=="Q3" & Prey=='Herring')

    b<- tapply(stom2$Prey.length.mean,list(stom2$Predator,stom2$Prey),sum)
cleanup()
i<-0

by(stom2,list(stom2$Year,stom2$Quarter,stom2$Predator.no),function(x) {

    # b<- tapply(x$stomcon/x$Prey.weight,list(x$Predator.length,x$Prey.length.mean),sum)
     b<- tapply(x$stomcon,list(x$Predator.length,x$Prey.length.mean),sum)

     b[is.na(b)]<-0
     for (l in (1:dim(b)[1])) {
       if ((i %% (nox*noy))==0) {
         newplot(dev,nox,noy,Portrait=TRUE);
         par(mar=c(3,5,3,2))
       }
       i<<-i+1
       bb<-b[l,]
       print(b)
       barplot(bb,beside = TRUE,col=2)
       title(main=paste(x[1,]$Year,x[1,]$Quarter,x[1,]$Predator,dimnames(b)[[1]][l]))
     }
})

##################################################################################
## prog rel 4
# Obsereved and predicted relativ stomach content by predator quarter and year

cleanup()

dev<-"print"
dev<-"screen"
#dev<-"wmf"
nox<-3
noy<-3

i<-0
b<- tapply(stom$stomcon,list(stom$Prey.no),sum)
all.prey.col<-sort(as.numeric(dimnames(b)[[1]]),decreasing = TRUE)
all.names<-rep('aaa',length(all.prey.col))
for (s in (1:length(all.prey.col))) all.names[s]<-sp.other.names[all.prey.col[s]+1]

by(stom,list(stom$Quarter,stom$Year,stom$Predator.no),function(x) {
    b<- tapply(x$stomcon,list(x$Prey.no,x$Predator.length),sum)
    b[is.na(b)]<-0

    c<- tapply(x$stomcon.hat,list(x$Prey.no,x$Predator.length),sum)
    c[is.na(c)]<-0

    b<-rbind(b,c)
    prey.no<-as.numeric(dimnames(b)[[1]])
    prey.names<-rep('aaa',length(prey.no))
    for (s in (1:length(prey.names))) prey.names[s]<-sp.other.names[prey.no[s]+1]
    length.names<-dimnames(b)[[2]]
    #if (x[1,]$Quarter=="Q1") {
    if ((i %% (nox*noy-1))==0) {
      newplot(dev,nox,noy,Portrait=F,filename=paste('stom',i));
       par(mar=c(3,5,3,2))
      if (dev=="wmf" ) par(mar=c(2,4,2,2))

     # text(x=0.0,y=0.07,"lower: observed",pos=4)
      plot.new();
      title(main="upper: expected\nlower: observed")
      legend("center",all.names,fill=all.prey.col,cex=1.2)

    }
    i<<-i+1
    barplot(b,names=length.names,col=prey.no)
    title(main=paste(x[1,]$Year,x[1,]$Quarter," Pred:",x[1,]$Predator))
    #title(main=paste(x[1,]$Year,x[1,]$Quarter))

    abline(h=1,lwd=2)
})

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

# Histogram of observations with and without prey size
stom2<-subset(stom, Prey!='Other' & Prey.length.mean >0 & stomcon>1E-5)
cleanup()
nox<-3; noy<-2;
i<-0
minStom<-0.2

by(stom2,list(stom2$Predator.no),function(x) {
       xx<-x
       x$stomcon[x$stomcon>minStom]<-minStom
       xx<-with(xx, aggregate(stomcon,list(Predator=Predator,Prey=Prey,Quarter=Quarter,Year=Year,Length=Predator.length),sum))
       xx$x[xx$x>minStom]<-minStom
      print(xx)
      if ((i %% (nox*noy))==0) {
         newplot(dev,nox,noy,Portrait=TRUE);
         par(mar=c(3,5,3,2))
       }
       i<<-i+1
       hist(x$stomcon,freq=F,breaks=50,main=paste(x[1,]$Predator,dim(x)[1],round(sum(x$stomcon))))
       hist(xx$x,freq=F,breaks=50,main=paste(xx[1,]$Predator,dim(xx)[1],'cond',round(sum(xx$x))))
})

##############################################################
## prog size 1
#size at length by species

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

by(stom,list(stom$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$Predator.length.mean,x$Predator.size,xlab='length',ylab='size')
   title(main=paste('pred:',x[1,]$Predator) )
   i<<-i+1
})

by(stom,list(stom$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   x<-subset(x,Prey.size>0)
   if (dim(x)[1]>0) {
     plot(x$Prey.length.mean,x$Prey.size,xlab='length',ylab='size')
     title(main=paste('prey:',x[1,]$Prey) )
     i<<-i+1
   }
})

##############################################################
#length distribution in the sea
## prog length 1

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

a<-subset(stom,Prey.no !=0 & L.N.bar>0,select=c("Year","Quarter","Quarter.no","Prey.no","Prey","Prey.length.class","Prey.length.mean","L.N.bar"))
a<-unique(a)
a<-subset(a,Prey=='Cod')
by(a,list(a$Quarter,a$Year,a$Prey.no),function(x) {
    if (x[1,]$Quarter=="Q1") {
      newplot(dev,nox,noy);
    }
    plot(x$Prey.length.mean,x$L.N.bar,col=x$Quarter.no)
    title(main=paste(x[1,]$Year,x[1,]$Quarter," Prey:",x[1,]$Prey))
})

##############################################################
#length distribution in the sea
## prog length 2

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

a<-subset(stom,Prey.no !=0,select=c("Year","Quarter","Quarter.no","Prey.no","Prey","Prey.length.class","Prey.length.mean","L.N.bar"))
a<-unique(a)
by(a,list(a$Year,a$Prey.no),function(x) {
    if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    xmin<-min(x$Prey.length.mean)
    xmax<-max(x$Prey.length.mean)
    ymin<-min(x$L.N.bar)
    ymax<-max(x$L.N.bar)
    s<-order(x$Quarter.no,x$Prey.length.class)
    x<-x[s,]
    plot(x$Prey.length.mean[x$Quarter.no==1],x$L.N.bar[x$Quarter.no==1],col=x$Quarter.no,type='b',
          xlim=c(xmin,xmax),ylim=c(ymin,ymax),xlab='length',ylab='Nbar')
    title(main=paste(x[1,]$Year," Prey:",x[1,]$Prey))
    for (q in seq(2,4)) {
      lines(x$Prey.length.mean[x$Quarter.no==q],x$L.N.bar[x$Quarter.no==q],col=q)
    }
    i<<-i+1
})

##############################################################
#length distribution in the sea
## prog length 3

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

a<-subset(stom,Prey.no !=0 & Prey.length.mean>0, select=c("Year","Quarter","Quarter.no","Prey.no","Prey","Prey.length.class","Prey.length.mean","Prey.weight","L.N.bar"))
a<-unique(a)
by(a,list(a$Prey.no),function(x) {
    newplot(dev,nox,noy)
    xmin<-min(x$Prey.length.mean)
    xmax<-max(x$Prey.length.mean)
    ymin<-min(x$L.N.bar*x$Prey.weight)
    ymax<-max(x$L.N.bar*x$Prey.weight)
    s<-order(x$Quarter.no,x$Prey.length.class,x$Prey.length.mean)
    x<-x[s,]
    d<-as.data.frame(x)
    print(xyplot(L.N.bar~Prey.length.mean|Prey+as.factor(Year),groups=Quarter,type='b',data=d,ylab='Nbar'),
    layout = c(2, 2))
})

 ##############################################################
#length distribution in the sea
## prog length 3

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

a<-subset(stom,Prey.no !=0 & Prey.length.mean>0, select=c("Year","Quarter","Quarter.no","Prey.no","Prey","Prey.length.class","Prey.length.mean","Prey.weight","L.N.bar"))
a<-unique(a)
by(a,list(a$Prey.no),function(x) {
    newplot(dev,nox,noy)
    xmin<-min(x$Prey.length.mean)
    xmax<-max(x$Prey.length.mean)
    ymin<-min(x$L.N.bar*x$Prey.weight)
    ymax<-max(x$L.N.bar*x$Prey.weight)
    s<-order(x$Quarter.no,x$Prey.length.class,x$Prey.length.mean)
    x<-x[s,]
    d<-as.data.frame(x)
    print(xyplot(L.N.bar*Prey.weight~Prey.length.mean|Prey+as.factor(Year),groups=Quarter,type='b',data=d,ylab='Nbar*mean weight'),
    layout = c(2, 2))
})

##############################################################
#length distribution in the sea
## prog length 4

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

a<-subset(stom,Prey.no !=0 & Prey.length.mean>0, select=c("Year","Quarter","Quarter.no","Prey.no","Prey","Prey.length.class","Prey.length.mean","Prey.weight","L.N.bar"))
a<-unique(a)

 barchart(stom~as.factor(trunc(PredPrey*2)/2)|Predator, data=a,
    xlab='log(predator weight/prey weight)',ylab='proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.8, lines=2),
    layout = c(1, 3) ,col='grey')

 ##############################################################
#Dirichlet
a<-subset(stom,stom.used.like==1,select=c(Predator,	Quarter,	Year,	Predator.length.class,	Prey,	Quarter.no,	SMS.area,	Predator.no,	Diri.p,	Diri.sum.p,	Diri.like	,Prey.no,	Prey.length.class, N.haul))
a<-unique(a)

a<-a[order(a$Diri.like),]
head(a,20)
tail(a,20)
##

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,group=Predator,
      auto.key = list(space = "right", points = T, lines = TRUE),data=a)

xyplot(Diri.like~N.samples,group=Predator,
      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)

a<-subset(stom,Quarter.no>0 )

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)

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

###
library(MCMCpack)
rdirichlet<-function(n, alpha)  # stolen from library MCMC-pack
{
    l <- length(alpha)
    x <- matrix(rgamma(l * n, alpha), ncol = l, byrow = TRUE)
    sm <- x %*% rep(1, l)
    return(x/as.vector(sm))
}
apply(rdirichlet(20, c(1,1,1) ),2,mean)
apply(rdirichlet(20, c(10,10,10) ),2,mean)
apply(rdirichlet(20, c(1,1,1) ),2,sd)
apply(rdirichlet(20, c(10,10,10) ),2,sd)

s<-subset(stom,Quarter.no>0 & Diri.sum.p>0 & Predator=='Cod' & Year==1981)
a<-tapply(s$stomcon.hat,list(s$Year,s$Quarter.no,s$Predator.no,s$Predator.length.class,s$Prey.no,s$Prey.length.class),sum,na.rm=T)
a.in<-tapply(s$stom.input,list(s$Year,s$Quarter.no,s$Predator.no,s$Predator.length.class,s$Prey.no,s$Prey.length.class),sum,na.rm=T)
avail<-tapply(s$stom.used.avail,list(s$Year,s$Quarter.no,s$Predator.no,s$Predator.length.class,s$Prey.no,s$Prey.length.class),sum,na.rm=T)

ss<-unique(droplevels(subset(s,select=c(Diri.sum.p,Year,Quarter.no,Predator.no,Predator,Predator.length.class))))
xyplot(Diri.sum.p~Predator.length.class|Predator, ylab="p sum",
      auto.key = list(space = "right", points = T, lines = TRUE),data=ss)

p_sum<-tapply(ss$Diri.sum.p,list(ss$Year,ss$Quarter.no,ss$Predator.no,ss$Predator.length.class),mean,na.rm=T)
#ftable(round(p_sum,1))

nrep<-200
dd<-dimnames(a)
sumStom<-SMS.dat@sum.stom.like
min.stom.cont<-SMS.dat@min.stom.cont
ddd<-NULL
for (y in dd[[1]]) {for (q in dd[[2]]) {
    cat('y:',y,' q:',q,'\n')
    for (pred in dd[[3]]) {
      for (predl in dd[[4]]) {
      obs<-t(a[y,q,pred,predl,,])
      obs<-obs[!is.na(obs)]
      obs<-obs[obs>0]
      if (length(obs)>1)
         bb<-obs*p_sum[y,q,pred,predl]
         dirbb<-rdirichlet(nrep,bb)
         for (i in (1:dim(dirbb)[2])) {
            d<-density(dirbb[,i])
            ddd<-rbind(ddd,data.frame(no=i,year=y,q=q,pred=pred,predl=predl,obs=obs[i],x=d$x,y=d$y))
          }
      }
}}}

ddd$labs<-paste(ddd$no," mean=",round(ddd$obs,4),sep='')
ddd$labs2<-paste(ddd$year,ddd$q,ddd$pred,ddd$predl,sep=',')

b<-droplevels(subset(ddd, pred=='17' &predl=='17' & year=='1981' & q=='1'))

xyplot(y~x| labs, ylab="density",data=b,type='l',scales=list(y=list(relation="free")))

b<-droplevels(subset(ddd, pred=='17' & year=='1981' & q=='1'))
xyplot(y~x|labs2, groups=no,ylab="density",data=b,type='l',scales=list(y=list(relation="free")))

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

# QQplot of Residuals by Predator and prey
## prog qq 1

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

by(stom,list(stom$Prey,stom$Predator),function(x) {
if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
  qqnorm(x$Residual,main=' ')
  qqline(x$Residual)
  title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
  i<<-i+1
})

##############################################################
#SPECIAL CASE COD  observed and predicted stomach contents by Predator and prey
# prog stom 1 cod

cleanup()
nox<-1; noy<-2;
newplot(dev,nox,noy);
i<-0
stom2<-subset(stom,Prey=='Cod')
 head(stom2)
by(stom2,list(stom2$Prey,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-log(x$stomcon)
   bb<-log(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),pch=x$Predator.length.class,
   col=x$Predator.no)
   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
})

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

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

by(stom,list(stom$Prey,stom$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
})

##############################################################
#log observed and predicted stomach contents by Predator and prey
## prog stom 2

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

by(stom,list(stom$Prey,stom$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-log(x$stomcon)
   bb<-log(x$stomcon.hat)
   max.val<-max(aa,bb)
   min.val<-min(aa,bb)
   plot(bb,aa,xlab='log Expected stomach content',ylab='log 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
})

##############################################################
#observed and predicted stomach contents by  prey
## prog stom 3

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

by(stom,list(stom$Prey),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))
   r2<-''
   if (var(bb)>0) {
       cc<-lm(aa~bb)
       abline(cc, lty=3)
       dd<-summary(cc)
       r2<-paste(" r^2=",round(dd[["r.squared"]],2),sep='')
   }
   title(main=paste("Prey:",x[1,]$Prey,r2,sep=""))
   i<<-i+1
})

##############################################################
#PAPER version. observed and predicted stomach contents by  prey
## prog stom 3

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

by(stom,list(stom$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
  # x<-subset(x,stomcon<0.2 &stomcon.hat<0.2)
  x<-subset(x,stomcon>0.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),cex=.8)
   r2<-''
   if (var(bb)>0) {
       #cc<-lm(aa~bb)
       cc<-lm(aa~bb,weights=(sqrt(x$N.samples)))

       abline(cc, lty=3)
       dd<-summary(cc)
      # r2<-round(dd[["r.squared"]],2)
        r2<-formatC(dd[["r.squared"]],digits = 2, format = "f")
       sp<- x[1,]$Prey
       #r2<-paste(" r^2=",r2,sep='')
          }

 title(main=paste("        ",sp),adj=0)
 title(bquote(r^2 == .(r2)),adj=1)

  #text(x=0,y=max.val*0.9,labels=bquote(r^2 == .(r2)),pos=4,adj=1,cex=1.5)
   i<<-i+1
})

 #theta <- 1.23 ; title(bquote(hat(theta) == .(theta)))
 # substitute(rho == . , list( . = r2))

#############################################################
# log observed and predicted stomach contents by  prey
## prog stom 4

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

by(stom,list(stom$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
     x<-subset(x,stomcon>0.0 )

   aa<-log(x$stomcon)
   bb<-log(x$stomcon.hat)
   max.val<-max(aa,bb)
   min.val<-min(aa,bb)
   plot(bb,aa,xlab='log Expected stomach content',ylab='log observed ',
       ylim=c(min.val,max.val),xlim=c(min.val,max.val),col=1)
   r2<-''
   if (var(bb)>0) {
       #cc<-lm(aa~bb,weights=1/x$Stom.var)
       cc<-lm(aa~bb)
       abline(cc, lty=3)
       dd<-summary(cc)
       r2<-paste(" r^2=",formatC(dd[["r.squared"]],2,format='f'),sep='')
   }
   title(main=paste("Prey:",x[1,]$Prey,r2,sep=""))
   i<<-i+1
})

##############################################################
# PAPER Residuals by Predator, and expected stom content
## prog resid 1

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

stom2<-subset(stom,Predator=='Cod' & Prey=="Sandeel")
#stom2<-subset(stom,Predator=='Cod' )

by(stom2,list(stom2$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$stomcon.hat,x$Residual,xlab='Expected relative stomach content',ylab='Residual')
   abline(h=0, lty=3)
#   title(main=paste(" Prey:",x[1,]$Prey,sep=""))
#   title(main=paste("Prey:",x[1,]$Prey))

   #abline(lm(x$Residual~x$stomcon.hat),lty=2)
   #if (length(x$Prey)>5 )  lines(smooth.spline(x$stomcon.hat,x$Residual),lty=1)
   i<<-i+1
})

##############################################################
#Residuals by Predator, and expected stom content
## prog resid 1

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

by(stom,list(stom$Prey,stom$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$stomcon.hat,x$Residual,xlab='Expected relative stomach content',ylab='residuals ')
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
#   title(main=paste("Prey:",x[1,]$Prey))

   #abline(lm(x$Residual~x$stomcon.hat),lty=2)
   #if (length(x$Prey)>5 )  lines(smooth.spline(x$stomcon.hat,x$Residual),lty=1)
   i<<-i+1
})

##############################################################
#Residuals by Predator and prey, and prey/pred size
## prog resid 2

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size/x$Prey.size),x$Residual,xlab='log(Pred size/Prey size)',ylab='residuals ')
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   if (x$Prey.no !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Predator.size/x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}}
)}

##############################################################
#Residuals and prey, and prey size. Label=quarter
## prog resid 3

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {

by(stom2,list(stom2$Prey.no),function(x) {
if (x$Prey.no[1] != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals', pch=x$Quarter.no,col=x$Quarter.no)
   abline(h=0, lty=3)
   title(main=paste("Prey:",x[1,]$Prey,sep=""))
   #if (x$Prey.no[1] !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}}
)}

##############################################################
#Residuals and prey, and prey size. Label=year
## prog resid 4

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {

by(stom2,list(stom2$Prey.no),function(x) {
if (x$Prey.no[1] != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals', pch=x$Year-1977,col=x$Year-1977)
   abline(h=0, lty=3)
   title(main=paste("Prey:",x[1,]$Prey,sep=""))
   if (x$Prey.no[1] !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}}
)}

##############################################################
#Residuals and prey, and prey size. Label=predator
## prog resid 5

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {

by(stom2,list(stom2$Prey.no),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals', pch=x$Predator.no,col=x$Predator.no)
   abline(h=0, lty=3)
   title(main=paste("Prey:",x[1,]$Prey,sep=""))
   if (x$Prey.no !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}})}

##############################################################
#Residuals and prey, and prey size and quarter
## prog resid 6

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Quarter,stom2$Prey.no),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals ', pch=x$Predator.no,col=x$Predator.no)
   abline(h=0, lty=3)
   title(main=paste(x[1,]$Quarter," Prey:",x[1,]$Prey,sep=""))
   if (x$Prey.no !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}})}

##############################################################
#Residuals and prey, and prey size and quarter
## prog resid 6b

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Quarter,stom2$Prey.no),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$Prey.length.class,x$Residual,xlab='prey length class',ylab='residuals ', pch=x$Predator.no,col=x$Predator.no)
   abline(h=0, lty=3)
   title(main=paste(x[1,]$Quarter," Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
}})}

##############################################################
#Residuals by Predator and prey, and prey size
## prog resid 7

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Predator,stom2$Prey.no),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals ')
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   if (x$Prey.no !=0 & length(x$Prey)>5 )  lines(smooth.spline(log(x$Prey.size),x$Residual),lty=1)
   i<<-i+1
}})}

##############################################################
#Residuals by Predator and prey, and prey size and quarter
## prog resid 8

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Quarter,stom2$Prey.no,stom2$Predator),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals ')
   abline(h=0, lty=3)
   title(main=paste(x[1,]$Quarter," Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
}})}

##############################################################
#Residuals by Prey and predator, and prey size and quarter
## prog resid 9

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

stom2<-subset(stom,Size.model>0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Quarter,stom2$Predator,stom2$Prey.no),function(x) {
if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Prey.size),x$Residual,xlab='log(Prey size)',ylab='residuals ')
   abline(h=0, lty=3)
   title(main=paste(x[1,]$Quarter,", Prey:",x[1,]$Prey," Pred:",x[1,]$Predator,sep=""))
   i<<-i+1
}})}

##############################################################
# Box-plot of residuals by predator, prey and quarter
# prog box 1

nox<-2; noy<-2;
cleanup()
newplot(dev,nox,noy);
i<-0
res.ylim<-c(-0.1,0.1)     # Dirichlet
#res.ylim<-c(-5,5)  # log normal

my.pred<-c("Cod","Whiting","Saithe","Haddock","W Mackerel","NS Mackerel")
my.pred<-c("Cod")

#my.pred<-c("Cod")
stom3<-subset(stom,Predator %in% my.pred,drop=TRUE)
#if (length(my.pred)==1) a<-glm(Residual~-1+Quarter:Prey,data=stom3,weight=stomcon.hat)
if (length(my.pred)==1) a<-glm(Residual~-1+Quarter:Prey,data=stom3,weight=N.haul*stomcon.hat)
if (length(my.pred)>1) a<-glm(Residual~-1+Quarter:Predator:Prey,data=stom3,weight=stomcon.hat)
summary(a)

by(stom3,list(stom3$Predator,stom3$Prey),function(x) {
#if (x$Prey.no != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    boxplot(Residual~Quarter,data=x,ylim=res.ylim)

   abline(h=0,col=3)
   title(main=paste(x[1,]$Predator,"eating",x[1,]$Prey,sep=" "))
   i<<-i+1
#}
})

##############################################################
# Box-plot of residuals by predator and quarter
# prog box 2

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

# note only other food selected
stom3<-subset(stom,Prey=="Other" & stom$Predator %in% my.pred,drop=TRUE)

by(stom3,list(stom3$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   boxplot(Residual~Quarter,data=x,ylim=c(-1,1))
   abline(h=0,col=3)

   title(main=paste(x[1,]$Predator,sep=""))
   i<<-i+1
})

##############################################################
# Box-plot of residuals by prey and quarter
# prog box 2

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

stom3<-subset(stom, stom$Predator %in% my.pred,drop=TRUE)

by(stom3,list(stom3$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   boxplot(Residual~Quarter,data=x,ylim=c(-0.1,0.1))
   abline(h=0,col=3)

   title(main=paste(x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# Box-plot of residuals by prey and year and quarter
# prog box 3

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

stom3<-subset(stom, stom$Predator %in% my.pred,drop=TRUE)

by(stom3,list(stom3$year,stom3$Prey),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   boxplot(Residual~Quarter,data=x,ylim=c(-1,1))
   abline(h=0,col=3)

   title(main=paste(x[1,]$year,x[1,]$Prey,sep=" "))
   i<<-i+1
})

##############################################################
#Frequency of observation by predator-prey size ratio
## prog size 1

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

stom2<-subset(stom,Size.model==1)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
if (x$Prey.no[1] != 0) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   hist(log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(pred-size / prey-size) ')
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
}}
)}

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

stom2<-subset(stom,Size.model>0 & stom$Prey.no != 0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
by(stom2,list(stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   hist(log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(pred-size / prey-size) ')
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,sep=""))
   i<<-i+1
}
)}

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

stom3<-subset(stom,Size.model>0 & Prey.no>0 & N.haul>=10 & Predator !="NS Mackerel" & Predator !="W Mackerel" )
#stom3<-subset(stom,Size.model>0 & Prey.no>0 & N.haul>10  )
#stom3<-subset(stom3, !((Predator=='Cod' & Predator.length.mean<400)| (Predator=='Whiting' & Predator.length.mean<200)  | (Predator=='Saithe' & Predator.length.mean<400)))

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

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

 barchart(stom~as.factor(trunc(PredPrey*2)/2)|Predator, data=a,
    xlab='log(predator weight/prey weight)',ylab='proportion',
    strip = strip.custom( bg='white'),par.strip.text=list(cex=0.8, lines=2),
    layout = c(1, 3) ,col='grey')

####################################
# observation by predator-prey size ratio
## prog size 1b

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

stom3<-subset(stom,  (Size.model==1 | Size.model==11) &  Prey.no>0 & !(
                     (Predator=='Cod' & Predator.length.mean<400) |
                     (Predator=='Whiting' & Predator.length.mean<200)  |
                     (Predator=='Saithe' & Predator.length.mean<400)))

stom3<-subset(stom,  (Size.model==1 | Size.model==11) &  Prey.no>0 & Predator %in% c('H. porpoise','Grey seal'))

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

# just checking
a<-aggregate(list(stom=stom3$stomcon,stom.input=stom3$stom.input,stom.hat=stom3$stomcon.hat,stom.hat.part=stom3$stomcon.hat.part),
             list(Year=stom3$Year,Quarter=stom3$Quarter,Predator=stom3$Predator,Pred_l=stom3$Predator.length),sum)

# 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

stom3<-droplevels(stom3)

# 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=18,pointsize = 12,
               new = TRUE, retain = FALSE)

 barchart(stom~as.factor(PredPrey)|headt, data=a,
    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=0.5, lines=2),
    scales = list(x = list(rot = 90, cex=0.5), y= list(alternating = 1,cex=0.5)),
    layout = c(3,4) ,col='grey')

if (F) {
 # for the paper
 barchart(stom~as.factor(PredPrey)|headt, data=a,
    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, lines=2),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(1,1) ,col='grey')
 }

b1<-a
b1$type<-paste(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='')

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

  barchart(stom.hat~as.factor(PredPrey)|headt, data=a,
    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=0.5, lines=2),
    scales = list(x = list(rot = 90, cex=0.5), y= list(alternating = 1,cex=0.5)),
    layout = c(3,4) ,col='grey')

if (F) {

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

 # for the paper
 barchart(stom.hat~as.factor(PredPrey)|headt, data=a,
    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=0.8, lines=2),
    scales = list(x = list(rot = 45, cex=0.8), y= list(alternating = 1,cex=0.8)),
    layout = c(1, 3) ,col='grey')
}

b2<-a

b2$type<-paste(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=17, height=17,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, lines=2),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 3) ,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:6
lab<-dimnames(b)[[1]]

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

 barchart(stom~as.factor(PredPrey)|headt, data=a,
 groups = Prey, stack = TRUE,  col=1:6,
    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:5),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(1, 1) )

b1<-a
b1$type<-paste(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='')
trellis.device(device = "windows",
               color = T, width=7, height=9,pointsize = 2,
               new = TRUE, retain = FALSE)

barchart(stom.hat~as.factor(PredPrey)|headt, data=a,
 groups = Prey, stack = TRUE,  col=1:6,
    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:6),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(1, 3) )

b2<-a

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

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

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

 barchart(stom~as.factor(PredPrey)|type, data=aa,
     groups = Prey, stack = TRUE,  col=1:6,    # 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:6),
    scales = list(x = list(rot = 45, cex=1), y= list(alternating = 1,cex=1)),
    layout = c(2, 3) )

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

trellis.device(device = "windows",
               color = T, width=8, height=4,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) )

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

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

by(a,list(a$Predator),function(x) {
    tit<-paste(x[1,]$Predator,' mean=',formatC(x[1,]$mean,digits=2,format='f'), ' var=',formatC(x[1,]$var,digits=2,format='f'),sep='')
    b<- tapply(x$stom,x$PredPrey,sum)
    print(b)
    if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    barplot(b)
    title(main=tit)
})

 ##############################################################
#observation of prey size against predator size by predator
## prog size 2aa

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Prey.size))
max.ratio<-log(max(stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size),log(x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(prey.size)",
             ylim=c(min.ratio,max.ratio),col=x$Quarter.no)
   abline(h=0, lty=3)
   aa<-lm(log(Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3)
   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator size by predator
## prog size 2a

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$Predator.size,log(x$Predator.size/x$Prey.size),main=NULL,xlab='predator size',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio),col=x$Quarter.no)
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~Predator.size ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3)
   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator size by predator
## prog size 2b

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio))
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3,lwd=2)

   #quantile regression
   for (tau in c(0.025,0.975)) {
     ru<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=tau)
     abline(ru,col='blue',lty=2)
   }
   # weighted regression
   #aa<-lm(log(Predator.size/Prey.size)~log(Predator.size),weights=stomcon ,data=x)
   #ac<-aa[["coefficients"]]
   #abline(aa, lty=2,col=2)

   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator size by predator
## prog size 2b paper

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4 & Predator=='Cod' & Prey=='Haddock')
#stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4 & Predator=='Cod' & Prey=='Cod')
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator weight)',ylab="log(predator weight / prey weight)")

   #quantile regression
   for (tau in c(0.025,0.975)) {
     ru<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=tau)
     abline(ru,col=1,lty=2)
   }

   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator size by prey
## prog size 3

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Predator,stom2$Prey.no),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$Predator.size,log(x$Predator.size/x$Prey.size),main=NULL,xlab='predator size',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio),col=x$Quarter.no)
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~Predator.size ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3)
   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator
## prog size 4

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$Predator.size,log(x$Predator.size/x$Prey.size),main=NULL,xlab='predator size',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio),col=x$Prey.no)
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~Predator.size ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3)
   title(main=paste(x[1,]$Predator,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

##############################################################
#observation of predator-prey size ratio against predator
## prog size 5

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio))
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3)
      #quantile regression
   rl<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=0.025)
   ru<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=0.975)
   abline(rl,col='blue',lty=2)
   abline(ru,col='blue',lty=2)

   title(main=paste(x[1,]$Predator,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
})}

######################################################################
#observation of predator-prey size ratio against predator
## prog size 6

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

stom2<-subset(stom,Size.model>0 & Prey.no !=0)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio),col=x$Prey.no)
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3,lwd=3)
   title(main=paste(x[1,]$Predator,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   xx<-x
   by(xx,list(xx$Prey.no),function(x) {
        abline(lm(log(Predator.size/Prey.size)~log(Predator.size),data=x))
   })
   i<<-i+1
})}

##############################################################
# Other food observed and estimated by year
## prog other 1

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

stom2<-subset(stom,Prey.no==0)

by(stom2,list(stom2$Year,stom2$Quarter,stom2$Predator.no),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   max.y<-max(x$stomcon.hat,x$stomcon)
   plot(x$Predator.length.class,x$stomcon,xlab='pred. length class',ylab='', pch=1,col=1,type='b',ylim=c(0,max.y))
   lines(x$Predator.length.class,x$stomcon.hat,pch=2,col=2,type='p')
   title(main=paste(x[1,]$Predator,x[1,]$Year,x[1,]$Quarter))
   i<<-i+1
})

##############################################################
# Other food observed and estimated by year
## prog other 1

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

stom2<-subset(stom,Prey=='Other')

xyplot(stomcon.hat~Predator.length.class|Quarter*Predator*year, data=stom2,
groups=stomcon,
panel=function(x,y,subscripts,groups) {
 panel.xyplot(x,y,col=1 ,pch=1)
 panel.xyplot(x,groups[subscripts],col=2 ,pch=4)
})

##############################################################
# Other food, suitatability
## prog other 2

xyplot(Suit~Predator.length.class|Quarter*Predator*year, data=stom,subset=(Prey=='Other'),col=2)

##############################################################
#Other food residuals
## prog other 3
xyplot(Residual~Predator.length.class|Quarter*Predator, data=stom,subset=(Prey=='Other'),
panel=function(x,y) {
 panel.xyplot(x,y,col=1 ,pch=1)
 panel.loess(x,y, span=1)
})
##############################################################

##############################################################
#Other food residuals
## prog other 4
xyplot(Residual~log(Predator.size)|Quarter*Predator, data=stom,subset=(Prey=='Other'),
panel=function(x,y) {
 panel.xyplot(x,y,col=1 ,pch=1)
 panel.loess(x,y, span=1)
})
##############################################################

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

#Total Available food
## prog avail 2
#
s<-tapply(stom$Prey.avail,list(stom$Year,stom$Quarter,stom$Predator,stom$Predator.length.class),sum)
s1<-arr2df(s)
names(s1)<-c('Year','Quarter','Predator','Predator.length','Prey.avail')
s1<-s1[!is.na(s1$Prey.avail),]

xyplot(Prey.avail~Predator.length|Quarter*Predator,col=2, data=s1)

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


#' @title Side density distributions
#'
#' @description
#' The [xside] and [yside] variants of \link[ggplot2]{geom_density} is
#' [geom_xsidedensity] and [geom_ysidedensity].
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_bar
#' @inheritParams ggplot2::geom_ribbon
#' @param stat Use to override the default connection between
#'   `geom_density()` and `stat_density()`.
#' @aliases geom_*sidedensity
#' @return XLayer or YLayer object to be added to a ggplot object
#' @examples
#'
#' ggplot(mpg, aes(displ, hwy, colour = class)) +
#'  geom_point(size = 2) +
#'  geom_xsidedensity() +
#'  geom_ysidedensity() +
#'  theme(axis.text.x = element_text(angle = 90, vjust = .5))
#'
#' ggplot(mpg, aes(displ, hwy, colour = class)) +
#'  geom_point(size = 2) +
#'  geom_xsidedensity(aes(y = after_stat(count)),position = "stack") +
#'  geom_ysidedensity(aes(x = after_stat(scaled))) +
#'  theme(axis.text.x = element_text(angle = 90, vjust = .5))
#'
#' @export
geom_xsidedensity <- function(mapping = NULL, data = NULL,
         stat = "density", position = "identity",
         ...,
         na.rm = FALSE,
         orientation = "x",
         show.legend = NA,
         inherit.aes = TRUE,
         outline.type = "upper") {
  mapping <- default_stat_aes(mapping, stat, orientation)
  outline.type <- match.arg(outline.type, c("both", "upper", "lower", "full"))
  l <- layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomXsidedensity,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      orientation = orientation,
      outline.type = outline.type,
      ...
    ),
    layer_class = XLayer
  )
  structure(l, class = c("ggside_layer",class(l)))
}

#' @rdname ggside-ggproto-geoms
#' @usage NULL
#' @format NULL
#' @export
GeomXsidedensity <- ggplot2::ggproto("GeomXsidedensity",
                                     ggplot2::GeomDensity,
                                     default_aes = aes(fill = NA, xfill = NA, weight = 1,
                                                       colour = "black", xcolour = NA, alpha = NA,
                                                       size = 0.5, linetype = 1),
                                     setup_data = function(data, params) {
                                       data <- parse_side_aes(data, params)
                                       ggplot2::GeomDensity$setup_data(data, params)
                                     },
                                     draw_group = function(data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") {
                                       data <- use_xside_aes(data)
                                       ggplot2::GeomDensity$draw_group(data = data, panel_params = panel_params, coord = coord, na.rm = na.rm,
                                                                       flipped_aes = flipped_aes, outline.type = outline.type)},
                                     draw_key = function(data, params, size) {
                                       data <- use_xside_aes(data)
                                       ggplot2::GeomDensity$draw_key(data, params, size)
                                       })

#' @rdname geom_xsidedensity
#' @export
geom_ysidedensity <- function(mapping = NULL, data = NULL,
                              stat = "density", position = "identity",
                              ...,
                              na.rm = FALSE,
                              orientation = "y",
                              show.legend = NA,
                              inherit.aes = TRUE,
                              outline.type = "upper") {
  mapping <- default_stat_aes(mapping, stat, orientation)
  outline.type <- match.arg(outline.type, c("both", "upper", "lower", "full"))
  l <- layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomYsidedensity,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      orientation = orientation,
      outline.type = outline.type,
      ...
    ),
    layer_class = YLayer
  )
  structure(l, class = c("ggside_layer",class(l)))
}

#' @rdname ggside-ggproto-geoms
#' @usage NULL
#' @format NULL
#' @export
GeomYsidedensity <- ggplot2::ggproto("GeomYsidedensity",
                                     ggplot2::GeomDensity,
                                     default_aes = aes(fill = NA, yfill = NA, weight = 1,
                                                       colour = "black", ycolour = NA, alpha = NA,
                                                       size = 0.5, linetype = 1),
                                     setup_data = function(data, params) {
                                       data <- parse_side_aes(data, params)
                                       ggplot2::GeomDensity$setup_data(data, params)
                                     },
                                     draw_group = function(data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") {
                                       data <- use_yside_aes(data)
                                       ggplot2::GeomDensity$draw_group(data = data, panel_params = panel_params, coord = coord, na.rm = na.rm,
                                                                       flipped_aes = flipped_aes, outline.type = outline.type)
                                     },
                                     draw_key = function(data, params, size) {
                                       data <- use_yside_aes(data)
                                       ggplot2::GeomDensity$draw_key(data, params, size)
                                     })


#' Assign reads to pre-existing bins
#'
#' This function exists in AneuFinder, but it is re-bins all reads and ignores
#' already provided reads. The functionality here is basically the same as:
#' https://github.com/ataudt/aneufinder/blob/master/R/binReads.R#L269-L303
#'
#' @param reads     A GRanges object of reads
#' @param bins      A GRanges object of bins
#' @param min_mapq  Min mapping quality (added to object for info)
#' @param id        Sample ID (added to object for info)
#' @return          A GRanges object of the read counts per bin
bin_reads = function(reads, bins, min_mapq=NULL, id=NULL) {
    grc = function(r) GenomicRanges::countOverlaps(bins, r)
    S4Vectors::mcols(bins) = S4Vectors::DataFrame(
        counts = grc(reads),
        mcounts = grc(reads[BiocGenerics::strand(reads) == '-']),
        pcounts = grc(reads[BiocGenerics::strand(reads) == '+']))

    qualityInfo = list(complexity = c(MM=NA),
                       coverage = NA,
                       spikiness = AneuFinder:::qc.spikiness(bins$counts),
                       entropy = AneuFinder:::qc.entropy(bins$counts))

    attr(bins, 'qualityInfo') = qualityInfo
    attr(bins, 'min.mapq') = min_mapq
    attr(bins, 'ID') = id
    bins
}


#' Read MODFLOW .lpf File
#'
#' This function reads in a lpf file and creates a list
#' composed of the following vectors:
#' \describe{
#' \item{ILPFCB}{is a flag and a unit number. If ILPFCB > 0, cell-by-cell flow terms will be written to this unit
#' number when "SAVE BUDGET" or a non-zero value for ICBCFL is specified in Output Control. The terms that are saved
#' are storage, constant-head flow, and flow between adjacent cells.
#' If ILPFCB = 0, cell-by-cell flow terms will not be written.
#' If ILPFCB < 0, cell-by-cell flow for constant-head cells will be written in the listing file when "SAVE BUDGET"
#' or a non-zero value for ICBCFL is specified in Output Control. Cell-by-cell flow to storage and between
#' adjacent cells will not be written to any file.}
#' \item{HDRY}{is the head that is assigned to cells that are converted to dry during a simulation. Although this value plays
#' no role in the model calculations, HDRY values are useful as indicators when looking at the resulting heads that are
#' output from the model. HDRY is thus similar to HNOFLO in the Basic Package, which is the value assigned to cells
#' that are no-flow cells at the start of a model simulation.}
#' \item{NPLPF}{is the number of LPF parameters}
#' \item{LAYTYP}{contains a flag for each layer that specifies the layer type.
#' 0 – confined
#' >0 – convertible
#' <0 – convertible unless the THICKSTRT option is in effect. When THICKSTRT is in effect, a negative value of
#' LAYTYP indicates that the layer is confined, and its saturated thickness will be computed as STRT-BOT.}
#' \item{LAYAVG}{contains a flag for each layer that defines the method of calculating interblock transmissivity.
#' 0—harmonic mean
#' 1—logarithmic mean
#' 2—arithmetic mean of saturated thickness and logarithmic-mean hydraulic conductivity.}
#' \item{CHANI}{contains a value for each layer that is a flag or the horizontal anisotropy. If CHANI is less than or equal to
#' 0, then variable HANI defines horizontal anisotropy. If CHANI is greater than 0, then CHANI is the horizontal
#' anisotropy for the entire layer, and HANI is not read. If any HANI parameters are used, CHANI for all layers must
#' be less than or equal to 0.}
#' \item{LAYVKA}{contains a flag for each layer that indicates whether variable VKA is vertical hydraulic conductivity or
#' the ratio of horizontal to vertical hydraulic conductivity.
#' 0—indicates VKA is vertical hydraulic conductivity
#' not 0—indicates VKA is the ratio of horizontal to vertical hydraulic conductivity, where the horizontal hydraulic
#' conductivity is specified as HK in item 10.}
#' \item{LAYWET}{contains a flag for each layer that indicates whether wetting is active.
#' 0—indicates wetting is inactive
#' not 0—indicates wetting is active}
#' \item{WETFCT}{is a factor that is included in the calculation of the head that is initially established at a cell when the cell
#' is converted from dry to wet. (See IHDWET.)
#' IWETIT—is the iteration interval for attempting to wet cells. Wetting is attempted every IWETIT iteration. If using
#' the PCG solver (Hill, 1990), this applies to outer iterations, not inner iterations. If IWETIT ≤ 0, the value is changed
#' to 1.}
#' \item{IHDWET}{is a flag that determines which equation is used to define the initial head at cells that become wet:
#' If IHDWET = 0, equation 5-32A is used: h = BOT + WETFCT (hn - BOT) .
#' If IHDWET is not 0, equation 5-32B is used: h = BOT + WETFCT(THRESH)}
#' \item{PARNAM}{is the name of a parameter to be defined. This name can consist of 1 to 10 characters and is not case
#' sensitive. That is, any combination of the same characters with different case will be equivalent.}
#' \item{PARTYP}{is the type of parameter to be defined. For the LPF Package, the allowed parameter types are:
#' HK—defines variable HK, horizontal hydraulic conductivity
#' HANI—defines variable HANI, horizontal anisotropy
#' VK—defines variable VKA for layers for which VKA represents vertical hydraulic conductivity (LAYVKA=0)
#' VANI—defines variable VKA for layers for which VKA represents vertical anisotropy (LAYVKA!=0)
#' SS—defines variable Ss, the specific storage
#' SY—defines variable Sy, the specific yield
#' VKCB—defines variable VKCB, the vertical hydraulic conductivity of a Quasi-3D confining layer.}
#' \item{Parval}{is the parameter value. This parameter value may be overridden by a value in the Parameter Value File.}
#' \item{NCLU}{is the number of clusters required to define the parameter. Each repetition of Item 9 is a cluster (variables
#' Layer, Mltarr, Zonarr, and IZ). Each layer that is associated with a parameter usually has only one cluster. For
#' example, parameters which apply to cells in a single layer generally will be defined by just one cluster. However,
#' having more than one cluster for the same layer is acceptable.}
#' \item{Layer}{is the layer number to which a cluster definition applies.}
#' \item{Mltarr}{is the name of the multiplier array to be used to define variable values that are associated with a parameter.
#' The name “NONE” means that there is no multiplier array, and the variable values will be set equal to Parval.}
#' \item{Zonarr}{is the name of the zone array to be used to define the cells that are associated with a parameter. The name
#' “ALL” means that there is no zone array, and all cells in the specified layer are part of the parameter.}
#' \item{IZ}{is up to 10 zone numbers (separated by spaces) that define the cells that are associated with a parameter. These
#' values are not used if ZONARR is specified as “ALL”. Values can be positive or negative, but 0 is not allowed. The
#' end of the line, a zero value, or a non-numeric entry terminates the list of values.}
#' \item{PROPS}{Data frame of LAY, ROW, COL, HK, HANI, VKA, Ss, Sy, VKCB, WETDRY}
#' }
#' @param rootname This is the root name of the lpf file
#' @export
#' @examples
#' readlpf("F95")
#' $ILPFCB
#' [1] 50
#'
#' $HDRY
#' [1] -1e+30
#'
#' $NPLPF
#' [1] 0
#'
#' $LAYTYP
#' [1] 1 3 3 3 0 0 0 0
#'
#' $LAYAVG
#' [1] 0 0 0 0 0 0 0 0
#'
#' $CHANI
#' [1] -1 -1 -1 -1 -1 -1 -1 -1
#'
#' etc.
#'
#' Use this to develop summary statistics of the hydraulic properties
#' p <- readlpf("F95")
#' p$PROPS %>% group_by(LAY) %>% summarise(MIN_K = min(HK), MEDIAN_K = median(HK), MAX_K = max(HK))
#'
# A tibble: 8 x 4
#     LAY      MIN_K  MEDIAN_K    MAX_K
#   <int>      <dbl>     <dbl>    <dbl>
# 1     1  0.1000004  3.229593 17.91849
# 2     2  0.0080000  0.008000  0.00800
# 3     3  0.0080000  0.008000  0.00800
# 4     4  0.0080000  0.008000  0.00800
# 5     5  0.0080000  0.008000  0.00800
# 6     6  0.0080000  0.008000  0.00800
# 7     7  0.1000000  6.449597 17.46494
# 8     8 20.0000000 20.000000 20.00000

readlpf <- function(rootname = NA){
    if(is.na(rootname)){
            rootname <- MFtools::getroot()
    }
    infl <- paste0(rootname, ".lpf")
    d    <- MFtools::readdis(rootname)
    linin <- readr::read_lines(infl)
    indx <- max(grep("#", linin)) + 1
    ILPFCB <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[1]] %>%
              as.integer()
    HDRY   <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[2]] %>%
              as.numeric()
    NPLPF  <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[3]] %>%
              as.integer()
    indx <- indx + 1
    BLOCKEND <- ceiling(d$NLAY / 50)
    BLOCKEND_NUM <- ceiling(d$NLAY / 20)
    LAYTYP <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.integer()
    indx <- indx + BLOCKEND
    LAYAVG <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.integer()
    indx <- indx + BLOCKEND
    CHANI <- linin[indx + seq(1:BLOCKEND_NUM) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
    indx <- indx + BLOCKEND_NUM
    LAYVKA <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.integer()
    indx <- indx + BLOCKEND
    LAYWET <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.integer()
    indx <- indx + BLOCKEND
    WETFCT <- c(NA)
    IWETIT <- c(NA)
    IHDWET <- c(NA)
    if(sum(LAYWET) > 0){
    WETFCT <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[1]] %>%
              as.numeric()
    IWETIT   <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[2]] %>%
              as.integer()
    IHDWET  <- linin[indx] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              .[[3]] %>%
              as.integer()

    indx <- indx + 1
    }
    PARNAM <- vector(mode = "character", length = NPLPF)
    PARTYP <- vector(mode = "character", length = NPLPF)
    Parval <- vector(mode = "numeric", length = NPLPF)
    NCLU   <- vector(mode = "integer", length = NPLPF)
    Layer  <- c(NULL)
    Mltarr <- c(NULL)
    Zonarr <- c(NULL)
    IZ     <- c(NULL)
    if(NPLPF > 0){
        for(Q in 1:NPLPF){
            PARNAM[Q] <- linin[indx] %>%
                         strsplit("\\s+") %>%
                         unlist() %>%
                         subset(. != "") %>%
                         .[[1]]
            PARTYP[Q] <- linin[indx] %>%
                         strsplit("\\s+") %>%
                         unlist() %>%
                         subset(. != "") %>%
                         .[[2]]
            Parval[Q] <- linin[indx] %>%
                         strsplit("\\s+") %>%
                         unlist() %>%
                         subset(. != "") %>%
                         .[[3]]    %>%
                         as.numeric()
            NCLU[Q]   <- linin[indx] %>%
                         strsplit("\\s+") %>%
                         unlist() %>%
                         subset(. != "") %>%
                         .[[4]] %>%
                         as.numeric()
            indx <- indx + 1
            for(ii in 1:NCLU[Q]){
                indx <- indx + 1
                Layer[ii] <- linin[indx] %>%
                             strsplit("\\s+") %>%
                             unlist() %>%
                             subset(. != "") %>%
                             .[[1]] %>%
                             as.integer()
                Mltarr[ii] <- linin[indx] %>%
                             strsplit("\\s+") %>%
                             unlist() %>%
                             subset(. != "") %>%
                             .[[2]]
                Zonarr[ii] <- linin[indx] %>%
                             strsplit("\\s+") %>%
                             unlist() %>%
                             subset(. != "") %>%
                             .[[3]]
                IZ[ii]    <- linin[indx] %>%
                             strsplit("\\s+") %>%
                             unlist() %>%
                             subset(. != "") %>%
                             .[[4:nchar(linin[indx])]] %>%
                             as.integer()
            }
        }
    }
    HKin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
    if(min(CHANI) < 0){
           HANIin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
           }else{
           HANIin <- rep(NA, d$NCOL * d$NROW * d$NLAY)
           }
    VKAin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
    if("TR" %in% d$SS){
        Ssin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
        }else{
        Ssin <- rep(NA, d$NCOL * d$NROW * d$NLAY)
        }
    if(("TR" %in% d$SS)&(min(abs(LAYTYP)) == 0)){
        Syin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
        }else{
        Syin <- rep(NA, d$NCOL * d$NROW * d$NLAY)
        }
    if(any(d$LAYCBD) != 0){
        VKCBDin <- vector(mode = "numeric", length = d$NCOL * d$NROW * d$NLAY)
        }else{
        VKCBDin <- rep(NA, d$NCOL * d$NROW * d$NLAY)
        }
    if((sum(LAYWET) == d$NLAY) & (sum(LAYTYP) != 0)){
        WETDRYin <- vector(mode = "numeric", length = d$NCOL * d$NROW * sum(LAYWET))
        }else{
        WETDRYin <- rep(NA, d$NCOL * d$NROW * d$NLAY) %>% as.numeric()
        }

    for(K in 1:d$NLAY){
# READ HORIZONTAL HYDRAULIC CONDUCTIVITY
#########################################################
    # print(paste("READING HK: LAYER", K))
    FROM <- (K - 1) * d$NROW * d$NCOL + 1
    TO   <- K * d$NROW * d$NCOL

    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    # print(paste("FRMTREP[",K,"] = ", FRMTREP, sep = ""))
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    HKin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
    }else{
        HKin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }
# READ HORIZONTAL ANISOTROPY IF CHANI < 0
########################################################
    # print(paste("READING HANI: LAYER", K))
    if(CHANI[K] <= 0){
        UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
        MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
        FRMT <- substr(linin[indx], start = 21, stop = 30)
        FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
        FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
        BLOCKEND <- (ceiling(d$NCOL / FRMTREP)) * d$NROW
        indx <- indx + 1
        if(UNI == 0){
        HANIin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
        }else{
            HANIin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
                  strsplit("\\s+") %>%
                  unlist() %>%
                  subset(. != "") %>%
                  as.numeric()
            indx <- indx + BLOCKEND
            }
            }

# READ VKA
##########################################################
    # print(paste("READING VKA: LAYER", K))
    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    VKAin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
    }else{
        VKAin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }

# READ Ss IF NUMBER OF TRANSIENT > 0
##########################################################
if("TR" %in% d$SS){
    # print(paste("READING Ss: LAYER", K))
    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    Ssin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
    }else{
        Ssin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }
        }

# READ Sy IF NUMBER OF TRANSIENT > 0 & LAYTYP == UNCONFINED (0)
##########################################################
if(("TR" %in% d$SS)&(LAYTYP[K] != 0)){
    # print(paste("READING Sy: LAYER", K))
    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    Syin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
    }else{
        Syin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }
        }

# READ VKCBD
##########################################################
if(d$LAYCBD[K] != 0){
    # print(paste("READING VKBD: LAYER", K))
    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    rR    }else{
        VKCBDin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }
        }

# READ WETDRY
##########################################################
if((LAYWET[K] != 0) & (LAYTYP[K] != 0)){
    # print(paste("READING WETDRY: LAYER", K))
    UNI <- substr(linin[indx], start = 1, stop = 10) %>% as.integer()
    MULT <- substr(linin[indx], start = 11, stop = 20) %>% as.numeric()
    FRMT <- substr(linin[indx], start = 21, stop = 30)
    FRMTREP <- as.integer(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[1]]
    FRMTWIDTH <- as.numeric(regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT))[[1]])[[2]]
    BLOCKEND <- ceiling(d$NCOL / FRMTREP) * d$NROW

    indx <- indx + 1
    if(UNI == 0){
    WETDRYin[FROM:TO] <- rep(MULT, d$NROW * d$NCOL)
    }else{
        WETDRYin[FROM:TO] <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              strsplit("\\s+") %>%
              unlist() %>%
              subset(. != "") %>%
              as.numeric()
        indx <- indx + BLOCKEND
        }
        }
    }
PROPS <- tibble::data_frame(
                      LAY = rep(1:d$NLAY, each = d$NCOL * d$NROW) %>% as.integer(),
                      ROW = rep(rep(1:d$NROW, each = d$NCOL), d$NLAY) %>% as.integer(),
                      COL = rep(rep(seq(1, d$NCOL, 1), d$NROW), d$NLAY) %>% as.integer(),
                      HK = HKin %>% as.numeric(),
                      HANI = HANIin %>% as.numeric(),
                      VKA = VKAin %>% as.numeric(),
                      Ss = Ssin %>% as.numeric(),
                      Sy = Syin %>% as.numeric(),
                      VKCBD = VKCBDin %>% as.numeric(),
                      WETDRY = WETDRYin %>% as.numeric()
                      )
rm(HKin)
rm(HANIin)
rm(VKAin)
rm(Ssin)
rm(Syin)
rm(VKCBDin)
rm(WETDRYin)
rm(d)
gc()

PROPLIST <- list(ILPFCB = ILPFCB,
                 HDRY = HDRY,
                 NPLPF = NPLPF,
                 LAYTYP = LAYTYP,
                 LAYAVG = LAYAVG,
                 CHANI = CHANI,
                 LAYVKA = LAYVKA,
                 LAYWET = LAYWET,
                 WETFCT = WETFCT,
                 IWETIT = IWETIT,
                 IHDWET = IHDWET,
                 PARNAM = PARNAM,
                 PARTYP = PARTYP,
                 Parval = Parval,
                 NCLU = NCLU,
                 Layer = Layer,
                 Mltarr = Mltarr,
                 Zonarr = Zonarr,
                 IZ = IZ,
                 PROPS = PROPS)
    return(PROPLIST)
    }


# usage: source("benchmark.r")

library("SparkR")
library("microbenchmark")
library("magrittr")
library("ggplot2")
library("pryr")

dir_path <- "/Users/liang/benchmark/results/"

# For benchmarking spark.lapply, I generate

#     lists

# 1. with different types (7):
#     Length = 100,
#     Type = integer,
#            logical,
#            double,
#            character1,
#            character10,
#            character100,
#            character1k.

data.list.type.double <- runif(100)
data.list.type.int <- as.integer(data.list.type.double * 100)
data.list.type.logical <- data.list.type.double < 0.5
data.list.type.char1 <- sapply(1:100, function(x) { "a" })
data.list.type.char10 <- sapply(1:100, function(x) { "0123456789" })
data.list.type.char100 <- sapply(1:100, function(x) { paste(replicate(20, "hello"), collapse = "") })
data.list.type.char1k <- sapply(1:100, function(x) { paste(replicate(200, "hello"), collapse = "") })

# 2. with different lengths (4):
#     Type = integer,
#     Length = 10,
#              100,
#              1k,
#              10k

data.list.len.10 <- 1:10
data.list.len.100 <- 1:100
data.list.len.1k <- 1:1000
data.list.len.10k <- 1:10000

# For benchmarking dapply+rnow/dapplyCollect, I generate

#     data.frame

# 1. with different types (7):
#     nrow = 100,
#     ncol = 1,
#     Type = integer,
#            logical,
#            double,
#            character1,
#            character10,
#            character100,
#            character1k.

data.df.type.double <- data.frame(data.list.type.double) %>% createDataFrame
data.df.type.int <- data.frame(data.list.type.int) %>% createDataFrame
data.df.type.logical <- data.frame(data.list.type.logical) %>% createDataFrame
data.df.type.char1 <- data.frame(data.list.type.char1) %>% createDataFrame
data.df.type.char10 <- data.frame(data.list.type.char10) %>% createDataFrame
data.df.type.char100 <- data.frame(data.list.type.char100) %>% createDataFrame
data.df.type.char1k <- data.frame(data.list.type.char1k) %>% createDataFrame

# 2. with different lengths (4):
#     ncol = 1,
#     Type = integer,
#     nrow = 10,
#            100,
#            1k,
#            10k

data.df.len.10 <- data.frame(data.list.len.10) %>% createDataFrame
data.rdf.len.100 <- data.frame(data.list.len.100)
data.df.len.100 <- data.rdf.len.100 %>% createDataFrame
data.df.len.1k <- data.frame(data.list.len.1k) %>% createDataFrame
data.df.len.10k <- data.frame(data.list.len.10k) %>% createDataFrame

# 3. with different ncols (3):
#     nrow = 100,
#     Type = integer,
#     ncol = 1,
#            10,
#            100

data.df.ncol.1 <- data.df.len.100
data.df.ncol.10 <- data.frame(rep(data.rdf.len.100, each = 10)) %>% createDataFrame
data.df.ncol.100 <- data.frame(rep(data.rdf.len.100, each = 100)) %>% createDataFrame

# For benchmarking gapply+rnow/gapplyCollect, I generate

#     data.frame

# 1. with different number of keys (3):
#     ncol = 2,
#     nrow = 1k,
#     Type = <integer, double>,
#     nkeys = 10,
#             100,
#             1000

data.rand.1k <- runif(1000)

data.df.nkey.10 <- data.frame(key = rep(1:10, 100), val = data.rand.1k) %>% createDataFrame
data.df.nkey.100 <- data.frame(key = rep(1:100, 10), val = data.rand.1k) %>% createDataFrame
data.df.nkey.1k <- data.frame(key = 1:1000, val = data.rand.1k) %>% createDataFrame

# data.df.nkey.10 <- repartition(data.df.nkey.10, numPartitions = 10, col = data.df.nkey.10$"key")
# data.df.nkey.100 <- repartition(data.df.nkey.100, numPartitions = 100, col = data.df.nkey.100$"key")
# data.df.nkey.1k <- repartition(data.df.nkey.1k, numPartitions = 100, col = data.df.nkey.1k$"key")

# 2. with different lengths (4):
#     ncol = 2,
#     Type = <integer, double>,
#     nkeys = 10,
#     nrow = 10,
#            100,
#            1k,
#            10k

data.df.nrow.10 <- data.frame(key = 1:10, val = runif(10)) %>% createDataFrame
data.df.nrow.100 <- data.frame(key = rep(1:10, 10), val = runif(100)) %>% createDataFrame
data.df.nrow.1k <- data.frame(key = rep(1:10, 100), val = data.rand.1k) %>% createDataFrame
data.df.nrow.10k <- data.frame(key = rep(1:10, 1000), val = runif(10000)) %>% createDataFrame

# 3. with different key types (3):
#     ncol = 2,
#     nkeys = 10,
#     nrow = 1k,
#     Type = <integer, double>
#            <character10, double>
#            <character100, double>

key.char10 <- sapply(1:10, function(x) { sprintf("%010d", x) })
key.char100 <- sapply(1:10, function(x) { sprintf("%0100d", x) })

data.df.keytype.int <- data.df.nrow.1k
data.df.keytype.char10 <- data.frame(key = rep(key.char10, 100), val = data.rand.1k) %>% createDataFrame
data.df.keytype.char100 <- data.frame(key = rep(key.char100, 10), val = data.rand.1k) %>% createDataFrame

# ========== benchmark functions ==============

# plot utils
plot.box.mbm <- function(mbm_result) {
	ggplot(mbm_result, aes(x = expr, y = time/1000000)) +
	geom_boxplot(outlier.colour = "red", outlier.shape = 1) + labs(x = "", y = "Time (milliseconds)") +
	geom_jitter(position=position_jitter(0.2), alpha = 0.2) +
	coord_flip()
}

# dummy function
func.dummy <- function(x) { x }

# group function
gfunc.mean <- function(key, sdf) {
	y <- data.frame(key, mean(sdf$val), stringsAsFactors = F)
	names(y) <- c("key", "val")
	y
}

# lapply, type
run.mbm.spark.lapply.type <- function() {
	microbenchmark(
		"lapply.int.100" = { spark.lapply(data.list.type.int, func.dummy) },
		"lapply.double.100" = { spark.lapply(data.list.type.double, func.dummy) },
		"lapply.logical.100" = { spark.lapply(data.list.type.logical, func.dummy) },
		"lapply.char1.100" = { spark.lapply(data.list.type.char1, func.dummy) },
		"lapply.char10.100" = { spark.lapply(data.list.type.char10, func.dummy) },
		"lapply.char100.100" = { spark.lapply(data.list.type.char100, func.dummy) },
		"lapply.char1k.100" = { spark.lapply(data.list.type.char1k, func.dummy) },
		times = 20
	)
}

# lapply, len
run.mbm.spark.lapply.len <- function(fast) {
	if (fast) {
		microbenchmark(
			"lapply.len.10" = { spark.lapply(data.list.len.10, func.dummy) },
			"lapply.len.100" = { spark.lapply(data.list.len.100, func.dummy) },
			"lapply.len.1k" = { spark.lapply(data.list.len.1k, func.dummy) },
			times = 20
		)
	} else {
		microbenchmark(
			"lapply.len.10" = { spark.lapply(data.list.len.10, func.dummy) },
			"lapply.len.100" = { spark.lapply(data.list.len.100, func.dummy) },
			"lapply.len.1k" = { spark.lapply(data.list.len.1k, func.dummy) },
			"lapply.len.10k" = { spark.lapply(data.list.len.10k, func.dummy) },
			times = 20
		)
	}

}

# dapply, type
run.mbm.dapply.type <- function() {
	microbenchmark(
		"dapply.int.100" = { dapply(data.df.type.int, func.dummy, schema(data.df.type.int)) %>% nrow },
		"dapply.double.100" = { dapply(data.df.type.double, func.dummy, schema(data.df.type.double)) %>% nrow },
		"dapply.logical.100" = { dapply(data.df.type.logical, func.dummy, schema(data.df.type.logical)) %>% nrow },
		"dapply.char1.100" = { dapply(data.df.type.char1, func.dummy, schema(data.df.type.char1)) %>% nrow },
		"dapply.char10.100" = { dapply(data.df.type.char10, func.dummy, schema(data.df.type.char10)) %>% nrow },
		"dapply.char100.100" = { dapply(data.df.type.char100, func.dummy, schema(data.df.type.char100)) %>% nrow },
		"dapply.char1k.100" = { dapply(data.df.type.char1k, func.dummy, schema(data.df.type.char1k)) %>% nrow },
		times = 20
	)
}

# dapply, len
run.mbm.dapply.len <- function(fast) {
	if (fast) {
		microbenchmark(
			"dapply.len.10" = { dapply(data.df.len.10, func.dummy, schema(data.df.len.10)) %>% nrow },
			"dapply.len.100" = { dapply(data.df.len.100, func.dummy, schema(data.df.len.100)) %>% nrow },
			"dapply.len.1k" = { dapply(data.df.len.1k, func.dummy, schema(data.df.len.1k)) %>% nrow },
			times = 20
		)
	} else {
		microbenchmark(
			"dapply.len.10" = { dapply(data.df.len.10, func.dummy, schema(data.df.len.10)) %>% nrow },
			"dapply.len.100" = { dapply(data.df.len.100, func.dummy, schema(data.df.len.100)) %>% nrow },
			"dapply.len.1k" = { dapply(data.df.len.1k, func.dummy, schema(data.df.len.1k)) %>% nrow },
			"dapply.len.10k" = { dapply(data.df.len.10k, func.dummy, schema(data.df.len.10k)) %>% nrow },
			times = 20
		)
	}
}

# dapply, ncol
run.mbm.dapply.ncol <- function() {
	microbenchmark(
		"dapply.ncol.1" = { dapply(data.df.ncol.1, func.dummy, schema(data.df.ncol.1)) %>% nrow },
		"dapply.ncol.10" = { dapply(data.df.ncol.10, func.dummy, schema(data.df.ncol.10)) %>% nrow },
		"dapply.ncol.100" = { dapply(data.df.ncol.100, func.dummy, schema(data.df.ncol.100)) %>% nrow },
		times = 20
	)
}

# dapplyCollect, type
run.mbm.dapplyCollect.type <- function() {
	microbenchmark(
		"dapplyCollect.int.100" = { dapplyCollect(data.df.type.int, func.dummy) },
		"dapplyCollect.double.100" = { dapplyCollect(data.df.type.double, func.dummy) },
		"dapplyCollect.logical.100" = { dapplyCollect(data.df.type.logical, func.dummy) },
		"dapplyCollect.char1.100" = { dapplyCollect(data.df.type.char1, func.dummy) },
		"dapplyCollect.char10.100" = { dapplyCollect(data.df.type.char10, func.dummy) },
		"dapplyCollect.char100.100" = { dapplyCollect(data.df.type.char100, func.dummy) },
		"dapplyCollect.char1k.100" = { dapplyCollect(data.df.type.char1k, func.dummy) },
		times = 20
	)
}

# dapplyCollect, len
run.mbm.dapplyCollect.len <- function(fast) {
	if (fast) {
		microbenchmark(
			"dapplyCollect.len.10" = { dapplyCollect(data.df.len.10, func.dummy) },
			"dapplyCollect.len.100" = { dapplyCollect(data.df.len.100, func.dummy) },
			"dapplyCollect.len.1k" = { dapplyCollect(data.df.len.1k, func.dummy) },
			times = 20
		)
	} else {
		microbenchmark(
			"dapplyCollect.len.10" = { dapplyCollect(data.df.len.10, func.dummy) },
			"dapplyCollect.len.100" = { dapplyCollect(data.df.len.100, func.dummy) },
			"dapplyCollect.len.1k" = { dapplyCollect(data.df.len.1k, func.dummy) },
			"dapplyCollect.len.10k" = { dapplyCollect(data.df.len.10k, func.dummy) },
			times = 20
		)
	}
}

# dapplyCollect, ncol
run.mbm.dapplyCollect.ncol <- function() {
	microbenchmark(
		"dapplyCollect.ncol.1" = { dapplyCollect(data.df.ncol.1, func.dummy) },
		"dapplyCollect.ncol.10" = { dapplyCollect(data.df.ncol.10, func.dummy) },
		"dapplyCollect.ncol.100" = { dapplyCollect(data.df.ncol.100, func.dummy) },
		times = 20
	)
}

# gapply, nkey
run.mbm.gapply.nkey <- function() {
	microbenchmark(
		"gapply.nkey.10" = { gapply(data.df.nkey.10, data.df.nkey.10$key, gfunc.mean, schema(data.df.nkey.10)) %>% nrow },
		"gapply.nkey.100" = { gapply(data.df.nkey.100, data.df.nkey.100$key, gfunc.mean, schema(data.df.nkey.100)) %>% nrow },
		"gapply.nkey.1k" = { gapply(data.df.nkey.1k, data.df.nkey.1k$key, gfunc.mean, schema(data.df.nkey.1k)) %>% nrow },
		times = 20
	)
}

# gapply, nrow
run.mbm.gapply.nrow <- function(fast) {
	if (fast) {
		microbenchmark(
			"gapply.nrow.10" = { gapply(data.df.nrow.10, data.df.nrow.10$key, gfunc.mean, schema(data.df.nrow.10)) %>% nrow },
			"gapply.nrow.100" = { gapply(data.df.nrow.100, data.df.nrow.100$key, gfunc.mean, schema(data.df.nrow.100)) %>% nrow },
			"gapply.nrow.1k" = { gapply(data.df.nrow.1k, data.df.nrow.1k$key, gfunc.mean, schema(data.df.nrow.1k)) %>% nrow },
			times = 20
		)
	} else {
		microbenchmark(
			"gapply.nrow.10" = { gapply(data.df.nrow.10, data.df.nrow.10$key, gfunc.mean, schema(data.df.nrow.10)) %>% nrow },
			"gapply.nrow.100" = { gapply(data.df.nrow.100, data.df.nrow.100$key, gfunc.mean, schema(data.df.nrow.100)) %>% nrow },
			"gapply.nrow.1k" = { gapply(data.df.nrow.1k, data.df.nrow.1k$key, gfunc.mean, schema(data.df.nrow.1k)) %>% nrow },
			"gapply.nrow.10k" = { gapply(data.df.nrow.10k, data.df.nrow.10k$key, gfunc.mean, schema(data.df.nrow.10k)) %>% nrow },
			times = 20
		)
	}

}

# gapply, keytype
run.mbm.gapply.keytype <- function() {
	microbenchmark(
		"gapply.keytype.int" = { gapply(data.df.keytype.int, data.df.keytype.int$key, gfunc.mean, schema(data.df.keytype.int)) %>% nrow },
		"gapply.keytype.char10" = { gapply(data.df.keytype.char10, data.df.keytype.char10$key, gfunc.mean, schema(data.df.keytype.char10)) %>% nrow },
		"gapply.keytype.char100" = { gapply(data.df.keytype.char100, data.df.keytype.char100$key, gfunc.mean, schema(data.df.keytype.char100)) %>% nrow },
		times = 20
	)
}

# gapplyCollect, nkey
run.mbm.gapplyCollect.nkey <- function() {
	microbenchmark(
		"gapplyCollect.nkey.10" = { gapplyCollect(data.df.nkey.10, data.df.nkey.10$key, gfunc.mean) },
		"gapplyCollect.nkey.100" = { gapplyCollect(data.df.nkey.100, data.df.nkey.100$key, gfunc.mean) },
		"gapplyCollect.nkey.1k" = { gapplyCollect(data.df.nkey.1k, data.df.nkey.1k$key, gfunc.mean) },
		times = 20
	)
}

# gapplyCollect, nrow
run.mbm.gapplyCollect.nrow <- function(fast) {
	if (fast) {
		microbenchmark(
			"gapplyCollect.nrow.10" = { gapplyCollect(data.df.nrow.10, data.df.nrow.10$key, gfunc.mean) },
			"gapplyCollect.nrow.100" = { gapplyCollect(data.df.nrow.100, data.df.nrow.100$key, gfunc.mean) },
			"gapplyCollect.nrow.1k" = { gapplyCollect(data.df.nrow.1k, data.df.nrow.1k$key, gfunc.mean) },
			times = 20
		)
	} else {
		microbenchmark(
			"gapplyCollect.nrow.10" = { gapplyCollect(data.df.nrow.10, data.df.nrow.10$key, gfunc.mean) },
			"gapplyCollect.nrow.100" = { gapplyCollect(data.df.nrow.100, data.df.nrow.100$key, gfunc.mean) },
			"gapplyCollect.nrow.1k" = { gapplyCollect(data.df.nrow.1k, data.df.nrow.1k$key, gfunc.mean) },
			"gapplyCollect.nrow.10k" = { gapplyCollect(data.df.nrow.10k, data.df.nrow.10k$key, gfunc.mean) },
			times = 20
		)
	}

}

# gapplyCollect, keytype
run.mbm.gapplyCollect.keytype <- function() {
	microbenchmark(
		"gapplyCollect.keytype.int" = { gapplyCollect(data.df.keytype.int, data.df.keytype.int$key, gfunc.mean) },
		"gapplyCollect.keytype.char10" = { gapplyCollect(data.df.keytype.char10, data.df.keytype.char10$key, gfunc.mean) },
		"gapplyCollect.keytype.char100" = { gapplyCollect(data.df.keytype.char100, data.df.keytype.char100$key, gfunc.mean) },
		times = 20
	)
}


# Run the code below to set up the data
# Make a scatter plot with x=Male, y=Female

library(tidyverse)

# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")

casey <- unisex_data %>% # get just the data for "Casey" needed to plot
  filter(name == "Casey") %>%
  select(-prop) %>%
  spread(sex, n, fill = 0)

# look at the data
casey

# make the plot