##Contents
#1. buildBinary
#2. buildMulti
#3. barMANA
#4. boxMANA
#5. randLmer (internal function)
#6. randGlmer (internal function)
#7. fixedLmer (internal function)
#8. fixedGlmer (internal function)

##1. binary data frame (Expand the counts to binary)
buildBinary <-  function(dat,copy,one,zero){  #label object, 'one' column, 'zero' column
 if (missing(dat)) stop("Need the data frame")
 if (missing(copy)) stop("Need column numbers to copy")
 if (missing(one)) stop("Need column name of 'one' counts")
 if (missing(zero)) stop("Need column name of 'zero' counts")
  labels_one<- cbind(1,dat[,copy]);colnames(labels_one)[1]<- "status"
  labels_zero<- cbind(0,dat[,copy]);colnames(labels_zero)[1]<- "status"
#column number
one2<- which(colnames(dat)==one)
zero2<- which(colnames(dat)==zero)
  dat_one<- labels_one[rep(1:length(dat[,one2]),dat[,one2][1:length(dat[,one2])]),]
  dat_zero<- labels_zero[rep(1:length(dat[,zero2]),dat[,zero2][1:length(dat[,zero2])]),]
  expa<-rbind(dat_one,dat_zero)
  invisible(expa) #does not print
} #end function

#**************************************************************************************

##2. Create multinomial data frame (Expand the counts to given number)
buildMulti <-  function(dat,copy,multi){
 if (missing(dat)) stop("Need the data frame")
 if (missing(copy)) stop("Need column numbers to copy")
 if (missing(multi)) stop("Need multi list(vector of numbers,vector of names)")
#get column information
col_mult<- matrix(0,ncol=1,nrow=length(multi[[1]]))  #columns numbers
col_sum<-  matrix(0,ncol=1,nrow=length(multi[[1]]))  #counts in columns
for (i in 1:length(multi[[1]])) {
  col_mult[i,]<- which(colnames(dat)==multi[[2]][i]) } #colnames in list
for (i in 1:length(multi[[1]])) {
  col_sum[i,]<- sum(dat[col_mult[i,]]) }   #get length in counts for each column
##Data copied by X
org<- do.call("rbind", replicate(length(multi[[1]]),dat[,copy],simplify=F))
#add the timing factor, the number, and bind
tim<-  c()
 for (i in 1:length(multi[[1]])) { tim<- c(tim,dat[,col_mult[i]]) }
status<- rep(multi[[1]],each=length(dat[,1]))
org<- cbind(tim,status,org)  #column is named status
#Expansion
expa<- org[rep(1:length(org[,1]),org[,1][1:length(org[,1])]),]   #tim=,1
expa<- expa[,-c(1)] #remove tim
#
  invisible(expa) #does not print
} #end function

#**************************************************************************************

##3. Bargraph CI
barMANA<- function(ci_dat,type="perc",bar_len=0.1,ymax=NULL,ymin=NULL,yunit=NULL,leg="topright",     #ci object
  cex_ylab=1,cex_yaxis=1,cex_names=1) {
#error bar script
  error.bar <- function(x, y, upper, lower=upper, length=bar_len,...){
    if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
    stop("vectors must be same length")
    arrows(x,upper, x, lower, angle=90, code=3, length=length, ...)}
#condtions for type
if (type == "perc") { dat<- ci_dat$percentage; label<- "phenotypic variance (%)" }
if (type == "raw") { dat<- ci_dat$raw; label<- "phenotypic variance" }
#find columns
if (is.null(dat$trait)) { num <- 1; name_lab<- ""
  ord<- matrix(0,ncol=1,nrow=3)
  ord[,1][1]<- which(dat$component=="additive")
  ord[,1][2]<- which(dat$component=="nonadd")
  ord[,1][3]<- which(dat$component=="maternal") }
if (!is.null(dat$trait)) { num <- length(levels(dat$trait)); name_lab<- levels(dat$trait)
  ord<- matrix(0,ncol=1,nrow=3*num)
  ord[,1][seq(1,3*num,3)]<- which(dat$component=="additive")
  ord[,1][seq(2,3*num,3)]<- which(dat$component=="nonadd")
  ord[,1][seq(3,3*num,3)]<- which(dat$component=="maternal") }
#Data matrix
 dat_ci<- matrix(dat[,3][ord],ncol=num,nrow=3) #median/mean
 lwr_ci<- matrix(dat$lower[ord],ncol=num,nrow=3)
 upp_ci<- matrix(dat$upper[ord],ncol=num,nrow=3)
#plot
 if (is.null(ymax)) { ymax<- max(dat$upper[ord]) }
 if (!is.null(ymax)) { ymax<- ymax }
 if (is.null(ymin)) { ymin<- 0 }
 if (!is.null(ymin)) { ymin<- ymin }
ci_plot<- barplot(dat_ci,beside=T,ylab=label,col=c("gray55","gray","gray95"),
  names.arg=name_lab,cex.names=cex_names,
  yaxt='n',ylim=c(ymin,ymax),cex.lab=cex_ylab)
  error.bar(ci_plot,dat_ci,upper=upp_ci,lower=lwr_ci)
  legend(paste(leg),c("additive","non-additive","maternal"),fill=c("gray55","gray","gray95"))
#axes
  if (is.null(yunit)) { yunit<- (ymax-ymin)/5 }
  if (!is.null(yunit)) { yunit<- yunit }
  axis(1, at=c(0,4*num),labels=FALSE)
  axis(2, at=seq(ymin,ymax,yunit),labels=seq(ymin,ymax,yunit),las=1,cex.axis=cex_yaxis)
}

#**************************************************************************************

##4. Boxplot resampled results
boxMANA<- function(comp,type="perc",ymax=NULL,ymin=NULL,yunit=NULL,leg="topright",   #bootstrap or jackknife object
  cex_ylab=1,cex_yaxis=1,cex_names=1) {
#find columns
  mater<- grep("maternal", colnames(comp))
  add<- grep("additive", colnames(comp))
  nonadd<- grep("nonadd", colnames(comp))
#condtions for type
if (type == "perc") {
  dat<- stack(100*comp[,c(add,nonadd,mater)]/ comp$Total)
  colnames(dat)<- c("variance","component")
  label<- "phenotypic variance (%)" }
if (type == "raw") {
  dat<- stack(comp[,c(add,nonadd,mater)])
  colnames(dat)<- c("variance","component")
  label<- "phenotypic variance" }
#order add, na, mat
dat$component<- factor(dat$component, levels(dat$component)[c(1,3,2)])
#plot
 if (is.null(ymax)) { ymax<- max(dat$variance) }
 if (!is.null(ymax)) { ymax<- ymax }
 if (is.null(ymin)) { ymin<- 0 }
 if (!is.null(ymin)) { ymin<- ymin }
#condition for trait
if (is.null(comp$trait)) { num<-1; name_lab<- ""
 box_plot<- boxplot(variance~ component, dat, pch=20, las=2, xaxt='n', yaxt='n',
   ylim=c(ymin,ymax),ylab=label,cex.lab=cex_ylab,col=c("gray55","gray","gray95"),at=1:3)
 legend(paste(leg),c("additive","non-additive","maternal"),fill=c("gray55","gray","gray95")) }
#
if (!is.null(comp$trait)) { num <- length(levels(comp$trait)); name_lab<- levels(comp$trait)
  dat$trait<- rep(levels(comp$trait),tapply(comp[,1],comp$trait,length))
  full<- 1:(num*4);rem<- seq(4,num*4,4); loc<- full[-rem]
box_plot<- boxplot(variance~ component + trait, dat, pch=20, las=2, xaxt='n', yaxt='n',
   ylim=c(ymin,ymax),ylab=label,cex.lab=cex_ylab,col=c("gray55","gray","gray95"),at=loc)
  legend(paste(leg),c("additive","non-additive","maternal"),fill=c("gray55","gray","gray95"))
  axis(1, at=seq(2,num*4,4),labels=name_lab,cex.axis=cex_names)  }
#axes
  if (is.null(yunit)) { yunit<- (ymax-ymin)/5 }
  if (!is.null(yunit)) { yunit<- yunit }
  axis(2, at=seq(ymin,ymax,yunit),labels=seq(ymin,ymax,yunit),las=1,cex.axis=cex_yaxis)
}

#**************************************************************************************

##5. Likelihood ratio tests, random effects, LMER
randLmer<- function(model,observ) {
#objects
  rand_terms<- sapply(findbars(formula(model)),function(x) paste0("(", deparse(x), ")"))
  drop_form<- list()
  rtable<- data.frame(term=rand_terms)
  rtable$d.AIC<- NA;rtable$d.BIC<- NA;rtable$Chi.sq<- NA; rtable$p.value<- NA
#drop1 random term, no fixed terms
if (length(fixef(model)) == 1) {
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
 for (i in 1:length(rand_terms)) {
  drop_form[[i]] <- reformulate(rand_terms[-i],response=resp_term)
if (grepl("\\bREML\\b", summary(model)$methTitle) == T) {
  m_new<- lmer(formula=drop_form[[i]],data=observ)
  p_mod<- anova(model,m_new,refit=F) }
if (grepl("\\bREML\\b", summary(model)$methTitle) == F) {
  m_new<- lmer(formula=drop_form[[i]],data=observ,REML=F)
  p_mod<- anova(model,m_new) }
  rtable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) } }
##Dealing with fixed terms
if (length(fixef(model)) > 1) {
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
  fixed_terms<- paste(attributes(terms(model))$term.labels)
 for (i in 1:length(rand_terms)) {
  drop_form[[i]] <- reformulate(c(rand_terms[-i],fixed_terms),response=resp_term)
if (grepl("\\bREML\\b", summary(model)$methTitle) == T) {
  m_new<- lmer(formula=drop_form[[i]],data=observ)
  p_mod<- anova(model,m_new,refit=F) }
if (grepl("\\bREML\\b", summary(model)$methTitle) == F) {
  m_new<- lmer(formula=drop_form[[i]],data=observ,REML=F)
  p_mod<- anova(model,m_new) }
  rtable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) } }
#finish
  invisible(rtable)
} #end function

#**************************************************************************************

##6. Likelihood ratio tests, random effects, GLMER
randGlmer<- function(model,observ,fam_link) {
#objects
  rand_terms<- sapply(findbars(formula(model)),function(x) paste0("(", deparse(x), ")"))
  drop_form<- list()
  rtable<- data.frame(term=rand_terms)
  rtable$d.AIC<- NA;rtable$d.BIC<- NA;rtable$Chi.sq<- NA; rtable$p.value<- NA
#drop1 random term, no fixed terms
if (length(fixef(model)) == 1) {
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
 for (i in 1:length(rand_terms)) {
  drop_form[[i]] <- reformulate(rand_terms[-i],response=resp_term)
  m_new<- glmer(formula=drop_form[[i]],family=fam_link,data=observ)
  p_mod<- anova(model,m_new)
  rtable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) } }
if (length(fixef(model)) > 1) {
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
  fixed_terms<- paste(attributes(terms(model))$term.labels)
 for (i in 1:length(rand_terms)) {
  drop_form[[i]] <- reformulate(c(rand_terms[-i],fixed_terms),response=resp_term)
  m_new<- glmer(formula=drop_form[[i]],family=fam_link,data=observ)
  p_mod<- anova(model,m_new)
  rtable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) } }
#finish
  invisible(rtable)
} #end function

#**************************************************************************************

##7. Likelihood ratio tests, fixed random effects, LMER
fixedLmer<- function(model,observ) {
#objects
  rand_terms<- sapply(findbars(formula(model)),function(x) paste0("(", deparse(x), ")"))
  drop_form<- list()
#drop1 fixed term
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
  fixed_terms<- paste(attributes(terms(model))$term.labels)
  ftable<- data.frame(term=fixed_terms)
  ftable$d.AIC<- NA;ftable$d.BIC<- NA;ftable$Chi.sq<- NA; ftable$p.value<- NA
 for (i in 1:length(fixed_terms)) {
  drop_form[[i]] <- reformulate(c(rand_terms,fixed_terms[-i]),response=resp_term)
  m_new<- lmer(formula=drop_form[[i]],data=observ,REML=F)
  p_mod<- anova(model,m_new)
  ftable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) }
#finish
  invisible(ftable)
} #end function

#**************************************************************************************

##8. Likelihood ratio tests, fixed random effects, GLMER
fixedGlmer<- function(model,observ,fam_link) {
#objects
  rand_terms<- sapply(findbars(formula(model)),function(x) paste0("(", deparse(x), ")"))
  drop_form<- list()
#drop1 fixed term, no fixed terms
  resp_term<- sapply(nobars(formula(model)),function(x) deparse(x))[2]
  fixed_terms<- paste(attributes(terms(model))$term.labels)
  ftable<- data.frame(term=fixed_terms)
  ftable$d.AIC<- NA;ftable$d.BIC<- NA;ftable$Chi.sq<- NA; ftable$p.value<- NA
 for (i in 1:length(fixed_terms)) {
  drop_form[[i]] <- reformulate(c(rand_terms,fixed_terms[-i]),response=resp_term)
  m_new<- glmer(formula=drop_form[[i]],family=fam_link,data=observ)
  p_mod<- anova(model,m_new)
  ftable[,-1][i,]<-c(p_mod$AIC[1]-p_mod$AIC[2],p_mod$BIC[1]-p_mod$BIC[2],p_mod$Chisq[2],p_mod$'Pr(>Chisq)'[2]) }
#finish
  invisible(ftable)
} #end function