#Load packages
library(dplyr)
library(pracma)
library(RRW)

getDelay <- function (val, k, cv) {
  delay = ((100/val) - 1)/k
  delay = delay + rnorm(length(delay),0,cv*delay)
  return(delay)
}

kFit <- function(stand, delay, k) {
  out <-stand/(1+(k*delay))
  return(out)
}

# Create rounding function
  round_any <-  function(x, accuracy, f=round){f(x/ accuracy) * accuracy}
  round.val <- 0.01

#Set the coefficient of variation
CV1 <- .2
#set your simulated k value here
kVal <- 0.07

rrwLoops <- 500
#Set switch for test runs versus full runs
testing <- FALSE

  ### Create simulated data for money
  DollarVec <- seq(5,95, 10)
  DollarVec <- trunc(DollarVec)
  MeanNames <- DollarVec
  MeansVec <- DollarVec
  Dollars100 <- 100

  ProbeMeansRound <- round_any(MeansVec,round.val)
  #Produce a dataframe with names and rounded values of simulated data
  Probes <- data.frame(MeanNames, ProbeMeansRound)

  ### Create data for delays
  #extend Dollar vector
  DollarVecExt <- c(0.5, 1, 2.5,DollarVec)
  #Calculate the value for each delay assuming the "k function" accurately describes delay discounting
  DelayNames <- getDelay(DollarVecExt,kVal,CV1)
  DelayMeansVec <- Dollars100*2 - DollarVecExt

  DelayMeanRound <- round_any(DelayMeansVec,round.val)
  Delays <- data.frame(DelayNames, DelayMeanRound)

  #set simulation constants
  N.ObsInDist <- 20000
  N.Samples <- 20000

 ### Set variables to null
  Probe <- NULL
  AHigher <- NULL
  Overlap <- NULL
  ProbeMean <- NULL
  ProbeVal <- NULL
  direction <- NULL
  Delay <- NULL
  DelayDat.tmp <- NULL

  for(x in Probes$MeanNames) {
    for(y in Delays$DelayNames) {
      j <- 1

        Probe <- x
        ProbeVal <- Probes[Probes$MeanNames == x,"ProbeMeansRound"]

        DelayName <- y
        DelayVal <- Delays[Delays$DelayNames == y, "DelayMeanRound"]
        DelayVal <- as.numeric(DelayVal)

        ### Delayed Probe Distribution- Create Probe and Cost Distrubutions then combine them
        #Create distributions

        B.tmp <- rnorm(N.ObsInDist,mean=ProbeVal,sd=(ProbeVal*CV1))
        ADist <- rnorm(N.ObsInDist,mean=Dollars100,sd=(Dollars100*CV1))
        BCost <- rnorm(N.ObsInDist,mean=DelayVal,sd=(DelayVal*CV1))
        BDist <- rowMeans(cbind(B.tmp,BCost))

        A <- sample(ADist,N.Samples,replace=T)
        #Select value from large Distribution
        B <- sample(BDist,N.Samples,replace=T)

        AHigher <- ifelse(A > B,1,ifelse(A < B, 0, .5))

        # Proportion of draws for which A > B
        MeanP <- mean(AHigher)
        # Calculate Overlap
        Overlap <- 1-(abs(MeanP-0.5)/0.5)
        ProbeMean <- x
        # Directional Overlap
        direction <- ifelse(MeanP > .5, 1, -1)
        j <- j + 1

        tmp.df <- data.frame(DelayName=DelayName, DelayVal=DelayVal, Standard = "100", StandardVal = mean(ADist), Probe=Probe,ProbeVal=mean(BDist),Overlap=Overlap,direction = direction)
      if (is.null(DelayDat.tmp)) {
        DelayDat.tmp <- tmp.df
      } else {
        DelayDat.tmp <- rbind(DelayDat.tmp, tmp.df)
      }
    }
  }

  ### Split DelayDat.tmp by direction to introduce the correct bias, etc.
  ### When direction ==1, then the standard is the HVO
  ### When direction == -1, then the delay is the HVO
  ### If you want the p(HVO) to actually equal the p(Standard), then the simulation has to be run separately for
  ### direction == 1 and direction == -1.

  DelayDat.tmp.Delay <- DelayDat.tmp[DelayDat.tmp$direction == 1,]
  DelayDat.tmp.Now <- DelayDat.tmp[DelayDat.tmp$direction == -1,]

###Unbiased

  print("starting Unbiased Standard")
  probes.tmp <- unique(DelayDat.tmp.Now$Probe)
  df.s.tmp <- NULL
  unbiased.Now <- NULL
  for(x in probes.tmp) {
    print(x)
    dat.tmp <- DelayDat.tmp.Now[DelayDat.tmp.Now$Probe == x,]
    #HVO is probe.
    tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue= 0, loops = rrwLoops,noiseSD = 2)
    df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
    #convert pCross p(HVO) to pStandard (which is the LVO)
    df.s.tmp$pStandard <- 1-df.s.tmp$pCross
    if (is.null(df.s.tmp)) {
      unbiased.Now <- df.s.tmp
    } else {
      unbiased.Now <- rbind(unbiased.Now, df.s.tmp)
    }
  }

  print("starting Unbiased Delay")
  probes.tmp <- unique(DelayDat.tmp.Delay$Probe)
  df.s.tmp <- NULL
  unbiased.Delay <- NULL
  for(x in probes.tmp) {
    print(x)
    dat.tmp <- DelayDat.tmp.Delay[DelayDat.tmp.Delay$Probe == x,]
    #HVO is standard.
    tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue= 0, loops = rrwLoops,noiseSD = 2)
    df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
    #set pCross p(HVO) to pStandard (which is the HVO)
    df.s.tmp$pStandard <- df.s.tmp$pCross
    if (is.null(df.s.tmp)) {
      unbiased.Delay <- df.s.tmp
    } else {
      unbiased.Delay <- rbind(unbiased.Delay, df.s.tmp)
    }
  }

    unbiased <- rbind(unbiased.Now,unbiased.Delay)
    DelayDat.unbiased <- subset(unbiased, select = -c(sd,Q25,Q50,Q75,boundary,startValue,noiseSD,decayAsymptote,decayBeta))
### Unbiased Plot
    DelayDat.unbiased$Delay <- DelayDat.unbiased$DelayName
    DelayDat.unbiased <-DelayDat.unbiased[order(DelayDat.unbiased$Delay),]

    numMeans <- length(MeanNames)
    c1 <- vector(length=numMeans)
    for(ct in 1:numMeans) {
      c1[ct] <- (.9/numMeans) * ct
    }

   if(!testing) {
### Immediacy Bias
    print("starting Immediacy Bias Standard")
    probes.tmp <- unique(DelayDat.tmp.Now$Probe)
    df.s.tmp <- NULL
    Immediacy.Now <- NULL
    for(x in probes.tmp) {
      print(x)
      dat.tmp <- DelayDat.tmp.Now[DelayDat.tmp.Now$Probe == x,]
      tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue=0.5, loops = rrwLoops,noiseSD = 2)
      df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
      df.s.tmp$pStandard <- 1-df.s.tmp$pCross
      if (is.null(df.s.tmp)) {
        Immediacy.Now <- df.s.tmp
      } else {
        Immediacy.Now <- rbind(Immediacy.Now, df.s.tmp)
      }
    }

    print("starting Immediacy Bias Delay")
    probes.tmp <- unique(DelayDat.tmp.Delay$Probe)
    df.s.tmp <- NULL
    Immediacy.Delay <- NULL
    for(x in probes.tmp) {
      print(x)
      dat.tmp <- DelayDat.tmp.Delay[DelayDat.tmp.Delay$Probe == x,]
      tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue= -0.5, loops = rrwLoops,noiseSD = 2)
      df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
      df.s.tmp$pStandard <- df.s.tmp$pCross
      if (is.null(df.s.tmp)) {
        Immediacy.Delay <- df.s.tmp
      } else {
        Immediacy.Delay <- rbind(Immediacy.Delay, df.s.tmp)
      }
    }

      Immediacy <- rbind(Immediacy.Now,Immediacy.Delay)
      DelayDat.immediacy <- subset(Immediacy, select = -c(sd,Q25,Q50,Q75,boundary,startValue,noiseSD,decayAsymptote,decayBeta))
### Immediacy Plot
      DelayDat.immediacy$Delay <- DelayDat.immediacy$DelayName
      DelayDat.immediacy <- DelayDat.immediacy[order(DelayDat.immediacy$Delay),]

### Bias Towards Delay
      print("starting Delay Bias Standard")
      probes.tmp <- unique(DelayDat.tmp.Now$Probe)
      df.s.tmp <- NULL
      delayed.Now <- NULL
      for(x in probes.tmp) {
        print(x)
        dat.tmp <- DelayDat.tmp.Now[DelayDat.tmp.Now$Probe == x,]
        tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue=-0.5, loops = rrwLoops,noiseSD = 2)
        df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
        df.s.tmp$pStandard <- 1-df.s.tmp$pCross
        if (is.null(df.s.tmp)) {
          delayed.Now <- df.s.tmp
        } else {
          delayed.Now <- rbind(delayed.Now, df.s.tmp)
        }
      }

      print("starting Delay Bias Delay")
      probes.tmp <- unique(DelayDat.tmp.Delay$Probe)
      df.s.tmp <- NULL
      delayed.Delay <- NULL
      for(x in probes.tmp) {
        print(x)
        dat.tmp <- DelayDat.tmp.Delay[DelayDat.tmp.Delay$Probe == x,]
        tmp.out <- getMomentsOfRRWoverlap(dat.tmp$Overlap,boundary=15, startValue=0.5, loops = rrwLoops,noiseSD = 2)
        df.s.tmp <- merge(dat.tmp, tmp.out, ,by.x="Overlap",by.y="overlap")
        df.s.tmp$pStandard <- df.s.tmp$pCross
        if (is.null(df.s.tmp)) {
          delayed.Delay <- df.s.tmp
        } else {
          delayed.Delay <- rbind(delayed.Delay, df.s.tmp)
        }
      }

        Delayed <- rbind(delayed.Now,delayed.Delay)
        DelayDat.delayed <- subset(Delayed, select = -c(sd,Q25,Q50,Q75,boundary,startValue,noiseSD,decayAsymptote,decayBeta))
      ### Bias Towards Delay Plot

        DelayDat.delayed$Delay <- DelayDat.delayed$DelayName
        DelayDat.delayed <-DelayDat.delayed[order(DelayDat.delayed$Delay),]
}

### Get x y pair for each probe and plot by delay (value on y and delay on x), fit k with nonlinear least squares
### Use approx to find k values
        ## Unbiased
        ApproxVal.1 <- NULL
        for(a in unique(DelayDat.unbiased$Probe)){
          tmp.dat <- DelayDat.unbiased[DelayDat.unbiased$Probe == a & DelayDat.unbiased$correct == T,]
          x <- tmp.dat$Delay
          y <- tmp.dat$pStandard
          approx_val <- approx(x,y,  n=1000)
          indif.df <- data.frame(approx_val$x,approx_val$y)
          val.delay <- indif.df[which.min(abs(approx_val$y - 0.50)),1]
          val.pStandard <- indif.df[which.min(abs(approx_val$y - 0.50)),2]
          df.tmp <- data.frame(DolVal = a, delay = val.delay, pStand = val.pStandard)

          if (is.null(ApproxVal.1)) {
            ApproxVal.1 <- df.tmp
          } else {
            ApproxVal.1 <- rbind(ApproxVal.1, df.tmp)
          }
        }

if(!testing) {

		## Bias Towards immediacy
        ApproxVal.2 <- NULL
        for(a in unique(DelayDat.immediacy$Probe)){
          tmp.dat <- DelayDat.immediacy[DelayDat.immediacy$Probe == a & DelayDat.immediacy$correct == T,]
          x <- tmp.dat$Delay
          y <- tmp.dat$pStandard
          approx_val <- approx(x,y, n=10000)
          indif.df <- data.frame(approx_val$x,approx_val$y)
          val.delay <- indif.df[which.min(abs(approx_val$y - 0.50)),1]
          val.pStandard <- indif.df[which.min(abs(approx_val$y - 0.50)),2]
          df.tmp <- data.frame(DolVal = a, delay = val.delay, pStand = val.pStandard)

          if (is.null(ApproxVal.2)) {
            ApproxVal.2 <- df.tmp
          } else {
            ApproxVal.2 <- rbind(ApproxVal.2, df.tmp)
          }
        }

        ## Bias Towards Delay
        ApproxVal.3 <- NULL
        for(a in unique(DelayDat.delayed$Probe)){
          tmp.dat <- DelayDat.delayed[DelayDat.delayed$Probe == a & DelayDat.delayed$correct == T,]
          x <- tmp.dat$Delay
          y <- tmp.dat$pStandard
          approx_val <- approx(x,y, n=1000)
          indif.df <- data.frame(approx_val$x,approx_val$y)
          val.delay <- indif.df[which.min(abs(approx_val$y - 0.50)),1]
          val.pStandard <- indif.df[which.min(abs(approx_val$y - 0.50)),2]
          df.tmp <- data.frame(DolVal = a, delay = val.delay, pStand = val.pStandard)

          if (is.null(ApproxVal.3)) {
            ApproxVal.3 <- df.tmp
          } else {
            ApproxVal.3 <- rbind(ApproxVal.3, df.tmp)
          }
        }
      }
      ## Calculate k values
      ### Unbiased
        ApproxVal.1 <- ApproxVal.1[ApproxVal.1$pStand < .53 & ApproxVal.1$pStand > 0.47,]
        nls.sum.tmp1 <- nls(formula=DolVal ~ 100/(1+(k*delay)),data=ApproxVal.1,start=list(k=0.1))
        nls.sum.unbiased <- summary(nls.sum.tmp1)
        #k value
        ApproxVal.1$k <- nls.sum.unbiased$coef[1]
        ApproxVal.1$Bias <- "unbiased"
        ApproxVal.1$Fit <- fitted(nls.sum.tmp1)

if(!testing) {
    ### Bias towards Immediacy
        ApproxVal.2 <- ApproxVal.2[ApproxVal.2$pStand < .53 & ApproxVal.1$pStand > 0.47,]
        nls.sum.tmp2 <- nls(formula=DolVal ~ 100/(1+(k*delay)),data=ApproxVal.2,start=list(k=0.00001))
        nls.sum.immediacy <- summary(nls.sum.tmp2)
        ApproxVal.2$k <- nls.sum.immediacy$coef[1]
        ApproxVal.2$Bias <- "immediacy"
        ApproxVal.2$Fit <- fitted(nls.sum.tmp2)

      ### Bias Towards Delay
        ApproxVal.3 <- ApproxVal.3[ApproxVal.3$pStand < .53 & ApproxVal.1$pStand > 0.47,]
        nls.sum.tmp3 <- nls(formula=DolVal ~ 100/(1+(k*delay)),data=ApproxVal.3,start=list(k=0.00001))
        nls.sum.delayed <- summary(nls.sum.tmp3)
        ApproxVal.3$k <- nls.sum.delayed$coef[1]
        ApproxVal.3$Bias <- "delayed"
        ApproxVal.3$Fit <- fitted(nls.sum.tmp3)

        k.df <- rbind(ApproxVal.1,ApproxVal.2,ApproxVal.3)
}
if(testing) {
  k.df <- ApproxVal.1
}
###points

    pdf(file="kValues x Bias.pdf")
        xHigh <- 1.1*max(k.df$delay)
        k.tmp <- k.df[k.df$Bias == "unbiased",]
        with(k.tmp,plot(DolVal ~ delay ,pch=16,frame.plot=F, xlim=c(0,300),ylim=c(0,100),xlab="Delay",ylab="Dollars",las=1))
        with(k.tmp,lines(c(1:xHigh), kFit(100,c(1:xHigh), k.tmp$k[1]) ))

if(!testing) {
        k.tmp <- k.df[k.df$Bias == "immediacy",]
        with(k.tmp,points(DolVal ~ delay, pch=16,col="red"))
        with(k.tmp,lines(c(1:xHigh), kFit(100,c(1:xHigh), k.tmp$k[1]), col="red") )

        k.tmp <- k.df[k.df$Bias == "delayed",]
        with(k.tmp,points(DolVal ~ delay,pch=16,col="blue"))
        with(k.tmp,lines(c(1:xHigh), kFit(100,c(1:xHigh), k.tmp$k[1]),col="blue" ))
        legend(200,80, legend=c("Bias Towards Immediacy","Unbiased","Bias Towards Delay"),title="Start Point Bias",col=c("red","black","blue"),pch=16,cex=0.75)
}
    dev.off()

      ## Write dataframes to a txt file
          sink("kvalues.txt",append=F)
          print(k.df)
          sink(NULL)


library(ggplot2) #vizualization
library(dplyr) #manipulation
library(mice)  #imputation
install.packages('ggthemes')
library('ggthemes')
library(scales)

# combining test and train data

fullDB <- bind_rows(train, test)

#checking structure of data
str(fullDB)

#grab title from passenger names
fullDB$Title <- gsub('(.*, )| (\\..*)', '', fullDB$Name)

#show title counts by Gender
table(fullDB$Sex, fullDB$Title)

# Add a survived variable to the test set to allow combining data sets
test.survived <- data.frame(survived = rep("None",nrow(test)), test[,])

# Combine data sets
data.combined <- rbind(train, test.survived)

# A bit about R data Types (e.g., Factors)
str(data.combined)

data.combined$Survived <- as.factor(data.combined$Survived)
data.combined$pclass <- as.factor(data.combined$pclass)


# Estimates mean age of families and mean phylogenetic fuse of families across a global grid of 2x2 (resolution as in the original estimation of the presence absence matrix).
# The estimation for every  grid-cell j is done by using the corresponding species richness (i.e., species present in j) for every family i present in j.
# (this procedure can also be performed using presence only (i.e., species richness = 1) of families in j, by transforming the PAM into a binary matrix).
# Continues with R objects generated in previous steps (saves and loads objects for plotting).

which(rowSums(prPAM_g2[,-c(1:2)]) > 5) -> iden; prPAM_g2 <- prPAM_g2[iden,]
prPAM_gt <- prPAM_g2
for (i in 3:438){
  cat(i,"\n")
  prPAM_gt[which(prPAM_gt[,i]>=1),i] <- resB_fams[rownames(resB_fams)==colnames(prPAM_gt)[i],"CG_age_Acal"]
}
MDT_mat <- prPAM_g2; MDT_mat[,-c(1:2)] <- NA
richness_tot <- apply(prPAM_g2[,-c(1:2)], MARGIN = 1,sum,na.rm=T)
MDT_mat[,-c(1:2)] <- prPAM_gt[,-c(1:2)] * prPAM_g2[,-c(1:2)]
MDT_crown <- apply(MDT_mat[,-c(1:2)],MARGIN = 1, sum,na.rm=T)
MDT_crown <- MDT_crown /richness_tot

prPAM_gt <- prPAM_g2
for (i in 3:438){
  cat(i,"\n")
  prPAM_gt[which(prPAM_gt[,i]>=1),i] <- resB_fams[rownames(resB_fams)==colnames(prPAM_gt)[i],"SG_age_Acal"]
}
MDT_mat <- prPAM_g2; MDT_mat[,-c(1:2)] <- NA
richness_tot <- apply(prPAM_g2[,-c(1:2)], MARGIN = 1,sum,na.rm=T)
MDT_mat[,-c(1:2)] <- prPAM_gt[,-c(1:2)] * prPAM_g2[,-c(1:2)]
MDT_stem <- apply(MDT_mat[,-c(1:2)],MARGIN = 1, sum,na.rm=T)
MDT_stem <- MDT_stem /richness_tot

prPAM_gt <- prPAM_g2
for (i in 3:438){
  cat(i,"\n")
  prPAM_gt[which(prPAM_gt[,i]>=1),i] <- (resB_fams[rownames(resB_fams)==colnames(prPAM_gt)[i],"SG_age_Acal"] - resB_fams[rownames(resB_fams)==colnames(prPAM_gt)[i],"CG_age_Acal"])
}
MDT_mat <- prPAM_g2; MDT_mat[,-c(1:2)] <- NA
richness_tot <- apply(prPAM_g2[,-c(1:2)], MARGIN = 1,sum,na.rm=T)
MDT_mat[,-c(1:2)] <- prPAM_gt[,-c(1:2)] * prPAM_g2[,-c(1:2)]
MDT_fuse_non <- apply(MDT_mat[,-c(1:2)],MARGIN = 1, sum,na.rm=T)
MDT_fuse_non <- MDT_fuse_non /richness_tot
save(MDT_stem,MDT_crown,MDT_fuse_non,file=paste(ruta_write,"WeightedMAFS.RData",sep=""))
pdf(paste(ruta_write,"5.MAF_MAPS.pdf",sep=""))

par(mfrow = c(1, 1), pty = "s")
iden <- which(rowSums(prPAM_g2[,-c(1:2)]) > 5)
ssp<-coordinates(prPAM_g2[iden,1:2])
f <- clean_coordinates(as.data.frame(ssp), lon = "LON",lat = "LAT",
                       tests="seas",species=NULL,value="flagged",seas_scale = 110)
k <- 20
Data<-data.frame(Order=1:dim(prPAM_g2[iden,])[1],z=MDT_stem)
Data<-Data[order(Data$z),]
breaks <- getJenksBreaks(Data$z[f],k)
cols_breaks <- (colorRampPalette(c("linen","lightpink","red3","darkred"),bias=1.1)(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
maps::map("world",interior=F); title("Stem Mean Age of Families (MAF)")
points(ssp[f,],pch=22,lwd=0.4,col=orderedcolors[f],bg=orderedcolors[f],cex=0.5)
rect(xleft =-180,xright = 190,ybottom = -86,ytop = 85,border = "black")
abline(h=c(23.5,-23.5),lwd=2,lty=3)
color.legend(xl=-35,xr=35,yb=-83,yt=-67,align="lt",gradient="x",legend=c(round(range(MDT_stem),2)),
             rect.col=cols_breaks)
Data<-data.frame(Order=1:dim(prPAM_g2[iden,])[1],z=MDT_crown)
Data<-Data[order(Data$z),]
breaks <- getJenksBreaks(Data$z[f],k)
cols_breaks <- (colorRampPalette(c("aliceblue","lightblue","dodgerblue3","darkblue"),bias=1.1)(k))
#cols_breaks <- rev(inferno(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
maps::map("world",interior=F); title("Crown Mean Age of Families (MAF)")
points(ssp[f,],pch=22,lwd=0.3,col=orderedcolors[f],bg=orderedcolors[f],cex=0.5)
rect(xleft =-180,xright = 190,ybottom = -86,ytop = 85,border = "black")
abline(h=c(23.5,-23.5),lwd=2,lty=3)
color.legend(xl=-35,xr=35,yb=-83,yt=-67,align="lt",gradient="x",legend=c(round(range(MDT_crown),2)),
             rect.col=cols_breaks)
Data<-data.frame(Order=1:dim(prPAM_g2[iden,])[1],z=MDT_fuse_non)
Data<-Data[order(Data$z),];ssp <- coordinates(prPAM_g2[iden,1:2])
breaks <- getJenksBreaks(Data$z[f],k)
cols_breaks <- (colorRampPalette(c("honeydew","darkseagreen1","forestgreen","black"),bias=1)(k))
Data$col <- cols_breaks[k]
for (i in k:1){Data$col[which(Data$z <= breaks[i])] <- cols_breaks[i]}
orderedcolors<-Data[order(Data$Order),"col"]
maps::map("world",interior=F);title("Mean Fuse of Families (absolute)")
points(ssp[f,],pch=22,lwd=0.1,bg=orderedcolors[f],cex=0.6,col=orderedcolors[f])
rect(xleft =-180,xright = 190,ybottom = -86,ytop = 85,border = "black")
color.legend(xl=-35,xr=35,yb=-83,yt=-67,align="lt",gradient="x",
             legend=c(round(range(MDT_fuse_non),2)),rect.col=cols_breaks)
dev.off()


# This script uses matR to generate 2 or 3 dimmensional pcoas

# table_in is the abundance array as tab text -- columns are samples(metagenomes) rows are taxa or functions
# color_table and pch_table are tab tables, with each row as a metagenome, each column as a metadata
# grouping/coloring. These tables are used to define colors and point shapes for the plot
# It is assumed that the order of samples (left to right) in table_in is the same
# as the order (top to bottom) in color_table and pch_table

# basic operation is to produce a color-less pcoa of the input data

# user can also input a table to specify colors
# This table can contain colors (as hex or nominal) or can contain metadata
# This is a PCoA plotting functions that can handle a number of different scenarios
# It always requires a *.PCoA file (like that produce by AMETHST/plot_pco.r)
# It can handle metadata as a table - producing plots for all or selected metadata columns (metadata used to generate colors automatically)
# It can handle an amthst groups file as metadata (metadata used to generate colors automatically)
# It can handle a list of colors - using them to pain the points directly
# It can handle the case when there is no metadata - painting all of points the same
# users can also specify a pch table to control the shape of plotted icons (this feature may not be ready yet)

render_pcoa.v12 <- function(
                            PCoA_in="", # annotation abundance table (raw or normalized values)
                            image_out="default",
                            figure_main ="principal coordinates",
                            components=c(1,2,3), # R formated string telling which coordinates to plot, and how many (2 or 3 coordinates)
                            label_points=FALSE, # default is off
                            metadata_table=NA, # matrix that contains colors or metadata that can be used to generate colors
                            metadata_column_index=1, # column of the color matrix to color the pcoa (colors for the points in the matrix) -- rows = samples, columns = colorings
                            amethst_groups=NA,
                            color_list=NA, # use explicit list of colors - trumps table if both are supplied
                            pch_behavior="default", #  "default" use pch_default for all; "auto" automatically assign pch from table; "asis" use integer values in the column
                            pch_default=16,
                            pch_table="default",
                            pch_column=1,
                            pch_labels="default",
                            image_width_in=22,
                            image_height_in=17,
                            image_res_dpi=300,
                            width_legend = 0.2, # fraction of width used by legend
                            width_figure = 0.8, # fraction of width used by figure
                            title_cex = "default", # cex for the title of title of the figure, "default" for auto scaling
                            legend_cex = "default", # cex for the legend, default for auto scaling
                            figure_cex = 2, # cex for the figure
                            figure_symbol_cex=2,
                            vert_line="dotted", # "blank", "solid", "dashed", "dotted", "dotdash", "longdash", or "twodash"
                            bar_cex = "default",
                            bar_vert_adjust = 0,
                            use_all_metadata_columns=FALSE, # option to overide color_column -- if true, plots are generate for all of the metadata columns
                            debug=FALSE
                            )

{

  require(matR)
  require(scatterplot3d)

  argument_test <- is.na(c(metadata_table,amethst_groups,color_list)) # check that incompatible options were not selected
  if ( 3 - length(subset(argument_test, argument_test==TRUE) ) > 1){
    stop(
         paste(
               "\n\nOnly on of these can have a non NA value:\n",
               "     metadata_table: ", metadata_table,"\n",
               "     amethst_groups: ", amethst_groups, "\n",
               "     color_list    : ", color_list, "\n\n",
               sep="", collapse=""
               )
         )
  }

  ######################
  ######## MAIN ########
  ######################

  # load data - everything is sorted by id
  my_data <- load_pcoa_data(PCoA_in) # import PCoA data from *.PCoA file --- this is always done

  # load data - everything is sorted by id
  eigen_values <- my_data$eigen_values
  eigen_vectors <- my_data$eigen_vectors
  # get the sample names for ordering data, colors, and pch later
  sample_names <- rownames(eigen_vectors)
  sample_names <- gsub("\"", "", sample_names)

  # make sure everything is sorted by id
  if(debug==TRUE){sample_names.test1<<-sample_names}

  if(debug==TRUE){sample_names.test2<<-sample_names}
  eigen_vectors <- eigen_vectors[ order(sample_names), ]
  eigen_values <- eigen_values[ order(sample_names) ]

  #sample_names <- sample_names[ order(sample_names) ]

  if(debug==TRUE){
    eigen_vectors.test<<-eigen_vectors
    eigen_values.test<<-eigen_values
  }

  #eigen_vectors <- eigen_vectors[ order(rownames(my_data$eigen_vectors)), ]
  #eigen_values <- eigen_values[ order(rownames(my_data$eigen_vectors)) ] # order will reflect id

  num_samples <- ncol(my_data$eigen_vectors)

  #if ( debug == TRUE ){ print(paste("num_samples: ", num_samples)) }

  if(debug==TRUE){print("made it here 1")}

  # CHECK FOR LEVELS OF PCH AS FACTOR _ DEFINE TWO TYPES OF LEGENDS
  # load pch - handles table or integer(pch_default)

  # somwhere here logic for three pch options
  #  pch_behavior = c("default", "auto", "asis")

  if(debug==TRUE){print("ABOUT TO LOAD PCH")}
  pch_object <- load_pch(pch_behavior, pch_default, pch_table, pch_column, pch_labels, sample_names, num_samples, rownames(my_data$eigen_vectors), debug)

  if(debug==TRUE){ pch_object.test <<- pch_object}
#return(list( "plot_pch_values"=plot_pch_values, "pch.levels"=pch_levels, "pch.labels"=pch_labels) )

  plot_pch <- pch_object$plot_pch_vector
  pch_levels <- pch_object$pch_levels
  pch_labels <- pch_object$pch_labels

  if(debug==TRUE){
    print(paste("first_data_sample:", sample_names[1]))
    print(paste("last_data_sample :", sample_names[length(sample_names)]))
    print(paste("first_pch_sample :", names(plot_pch)[1]))
    print(paste("first_pch_sample :", names(plot_pch)[length(plot_pch)]))
    print(paste("first_pch_value  :", (plot_pch)[1]))
    print(paste("last_pch_value  :", (plot_pch)[length(plot_pch)]))
  }

  if(debug==TRUE){print("made it here 2")}

                                        #if(debug==TRUE){print(paste("main.pch_levels", pch_levels))}
  #if(debug==TRUE){print(paste("main.pch_labels", pch_labels))}

  if(debug==TRUE){print(paste("2.pch_levels", pch_levels))}
  if(debug==TRUE){print(paste("2.pch_labels", pch_labels))}

  #####################################################################################
  ########## PLOT WITH NO METADATA OR COLORS SPECIFIED (all point same color) #########
  #####################################################################################
  if ( length(argument_test==TRUE)==0 ){ # create names for the output files
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".NO_COLOR.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".NO_COLOR.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }

    column_levels <- "data" # assign necessary defaults for plotting
    num_levels <- 1
    color_levels <- 1
    ncol.color_matrix <- 1
    pcoa_colors <- "black"

    create_plot( # generate the plot
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                )
  }
  #####################################################################################
  #####################################################################################

  #####################################################################################
  ########### PLOT WITH AMETHST GROUPS (colors generated by load_metadata) ############
  #####################################################################################
  if ( identical( is.na(amethst_groups), FALSE ) ){ # create names for the output files
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".AMETHST_GROUPS.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".AMETHST_GROUPS.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }

    con_grp <- file(amethst_groups) # get metadata and generate colors from amethst groups file
    open(con_grp)
    line_count <- 1
    groups.list <- vector(mode="character")
    while ( length(my_line <- readLines(con_grp,n = 1, warn = FALSE)) > 0) {
      new_line <- my_line
      split_line <- unlist(strsplit(my_line, split=","))
      split_line.list <- rep(line_count, length(split_line))
      names(split_line.list) <- split_line
      groups.list <- c(groups.list, split_line.list)
      line_count <- line_count + 1
    }
    close(con_grp)
    if ( length(groups.list) != length(unique(names(groups.list))) ){
      stop("One or more groups have redundant entries - this is not allowed for coloring the PCoA")
    }
    metadata_column <- matrix(groups.list, ncol=1)

    suppressWarnings( numericCheck <- as.numeric(metadata_column) ) # check to see if metadata are numeric, and sort accordingly
    if( is.na(numericCheck[1])==FALSE ){
      column_name = colnames(metadata_column)[1]
      row_names = rownames(metadata_column)
      metadata_column <- matrix(numericCheck, ncol=1)
      colnames(metadata_column) <- column_name
      rownames(metadata_column) <- row_names
    }
    #sample_names
    metadata_column <- metadata_column[ order(sample_names),,drop=FALSE ] # order the metadata by sample 1d
    #metadata_column <- metadata_column[ order(rownames(metadata_column)),,drop=FALSE ] # order the metadata by value
    color_column <- create_colors(metadata_column, color_mode = "auto")

    column_levels <- levels(as.factor(as.matrix(metadata_column)))
    num_levels <- length(column_levels)
    color_levels <- col.wheel(num_levels)
    ncol.color_matrix <- 1

    colnames(metadata_column) <- "amethst_metadata"
    column_levels <- column_levels[ order(column_levels) ] # NEW (order by levels values)
    color_levels <- color_levels[ order(column_levels) ] # NEW (order by levels values)

    pcoa_colors <- as.character(color_column[,1]) # convert colors to a list after they've been used to sort the eigen vectors

    create_plot( # generate the plot
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                )

  }
  #####################################################################################
  #####################################################################################

  if(debug==TRUE){print("made it here 3")}

  if(debug==TRUE){print(paste("3.pch_levels", pch_levels))}
  if(debug==TRUE){print(paste("3.pch_labels", pch_labels))}

  #####################################################################################
  ############ PLOT WITH LIST OF COLORS (colors generated by load_metadata) ###########
  #####################################################################################
  if ( identical( is.na(color_list), FALSE ) ){ # create names for the output files
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".color_List.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".color_list.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }

    column_levels <- levels(as.factor(as.matrix(color_list))) # get colors directly from list of colors
    num_levels <- length(column_levels)
    color_levels <- col.wheel(num_levels)
    #color_levels <- col.wheel(num_levels)
    ncol.color_matrix <- 1
    pcoa_colors <- color_list

    create_plot( # generate the plot
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                )
  }
  #####################################################################################
  #####################################################################################

  if(debug==TRUE){print("made it here 4")}

  if(debug==TRUE){print(paste("4.pch_levels", pch_levels))}
  if(debug==TRUE){print(paste("4.pch_labels", pch_labels))}

  #####################################################################################
  ########### PLOT WITH METADATA_TABLE (colors produced from color_matrix) ############
  ######## CAN HANDLE PLOTTING ALL OR A SINGLE SELECTED METADATA TABLE COLUMN #########
  #####################################################################################
  if ( identical( is.na(metadata_table), FALSE ) ){

    metadata_matrix <- as.matrix( # Load the metadata table (same if you use one or all columns)
                              read.table(
                                         file=metadata_table,row.names=1,header=TRUE,sep="\t",
                                         colClasses = "character", check.names=FALSE,
                                         comment.char = "",quote="",fill=TRUE,blank.lines.skip=FALSE
                                         )
                              )
    #metadata_matrix <- metadata_matrix[ order(rownames(metadata_matrix)),,drop=FALSE ]  # make sure that the metadata matrix is sorted (ROWWISE) by id
    metadata_matrix <- metadata_matrix[ order(sample_names),,drop=FALSE ]  # make sure that the metadata matrix is sorted (ROWWISE) by id

    if(debug==TRUE){print("made it here 5")}

    if ( use_all_metadata_columns==TRUE ){ # AUTOGENERATE PLOTS FOR ALL COLUMNS IN THE METADATA FILE - ONE PLOT PER METADATA COLUMN

      ncol.color_matrix <- ncol( metadata_matrix) # get then number of columns in the metadata data file = number of plots
      for (i in 1:ncol.color_matrix){ # loop to process through all columns

        if(debug==TRUE){print("made it here 6")}

        metadata_column <- metadata_matrix[ ,i,drop=FALSE ] # get column i from the metadata matrix
        if(debug==TRUE){ test1<<-metadata_column }

        if(debug==TRUE){print("made it here 7")}
        if(debug==TRUE){print(paste("7.pch_levels", pch_levels))}
        if(debug==TRUE){print(paste("7.pch_labels", pch_labels))}

        image_out = paste(PCoA_in,".", colnames(metadata_column), ".pcoa.png", sep="", collapse="") # generate name for plot file
        figure_main = paste( PCoA_in,".", colnames(metadata_column),".PCoA", sep="", collapse="") # generate title for the plot

        suppressWarnings( numericCheck <- as.numeric(metadata_column) ) # check to see if metadata are numeric, and sort accordingly
        if( is.na(numericCheck[1])==FALSE ){
          column_name = colnames(metadata_column)[1]
          row_names = rownames(metadata_column)
          metadata_column <- matrix(numericCheck, ncol=1)
          colnames(metadata_column) <- column_name
          rownames(metadata_column) <- row_names
        }

        if(debug==TRUE){print("made it here 8")}
        if(debug==TRUE){print(paste("8.pch_levels", pch_levels))}
        if(debug==TRUE){print(paste("8.pch_labels", pch_labels))}

        if(debug==TRUE){ test2<<-metadata_column }

        metadata_column <- metadata_column[ order(sample_names),,drop=FALSE ] # order the metadata by value
        #metadata_column <- metadata_column[ order(rownames(metadata_column)),,drop=FALSE ] # order the metadata by value
        if(debug==TRUE){ test3<<-metadata_column }

        color_column <- create_colors(metadata_column, color_mode = "auto") # set parameters for plotting
        ncol.color_matrix <- 1
        column_factors <- as.factor(metadata_column)
        column_levels <- levels(as.factor(metadata_column))
        num_levels <- length(column_levels)
        color_levels <- col.wheel(num_levels)

        rownames(eigen_vectors) <- gsub("\"", "", rownames(eigen_vectors)) # make sure that vectors are sorted identically to the colors
        eigen_vectors <- eigen_vectors[ rownames(color_column), ]

        if(debug==TRUE){print("made it here 9")}
        if(debug==TRUE){print(paste("9.pch_levels", pch_levels))}
        if(debug==TRUE){print(paste("9.pch_labels", pch_labels))}

        #plot_pch <- plot_pch[ rownames(color_column) ]# make sure pch is sorted identically to colors

        pcoa_colors <- as.character(color_column[,1]) # convert colors to a list after they've been used to sort the eigen vectors

        if(debug==TRUE){
          test.color_column <<- color_column
          test.pcoa_colors <<- pcoa_colors
        }

        if(debug==TRUE){print("made it here 10")}
        if(debug==TRUE){print(paste("10.pch_levels", pch_levels))}
        if(debug==TRUE){print(paste("10.pch_labels", pch_labels))}

        create_plot( # generate the plot
                    PCoA_in,
                    ncol.color_matrix,
                    eigen_values, eigen_vectors, components,
                    column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                    image_out,figure_main,
                    image_width_in, image_height_in, image_res_dpi,
                    width_legend, width_figure,
                    title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                    )
      }

    }else if ( use_all_metadata_columns==FALSE ){ # ONLY CREATE A PLOT FOR THE SELECTED COLUMN IN THE METADATA FILE

      metadata_column <- metadata_matrix[ ,metadata_column_index,drop=FALSE ] # get column i from the metadata matrix
      if(debug==TRUE){ test1<<-metadata_column }

      image_out = paste(PCoA_in,".", colnames(metadata_column), ".pcoa.png", sep="", collapse="") # generate name for plot file
      figure_main = paste( PCoA_in,".", colnames(metadata_column),".PCoA", sep="", collapse="") # generate title for the plot

      suppressWarnings( numericCheck <- as.numeric(metadata_column) ) # check to see if metadata are numeric, and sort accordingly
      if( is.na(numericCheck[1])==FALSE ){
        column_name = colnames(metadata_column)[1]
        row_names = rownames(metadata_column)
        metadata_column <- matrix(numericCheck, ncol=1)
        colnames(metadata_column) <- column_name
        rownames(metadata_column) <- row_names
      }

      if(debug==TRUE){ test2<<-metadata_column }

      #metadata_column <- metadata_column[ order(metadata_column),,drop=FALSE ] # order the metadata by value
      metadata_column <- metadata_column[ order(sample_names),,drop=FALSE ] # order the metadata by value
      if(debug==TRUE){ test3<<-metadata_column }

      color_column <- create_colors(metadata_column, color_mode = "auto") # set parameters for plotting
      ncol.color_matrix <- 1
      column_factors <- as.factor(metadata_column)
      column_levels <- levels(as.factor(metadata_column))
      num_levels <- length(column_levels)
      color_levels <- col.wheel(num_levels)
      rownames(eigen_vectors) <- gsub("\"", "", rownames(eigen_vectors)) # make sure that vectors are sorted identically to the colors
      eigen_vectors <- eigen_vectors[ rownames(color_column), ]
      pcoa_colors <- as.character(color_column[,1]) # convert colors to a list after they've been used to sort the eigen vectors
      create_plot( # generate the plot
                  PCoA_in,
                  ncol.color_matrix,
                  eigen_values, eigen_vectors, components,
                  column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                  image_out,figure_main,
                  image_width_in, image_height_in, image_res_dpi,
                  width_legend, width_figure,
                  title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                  )

    }else{
      stop(paste("invalid value for use_all_metadata_columns(", use_all_metadata_columns,") was specified, please try again", sep="", collapse=""))
    }
  }

}
#####################################################################################

######################
###### END MAIN ######
######################

######################
######## SUBS ########
######################

#######################
######## SUB(1): Function to import the data from a pre-calculated PCoA
######################
load_pcoa_data <- function(PCoA_in){

  #print("loading PCoA")

  con_1 <- file(PCoA_in)
  con_2 <- file(PCoA_in)
  # read through the first time to get the number of samples
  open(con_1);
  num_values <- 0
  data_type = "NA"
  while ( length(my_line <- readLines(con_1,n = 1, warn = FALSE)) > 0) {
    if ( length( grep("PCO", my_line) ) == 1  ){
      num_values <- num_values + 1
    }
  }
  close(con_1)
  # create object for values
  eigen_values <- matrix("", num_values, 1)
  dimnames(eigen_values)[[1]] <- 1:num_values
  eigen_vectors <- matrix("", num_values, num_values)
  dimnames(eigen_vectors)[[1]] <- 1:num_values
  # read through a second time to populate the R objects
  value_index <- 1
  vector_index <- 1
  open(con_2)
  current.line <- 1
  data_type = "NA"
  while ( length(my_line <- readLines(con_2,n = 1, warn = FALSE)) > 0) {
    if ( length( grep("#", my_line) ) == 1  ){
      if ( length( grep("EIGEN VALUES", my_line) ) == 1  ){
        data_type="eigen_values"
      } else if ( length( grep("EIGEN VECTORS", my_line) ) == 1 ){
        data_type="eigen_vectors"
      }
    }else{
      split_line <- noquote(strsplit(my_line, split="\t"))
      if ( identical(data_type, "eigen_values")==TRUE ){
        dimnames(eigen_values)[[1]][value_index] <- noquote(split_line[[1]][1])
        eigen_values[value_index,1] <- noquote(split_line[[1]][2])
        value_index <- value_index + 1
      }
      if ( identical(data_type, "eigen_vectors")==TRUE ){
        dimnames(eigen_vectors)[[1]][vector_index] <- noquote(split_line[[1]][1])
        for (i in 2:(num_values+1)){
          eigen_vectors[vector_index, (i-1)] <- as.numeric(noquote(split_line[[1]][i]))
        }
        vector_index <- vector_index + 1
      }
    }
  }
  close(con_2)
  # finish labeling of data objects
  dimnames(eigen_values)[[2]] <- "EigenValues"
  dimnames(eigen_vectors)[[2]] <- dimnames(eigen_values)[[1]]
  class(eigen_values) <- "numeric"
  class(eigen_vectors) <- "numeric"
  # write imported data to global objects
  #eigen_values <<- eigen_values
  #eigen_vectors <<- eigen_vectors
  return(list(eigen_values=eigen_values, eigen_vectors=eigen_vectors))

}
######################
######################
######################

## ######################
## # SUB(2): Function to load the metadata/ generate or import colors for the points
## ######################
## #load_metadata <- function(metadata_table, metadata_column, color_list, amethst_groups){
## load_metadata <- function(metadata_table, ...){

##   if ( identical( is.na(metadata_table), FALSE ) ){ # HANDLE METADATA TABLE for generating colors
##     metadata_matrix <- as.matrix( # Import metadata table, use it to generate colors
##                               read.table(
##                                          file=metadata_table,row.names=1,header=TRUE,sep="\t",
##                                          colClasses = "character", check.names=FALSE,
##                                          comment.char = "",quote="",fill=TRUE,blank.lines.skip=FALSE
##                                          )
##                               )
##     metadata_matrix <- metadata_matrix[ order(rownames(metadata_matrix)),,drop=FALSE ]  # make sure that the metadata matrix is sorted (ROWWISE) by id
##     return(metadata_matrix)

##   } else if ( identical( is.na(amethst_groups), FALSE ) ){ # HANDLE AMETHST GROUPS for generating colors

##     con_grp <- file(amethst_groups)
##     open(con_grp)
##     line_count <- 1
##     groups.list <- vector(mode="character")
##     while ( length(my_line <- readLines(con_grp,n = 1, warn = FALSE)) > 0) {
##       new_line <- my_line
##       split_line <- unlist(strsplit(my_line, split=","))
##       split_line.list <- rep(line_count, length(split_line))
##       names(split_line.list) <- split_line
##       groups.list <- c(groups.list, split_line.list)
##       line_count <- line_count + 1
##     }
##     close(con_grp)
##     if ( length(groups.list) != length(unique(names(groups.list))) ){
##       stop("One or more groups have redundant entries - this is not allowed for coloring the PCoA")
##     }
##     metadata_matrix <- matrix(groups.list, ncol=1)
##     metadata_matrix <- metadata_matrix[ order(metadata_matrix),,drop=FALSE ] # order by metadata value
##     colnames(metadata_matrix) <- "amethst_metadata"
##     #column_levels <<- levels(metadata_column)
##     #num_levels <<- length(column_levels)
##     #color_levels <<- col.wheel(num_levels)
##     #ncol.color_matrix <<- 1
##     #pcoa_colors <<- color_list
##     return(metadata_matrix)

##   }else if ( identical( is.na(color_list), FALSE ) ){ # HANDLE COLOR LIST; use list of color if it is supplied

##     column_levels <<- levels(as.factor(as.matrix(color_list)))
##     num_levels <<- length(column_levels)
##     color_levels <<- col.wheel(num_levels)
##     ncol.color_matrix <<- 1
##     pcoa_colors <<- color_list

##   }else{ # HANDLE NO INPUT METADATA OR COLORS; use a default of black if no table or list is supplied

##     column_levels <<- "data"
##     num_levels <<- 1
##     color_levels <<- 1
##     ncol.color_matrix <<- 1
##     pcoa_colors <<- "black"

##   }
## }
## ######################
## ######################

######################
# SUB(3): Function to import the pch information for the points # load pch matrix if one is specified
######################
load_pch <- function(pch_behavior, pch_default, pch_table, pch_column, pch_labels, sample_names, num_samples, my_names, debug){

#pch_behavior=c("default", "auto", "asis")
  #my_names <- gsub("\"", "", my_names)

  if(debug==TRUE){print(rep("LOADING PCH",50))}

  if(debug==TRUE){print(paste("class(my_names): ", class(my_names), sep=""))}

  if(debug==TRUE){print(paste("(preloop) PCH_BEHAVIOR: ", pch_behavior))}

  if( identical(pch_behavior,"default") ){

    if(debug==TRUE){print(paste("(in loop) PCH_BEHAVIOR: ", pch_behavior))}

    my_names <- gsub("\"", "", my_names)
    pch_matrix <- data.matrix(matrix(rep(pch_default, num_samples), ncol=1))
    #pch_matrix <- pch_matrix[order(rownames(pch_matrix)),]
    #pch_matrix <- pch_matrix[ order(sample_names), ]
    plot_pch <- pch_matrix[ , 1, drop=FALSE]
    plot_pch_vector <- as.vector(plot_pch)
    pch_labels <- levels(as.factor(plot_pch_vector))
    #names(plot_pch_vector) <- my_names
    pch_levels <- pch_labels
    pch_labels <- pch_labels
    if(debug==TRUE){
      print(paste("plot_pch_vector: ", class(plot_pch_vector)))
      print(plot_pch_vector)
      plot_pch_vector.test <<- plot_pch_vector
    }

  }else if ( identical(pch_behavior,"asis") ){

    if(debug==TRUE){print(paste("(in loop) PCH_BEHAVIOR: ", pch_behavior))}

    pch_matrix <- data.matrix(read.table(pch_table, row.names=1, header=TRUE, sep="\t", comment.char="", quote="", check.names=FALSE))

    #my_names <- gsub("\"", "", my_names)

    #pch_matrix <- pch_matrix[ order(rownames(pch_matrix)), ]
    if(debug==TRUE){pch_matrix.test1<<-pch_matrix}
    pch_matrix <- pch_matrix[ order(sample_names), ]
    if(debug==TRUE){pch_matrix.test2<<-pch_matrix}
    plot_pch <- pch_matrix[ , pch_column, drop=FALSE ]
    #plot_pch <- pch_matrix[ order(pch_column), drop=FALSE]
    plot_pch_vector <- as.vector(plot_pch)
    names(plot_pch_vector) <- sample_names[ order(sample_names) ]
    pch_levels <- levels(as.factor(plot_pch_vector))
    if(debug==TRUE){pch_levels.test<<-pch_levels}
    #pch_labels <- pch_labels
    if(debug==TRUE){pch_labels.test<<-pch_labels}
    if(debug==TRUE){plot_pch_vector.test<<-plot_pch_vector}
    if(debug==TRUE){print(paste("ASIS.pch_labels", pch_labels))}
    if(debug==TRUE){print(paste("ASIS.pch_levels", pch_levels))}

    if( length(pch_levels)!=length(pch_labels) ){ stop("you have (", length(pch_labels), ") labels in pch_labels for (", length(pch_levels),") unique factor levels") }

    if(debug==TRUE){
      print(paste("plot_pch_vector class: ", class(plot_pch_vector)))
      print(paste("plot_pch_vector: ",plot_pch_vector))
      plot_pch_vector.test <<- plot_pch_vector
    }

  }else if( identical(pch_behavior, "auto") ){

    if(debug==TRUE){print(paste("(in loop) PCH_BEHAVIOR: ", pch_behavior))}

    # pch_matrix <- data.matrix(read.table(pch_table, row.names=1, header=TRUE, sep="\t", comment.char="", quote="", check.names=FALSE))

      pch_matrix <- as.matrix( # Load the metadata table (same if you use one or all columns)
                              read.table(
                                         file=pch_table,row.names=1,header=TRUE,sep="\t",
                                         colClasses = "character", check.names=FALSE,
                                         comment.char = "",quote="",fill=TRUE,blank.lines.skip=FALSE
                                         )
                              )

    if(debug==TRUE){ pch_matrix.test <<- pch_matrix }
    pch_temp <- create_pch(pch_matrix, pch_column, sample_names, debug)
    plot_pch_vector <- as.vector(pch_temp$my_pch)
    pch_levels <- pch_temp$pch_levels
    pch_labels <- names(pch_levels)

  }else{
    stop(paste("( ",pch_behavior, " )", "is an invalid pch_behavior option value - try \"default\", \"asis\", or \"auto\""))
  }

  if( length(plot_pch_vector) != num_samples ){
    stop(paste("The number of samples in pch column ( ", length(plot_pch), " ) does not match number of samples ( ", num_samples, " )"))
  }

  return(list( "plot_pch_vector"=plot_pch_vector, "pch_levels"=pch_levels, "pch_labels"=pch_labels) )
}
######################
######################

######################
# SUB(3): Sub to provide scaling for title and legened cex
######################
calculate_cex <- function(my_labels, my_pin, my_mai, reduce_by=0.30, debug){

  # get figure width and height from pin
  my_width <- my_pin[1]
  my_height <- my_pin[2]

  # get margine from mai
  my_margin_bottom <- my_mai[1]
  my_margin_left <- my_mai[2]
  my_margin_top <- my_mai[3]
  my_margin_right <- my_mai[4]

  #if(debug==TRUE){
  #  print(paste("my_pin: ", my_pin, sep=""))
  #  print(paste("my_mai: ", my_mai, sep=""))
  #}

  # find the longest label (in inches), and figure out the maximum amount of length scaling that is possible
  label_width_max <- 0
  for (i in 1:length(my_labels)){
    label_width <- strwidth(my_labels[i],'inches')
    if ( label_width > label_width_max){ label_width_max<-label_width  }
  }
  label_width_scale_max <- ( my_width - ( my_margin_right + my_margin_left ) )/label_width_max
  ## if(debug==TRUE){
  ##                 cat(paste("\n", "my_width: ", my_width, "\n",
  ##                           "label_width_max: ", label_width_max, "\n",
  ##                           "label_width_scale_max: ", label_width_scale_max, "\n",
  ##                           sep=""))
  ##                 }

  # find the number of labels, and figure out the maximum height scaling that is possible
  label_height_max <- 0
  for (i in 1:length(my_labels)){
    label_height <- strheight(my_labels[i],'inches')
    if ( label_height > label_height_max){ label_height_max<-label_height  }
  }
  adjusted.label_height_max <- ( label_height_max + label_height_max*0.4 ) # fudge factor for vertical space between legend entries
  label_height_scale_max <- ( my_height - ( my_margin_top + my_margin_bottom ) ) / ( adjusted.label_height_max*length(my_labels) )
  ## if(debug==TRUE){
  ##                 cat(paste("\n", "my_height: ", my_height, "\n",
  ##                           "label_height_max: ", label_height_max, "\n",
  ##                           "length(my_labels): ", length(my_labels), "\n",
  ##                           "label_height_scale_max: ", label_height_scale_max, "\n",
  ##                           sep="" ))
  ##                 }

  # max possible scale is the smaller of the two
  scale_max <- min(label_width_scale_max, label_height_scale_max)
  # adjust by buffer
  #scale_max <- scale_max*(100-buffer/100)
  adjusted_scale_max <- ( scale_max * (1-reduce_by) )
  #if(debug==TRUE){ print(cat("\n", "adjusted_scale_max: ", adjusted_scale_max, "\n", sep=""))  }
  return(adjusted_scale_max)

}

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

######################
# SUB(3): Fetch par values of the current frame - use to scale cex
######################
par_fetch <- function(){
    my_pin<-par('pin')
    my_mai<-par('mai')
    my_mar<-par('mar')
    return(list("my_pin"=my_pin, "my_mai"=my_mai, "my_mar"=my_mar))
}
######################
######################

######################
# SUB(5): Workhorse function that creates the plot
######################
create_plot <- function(
                        PCoA_in,
                        ncol.color_matrix,
                        eigen_values, eigen_vectors, components,
                        column_levels, num_levels, color_levels, pcoa_colors, plot_pch, pch_labels, pch_levels,
                        image_out,figure_main,
                        image_width_in, image_height_in, image_res_dpi,
                        width_legend, width_figure,
                        title_cex, legend_cex, figure_cex, figure_symbol_cex, bar_cex, bar_vert_adjust, label_points, vert_line, debug
                        ){

  if(debug==TRUE){print("creating figure")}

  png( # initialize the png
      filename = image_out,
      width = image_width_in,
      height = image_height_in,
      res = image_res_dpi,
      units = 'in'
      )

  # LAYOUT CREATION HAS TO BE DICTATED BY PCH TO A DEGREE _ NUM LEVELS (1 or more)
  # Determine num levels for pch
  num_pch <- length(levels(as.factor(plot_pch)))
  # CREATE THE LAYOUT
  if ( num_pch > 1 ){
    my_layout <- layout( matrix(c(1,1,2,3,4,3,5,5), 4, 2, byrow=TRUE ), widths=c(0.5,0.5), heights=c(0.1,0.8,0.3,0.1) )
  }else{
    my_layout <- layout(  matrix(c(1,1,2,3,4,4), 3, 2, byrow=TRUE ), widths=c(width_legend,width_figure), heights=c(0.1,0.8,0.1) )
    # requires an extra plot.new() to skip over pch legend (frame 4 or none )
  }
                                        # my_layout <- layout(  matrix(c(1,1,2,3,4,3,5,5), 4, 2, byrow=TRUE ), widths=c(width_legend,width_figure), heights=c(0.1,0.4,0.8,0.4,0.1) ) # for auto pch legend
  layout.show(my_layout)

  # PLOT THE TITLE (layout frame 1)
  par( mai = c(0,0,0,0) )
  par( oma = c(0,0,0,0) )
  plot.new()
  if ( identical(title_cex, "default") ){ # automatically scale cex for the legend
    if(debug==TRUE){print("autoscaling the title cex")}
    title_par <- par_fetch()
    title_cex <- calculate_cex(figure_main, title_par$my_pin, title_par$my_mai, reduce_by=0.10)
  }
  text(x=0.5, y=0.5, figure_main, cex=title_cex)

  # PLOT THE LEGEND (layout frame 2)
  plot.new()
  if ( identical(legend_cex, "default") ){ # automatically scale cex for the legend
    if(debug==TRUE){print("autoscaling the legend cex")}
    legend_par <- par_fetch()
    legend_cex <- calculate_cex(column_levels, legend_par$my_pin, legend_par$my_mai, reduce_by=0.40)
  }
  legend( x="center", y="center", legend=column_levels, pch=15, col=color_levels, cex=legend_cex)

  # PLOT THE PCoA FIGURE (layout frame 3)
  # set par options (Most of the code in this section is copied/adapted from Dan Braithwaite's pco plotting in matR)

  #par(op)
  par <- list ()
  #par$mar <- par()['mar']
  #par$oma <- par()['oma']
                                        #par$mar <- c(4,4,4,4)
  #par$mar <- par(op)['mar']
  #par$oma <- par(op)['oma']
  #par$oma <- c(1,1,1,1)
  #par$mai <- c(1,1,1,1)
  par$main <- ""#figure_main
  #par$labels <- if (length (names (x)) != 0) names (x) else samples (x)
  if ( label_points==TRUE ){
    par$labels <-  rownames(eigen_vectors)
  } else {
    par$labels <- NA
  }
  #if (length (groups (x)) != 0) par$labels <- paste (par$labels, " (", groups (x), ")", sep = "")
  par [c ("xlab", "ylab", if (length (components) == 3) "zlab" else NULL)] <- paste ("PC", components, ", R^2 = ", format (eigen_values [components], dig = 3), sep = "")
  #col <- if (length (groups (x)) != 0) groups (x) else factor (rep (1, length (samples (x))))
  #levels (col) <- colors() [sample (length (colors()), nlevels (col))]
  #g <- as.character (col)
  #par$pch <- 19
  par$cex <- figure_cex
  #par$oma <- c(1,1,1,1)
  #par$mai <- c(1,1,1,1)
  # main plot paramters - create the 2d or 3d plot
  i <- eigen_vectors [ ,components [1]]
  j <- eigen_vectors [ ,components [2]]
  k <- if (length (components) == 3) eigen_vectors [ ,components [3]] else NULL
  if (is.null (k)) {
    #par$col <- col

     par$cex <- figure_cex
     par$col <- pcoa_colors ####<--------------
     #if(debug==TRUE){print(paste("func_pch: ",plot_pch, sep="")}
     par$pch <- plot_pch
    #par$cex.symbols <- figure_symbol_cex
    #par <- resolveMerge (list (...), par)
     xcall (plot, x = i, y = j, with = par, without = "labels")
     xcall (points, x = i, y = j, with = par, without = "labels")
     grid ()
  } else {
    # parameter "color" has to be specially handled.
    # "points" above wants "col", scatterplot3d wants "color", and we
    # want the user not to worry about it...
    # par$color <- col
    #par$cex <- figure_cex
    par$color <- pcoa_colors
    #if(debug==TRUE){print(paste("func_pch: ",plot_pch, sep="")}
    par$pch <- plot_pch
    par$cex.symbols <- figure_symbol_cex
    par$type <- "h"
    par$lty.hplot <- vert_line
    par$axis <- TRUE
    par$box <- FALSE
    #par <- resolveMerge (list (...), par)
    reqPack ("scatterplot3d")
    xys <- xcall (scatterplot3d, x = i, y = j, z = k, with = par,
                  without = c ("cex", "labels")) $ xyz.convert (i, j, k)
                  #without = c ("labels")) $ xyz.convert (i, j, k)
    i <- xys$x ; j <- xys$y
  }
  text (x = i, y = j, labels = par$labels, pos = 4, cex = par$cex)
  #invisible (P)
  #})

  # PCH LEGEND (4 or doesn't exist) ############ <-

  if (num_pch>1){
    #par( mai = c(0,0,0,0) )
    #par( oma = c(0,0,0,0) )
    plot.new()
    par_legend_par <- par_fetch()
    par_legend_cex <- calculate_cex(column_levels, par_legend_par$my_pin, par_legend_par$my_mai, reduce_by=0.40)
    #my_pch_levels <<- as.integer(levels(as.factor(plot_pch)))

    if(debug==TRUE){print("made it here 11")}
    if(debug==TRUE){print(paste("11.pch_levels", pch_levels))}
    if(debug==TRUE){print(paste("11.pch_labels", pch_labels))}

    #if( identical(pch_behavior, "default") ){
    #  pch_legend_text <- rep("pch",num_pch)
    #}else{
      #pch_legend_text<-pch_labels[ order(pch_labels) ]
    #  pch_legend_text <- pch_labels
    #  if ( length(pch_legend_text)!=num_pch ){
    #    stop(paste("length(pch_legend_text) (", length(pch_legend_text), ") and num of unique pch entries (", num_pch,") is not the same."))
    #  }
    #}

    #pch_legend_pch <- as.integer(levels(as.factor(plot_pch)))
    #ordered_pch_legend_pch <- pch_legend_pch[ order(pch_legend_pch) ]
    pch_levels <- as(pch_levels, "numeric")
    legend( x="center", y="center", legend=pch_labels, pch=pch_levels, cex=par_legend_cex, pt.cex=par_legend_cex)
    #legend( x="center", y="center", legend=pch_legend_text, pch=ordered_pch_legend_pch, cex=par_legend_cex, pt.cex=par_legend_cex)
    #legend( x="center", legend="TEST", cex=par_legend_cex, pt.cex=par_legend_cex)
  }

  # PLOT THE COLOR BAR (frame 4 or 5)
  #par( mar = c(2,2,2,2) )
  #par( oma = c(1,1,1,1) )
  bar_x <- 1:num_levels
  bar_y <- 1
  bar_z <- matrix(1:num_levels, ncol=1)
  image(x=bar_x,y=bar_y,z=bar_z,col=color_levels,axes=FALSE,xlab="",ylab="")
  loc <- par("usr")
  if( identical(bar_cex,"default") ){
    bar_texts <- paste(column_levels[1], column_levels[num_levels])
    bar_par <- par_fetch()
    bar_cex <- calculate_cex(bar_texts, bar_par$my_pin, bar_par$my_mai, reduce_by=0.10)
  }
  text(loc[1], (loc[1]+bar_vert_adjust), column_levels[1], pos = 4, xpd = T, cex=bar_cex, adj=c(0,0))
#1 3

  text(loc[2], (loc[1]+bar_vert_adjust), column_levels[num_levels], pos = 2, xpd = T, cex=bar_cex, adj=c(0,0))

  #text(loc[2], (loc[1]+bar_vert_adjust), paste(column_levels[num_levels],":1",sep=""), pos = 2, xpd = T, cex=bar_cex, adj=c(0,0))
  #text(loc[2], (loc[2]+bar_vert_adjust), paste(column_levels[num_levels],":2",sep=""), pos = 2, xpd = T, cex=bar_cex, adj=c(0,0))
  #text(loc[2], (loc[3]+bar_vert_adjust), paste(column_levels[num_levels],":3",sep=""), pos = 2, xpd = T, cex=bar_cex, adj=c(0,0))
  #text(loc[2], (loc[4]+bar_vert_adjust), paste(column_levels[num_levels],":4",sep=""), pos = 2, xpd = T, cex=bar_cex, adj=c(0,0))

                                        #text(loc[1], loc[2], column_levels[1], pos = 4, xpd = T, cex=bar_cex, adj=c(0,0))
  #text(loc[2], loc[2], column_levels[num_levels], pos = 2, xpd = T, cex=bar_cex, adj=c(0,1))

  graphics.off()
}
######################
######################

######################
# SUB(5): Handle partially formatted metadata to produce colors for a single column in a metadata table
######################
## column_color <- function( color_matrix, my_color_mode="auto", my_column ){
##   ncol.color_matrix <<- ncol(color_matrix)
##   plot_colors.matrix <<- create_colors(color_matrix, color_mode=my_color_mode)
##   column_factors <<- as.factor(color_matrix[,my_column])
##   column_levels <<- levels(as.factor(color_matrix[,my_column]))
##   num_levels <<- length(column_levels)
##   color_levels <<- col.wheel(num_levels)
##   pcoa_colors <<- plot_colors.matrix[,my_column]
## }
######################
######################

######################
# SUB(6): Create optimal contrast color selection using a color wheel
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
col.wheel <- function(num_col, my_cex=0.75) {
  cols <- rainbow(num_col)
  col_names <- vector(mode="list", length=num_col)
  for (i in 1:num_col){
    col_names[i] <- getColorTable(cols[i])
  }
  cols
}
######################
######################

######################
# SUB(7): The inverse function to col2rgb()
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
rgb2col <- function(rgb) {
  rgb <- as.integer(rgb)
  class(rgb) <- "hexmode"
  rgb <- as.character(rgb)
  rgb <- matrix(rgb, nrow=3)
  paste("#", apply(rgb, MARGIN=2, FUN=paste, collapse=""), sep="")
}
######################
######################

######################
# SUB(8): Convert all colors into format "#rrggbb"
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
getColorTable <- function(col) {
  rgb <- col2rgb(col);
  col <- rgb2col(rgb);
  sort(unique(col))
}
######################
######################

######################
# SUB(9): Automtically generate colors from metadata with identical text or values
######################
create_colors <- function(metadata_column, color_mode = "auto"){ # function to
  my_data.color <- data.frame(metadata_column)
  #ids <- rownames(metadata_column)
  #color_categories <- colnames(metadata_column)
  #for ( i in 1:dim(metadata_matrix)[2] ){
  column_factors <- as.factor(metadata_column[,1])
  column_levels <- levels(as.factor(metadata_column[,1]))
  num_levels <- length(column_levels)
  color_levels <- col.wheel(num_levels)
  levels(column_factors) <- color_levels
  my_data.color[,1]<-as.character(column_factors)
  #}

  return(my_data.color)
}
######################
######################

######################
# SUB(10): Automtically generate pch from metadata with identical text or values
######################
create_pch <- function(metadata_table, metadata_column, sample_names, debug){ # function to
 #return(list("my_pch"=my_pch, "pch_levels"=pch_levels, "pch_levels_text"=pch_levels_text))

  #pch_matrix <- data.matrix(metadata_table)
  if(debug==TRUE){metadata_table.test <<- metadata_table}

  #plot_pch <- metadata_table[ order(sample_names), metadata_column, drop=FALSE ]
  plot_pch <- metadata_table[ order(rownames(plot_pch)), metadata_column, drop=FALSE ]
  plot_pch_vector <- as.vector(plot_pch)

  if(debug==TRUE){plot_pch_vector.test <<- plot_pch_vector}

  names(plot_pch_vector) <- sample_names[ order(sample_names) ]
  pch_labels <- levels(as.factor(plot_pch_vector))

  num_labels <- length(pch_labels)

  if( num_labels>25 ){ stop("too many pch levels - must be 25 or less") }

  pch_levels <- 1:num_labels
  names(pch_levels) <- pch_labels
  if(debug==TRUE){ pch_levels.test <<- pch_levels }

  my_pch <- integer()
  for (i in 1:nrow(plot_pch)){
    my_pch <- c(my_pch, pch_levels[ as.character( plot_pch[i,metadata_column] ) ])
    if(debug==TRUE){ print(paste("my_pch: ", my_pch)) }
  }

  if(debug==TRUE){ my_pch.test <<- my_pch; pch_levels.test <<- pch_levels}

  return(list("my_pch"=my_pch, "pch_levels"=pch_levels))
}
######################
######################

## create_colors <- function(metadata_matrix, color_mode = "auto"){ # function to
##   #my_data.color <- data.frame(metadata_matrix)
##   my_data.color <- vector(length=nrow(metadata_matrix), mode="character")
##   ids <- rownames(metadata_matrix)
##   color_categories <- colnames(metadata_matrix)
##   for ( i in 1:dim(metadata_matrix)[2] ){
##     column_factors <- as.factor(metadata_matrix[,i])
##     column_levels <- levels(as.factor(metadata_matrix[,i]))
##     num_levels <- length(column_levels)
##     color_levels <- col.wheel(num_levels)
##     levels(column_factors) <- color_levels
##     my_data.color[i] <- as.character(column_factors)
##   }
##   return(my_data.color)
## }
######################
######################

## ######################
## # SUB(10): Plot operations for a single metadata column
## ######################

## plot_column <- function(
##                         metadata_matrix,i,
##                         PCoA_in,
##                         ncol.color_matrix,
##                         eigen_values, eigen_vectors, components,
##                         plot_pch,
##                         image_width_in, image_height_in, image_res_dpi,
##                         width_legend, width_figure,
##                         title_cex, legend_cex, figure_cex, bar_cex, label_points
##                         )
## {
##   metadata_column <- metadata_matrix[ ,i,drop=FALSE ] # get column i from the metadata matrix

##   suppressWarnings( numericCheck <- as.numeric(metadata_column) ) # check to see if metadata are numeric, and sort accordingly
##   if( is.numeric(numericCheck[1]) ){
##     column_name = colnames(metadata_column)[1]
##     row_names = rownames(metadata_column)
##     metadata_column <- matrix(numericCheck, ncol=1)
##     colnames(metadata_column) <- column_name
##     rownames(metadata_column) <- row_names
##   }

##   metadata_column <- metadata_column[ order(metadata_column),,drop=FALSE ] # order the metadata by value

##   color_column <- create_colors(metadata_matrix=metadata_column, color_mode = "auto")
##   #pcoa_colors <<- #color_column[ ,1,drop=FALSE ]
##   ncol.color_matrix <- 1
##   column_factors <- as.factor(metadata_column)
##   column_levels <- levels(as.factor(metadata_column))
##   num_levels <- length(column_levels)
##   color_levels <- col.wheel(num_levels)
##   pcoa_colors <- color_column #[,1, drop=FALSE]

##   image_out = paste(PCoA_in,".", colnames(metadata_column), ".pcoa.png", sep="", collapse="") # generate name for plot file
##   figure_main = paste( PCoA_in,".", colnames(metadata_column),".PCoA", sep="", collapse="") # generate title for the plot

##   #rownames(eigen_vectors) <<- noquote(rownames(eigen_vectors))
##   # test2 <- test2[rownames(test1),,drop=FALSE]
##   # eigen_vectors <<- eigen_vectors[ rownames(color_column),,drop=FALSE ] # sort vectors by ordering of colors
##   #test2[match(row.names(test2), row.names(test1)),1,drop=FALSE]

## ###### HERE

##   #vector_rownames <<- rownames(eigen_vectors)
##   #vector_colnames <<- colnames(eigen_vectors)
##   #color_column <<- as.matrix(color_column)
##   #rownames(eigen_vectors) <<-

##   #test_2 <- eigen_vectors
##   #rownames(test_2) <- gsub("\"", "", rownames(test_2))

##   rownames(eigen_vectors) <- gsub("\"", "", rownames(eigen_vectors))

##   #eigen_vectors[ match(rownames(eigen_vectors), rownames(pcoa_colors)),1,drop=FALSE]
##   #eigen_vectors[ match(rownames(pcoa_colors), rownames(eigen_vectors)),1,drop=FALSE]
##   eigen_vectors <- eigen_vectors[ rownames(pcoa_colors), ]
##   #eigen_vectors[ rownames(pcoa_colors)),]

##   create_plot( # generate the  plot
##               PCoA_in,
##               ncol.color_matrix,
##               eigen_values, eigen_vectors, components,
##               column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
##               image_out,figure_main,
##               image_width_in, image_height_in, image_res_dpi,
##               width_legend, width_figure,
##               title_cex, legend_cex, figure_cex, bar_cex, label_points
##               )
## }

######################
###### END SUBS ######
######################


require(stringr)
require(gtools)
require(parallel)
library(tidyverse)

#UPDATED August 5, 2021

source("import_data_V2.r")

ids = data$ids
nids = length(ids)

source("euk_bayesian_fulldataset_V3.r")

source("euk_heuristic_fulldataset.r")

## average both methods

Bayesian_pairwisedistancematrix_norm_temp = (2-Bayesian_pairwisedistancematrix)
Bayesian_pairwisedistancematrix_norm_temp = Bayesian_pairwisedistancematrix_norm_temp - min(Bayesian_pairwisedistancematrix_norm_temp)
Bayesian_pairwisedistancematrix_norm = Bayesian_pairwisedistancematrix_norm_temp  / (max(Bayesian_pairwisedistancematrix_norm_temp ))

#write.csv(Bayesian_pairwisedistancematrix_norm,"Bayesian_pairwisedistancematrix_norm.csv")

Heuristic_pairwisedistancematrix_norm_temp = (Heuristic_pairwisedistancematrix - min(Heuristic_pairwisedistancematrix,na.rm=TRUE))
Heuristic_pairwisedistancematrix_norm = Heuristic_pairwisedistancematrix_norm_temp  / (max(Heuristic_pairwisedistancematrix_norm_temp,na.rm=TRUE ))

D = sort(Bayesian_pairwisedistancematrix_norm)[rank(Heuristic_pairwisedistancematrix_norm,ties.method="random")]

ensemble_pairwisedistancematrix = matrix(NA,nids,nids)
ensemble_pairwisedistancematrix = list(Bayesian_pairwisedistancematrix_norm,Heuristic_pairwisedistancematrix_norm)

arraytemp = array(NA, dim=c(nids,nids,2))
arraytemp[,,1] = D
arraytemp[,,2] = Heuristic_pairwisedistancematrix_norm
ensemble_pairwisedistancematrix = apply(arraytemp,c(1,2),function (x) mean(x,na.rm=TRUE))
colnames(ensemble_pairwisedistancematrix) = colnames(Bayesian_pairwisedistancematrix_norm )
rownames(ensemble_pairwisedistancematrix) = rownames(Bayesian_pairwisedistancematrix_norm )

ensemble_pairwisedistancematrix = ensemble_pairwisedistancematrix/max(ensemble_pairwisedistancematrix)

todays_date <- Sys.Date()

current_distance_matrix <- paste("../ensemble_matrices/",todays_date,"_pairwisedistancematrix_ensemble.csv", sep="") ##modify so it puts in the right place.

write.csv(ensemble_pairwisedistancematrix, current_distance_matrix)


8 * .Machine$sizeof.long # e.g. 32
# or
object.size(0L)          # e.g. 32 bytes


library(raster)

diff_CS=raster("ISPRA_CS_2015.tif")-raster("ISPRA_CS_2012.tif")
writeRaster(diff_CS,"ISPRA_CS_diff_2015_2012.tif")

diff_CS=raster("ISPRA_CS_2016.tif")-raster("ISPRA_CS_2015.tif")
writeRaster(diff_CS,"ISPRA_CS_diff_2016_2015.tif")


## Makes ebird absences across study area for extinction risk model

library(sf)
library(raster)
library(dplyr)

getwd()

sirgas <- "+proj=poly +lat_0=0 +lon_0=-54 +x_0=5000000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
# get ebird absences in binary model (from s3 script)
## This is ia shapefile of all the ebird complete checklist locations without the focal species,
## within the thresholded area of the model
ebird.abs.bin <- st_read("gis/s_sir/ebird_abs_bin.shp", crs = sirgas)

ebird.abs.bin

# buffer and dissolve by year groups
summary(ebird.abs.bin)
table(cut(ebird.abs.bin$year, breaks = c(1972, 2005,2010,2015,2020)))
ebird.abs.bin$yr.grp <- cut(ebird.abs.bin$year, breaks = c(1972, 2005,2010,2015,2020), labels = c("<2005", "2010", "2015", "2020"))

table(ebird.abs.bin$yr.grp, useNA = "always")

# buff.grps <- ebird.abs.bin %>%
#   group_by(yr.grp)%>%
#   st_buffer(dist = 5000)%>%
#   st_union()
#
#
# buff.grps

ebird2010 <- subset(ebird.abs.bin, yr.grp == "2010")
ebird2015 <- subset(ebird.abs.bin, yr.grp == "2015")
ebird2020 <- subset(ebird.abs.bin, yr.grp == "2020")

ebird2010 <- st_union(st_buffer(ebird2010, dist = 5000))
ebird2015 <- st_union(st_buffer(ebird2015, dist = 5000))
ebird2020 <- st_union(st_buffer(ebird2020, dist = 5000))

plot(st_geometry(ebird.abs.bin), pch = 16)
plot(ebird2010, add = T, col = "red")
plot(ebird2015, add = T, col = "blue")
plot(ebird2020, add = T, col = "green")

# get binary modelled range (from s3_model script)
bin.range <- raster("gis/r_sir/models/modRes_habt_bin_mf.tif")
bin.range

plot(bin.range)
plot(ebird2020, add = T)
#
#
# # convert raster to polygon
# # convert 0 to NA
bin.range[bin.range == 0] <- NA
bin.range.poly <- rasterToPolygons(bin.range, dissolve = TRUE)

bin.range.poly
plot(bin.range.poly, add = T)
#
bin.range.poly <- st_as_sf(bin.range.poly)

# intersect ebird absences with range for estimate of range surveyd

## give range not in ebird2020
# diff2020 <- st_difference(bin.range.poly, ebird2020)
#
# plot(st_geometry(bin.range.poly))
# plot(ebird2020, col = "blue", add = T)
# plot(diff2020, add = TRUE, col = "green")

# ebird dissolved buffers represent area surveyed as these absences are already only those inside modelled range

st_area(ebird2020) / st_area(bin.range.poly)
# 0.3226884 [1]
st_area(ebird2015) / st_area(bin.range.poly)
# 0.148272 [1]
st_area(ebird2010) / st_area(bin.range.poly)
# 0.068318 [1]

save(ebird2010, ebird2015, ebird2020, ebird.abs.bin, bin.range.poly, file = "gis/ebird_survey_data.rdata")
# load("gis/ebird_survey_data.rdata")
# rm(ebird2010, ebird2015, ebird2020)

ebird.abs.bin <- st_read("gis/s_sir/ebird_abs_bin.shp", crs = sirgas)

# make absences per year

res <- list()

range.area <- st_area(bin.range.poly) # 1.74489e+11 [m^2]
yrs <- 2005:2020

st_area(bin.range.poly) / 1000000
174489 # km2

for(i in yrs){

  tmp.yr <- subset(ebird.abs.bin, year == i)
  tmp.yr <- st_union(st_buffer(tmp.yr, dist = 5000))

  yr.res <- cbind(year = i,
        area = st_area(tmp.yr),
        prop.total = st_area(tmp.yr) / range.area)

  res[[which(i == yrs)]] <- yr.res

}

yrRes <- do.call(rbind, res)

save(yrRes, ebird.abs.bin, bin.range.poly, file = "gis/ebird_absence_eps_prop.rdata")


# Compare MAPE for different validation
# of the best model to be used in forecasting

source('2020-08-31-jsa-type-v2-ch2/03-evaluate/init.r')

# Inititalize parameters
model <- c("BGY-E1-C4-I20000-A0.99-T12-F50-V50")

dir_model_folder <- paste0(dir_analysis_edie_model, model, "/")
model_params <- parse_model_identifier(model)

# Original data
file <-paste0(dir_model_folder, "data.csv")
data_raw <- read.csv(file, na.strings=c(""), stringsAsFactors = T)

# Map model indices to original variables
mapping <- unique(data.frame(
    groupname = as.character(data_raw$group),
    group = as.numeric(data_raw$group)
))

# Read data
files <- dir(dir_model_folder, pattern = 'count_info.data.R', full.names = TRUE)
data <- read_rdump(files)

# Read data
files <- dir(
    dir_model_folder,
    pattern = 'count_info_ref.data.R',
    full.names = TRUE
)

data_ref <- read_rdump(files)

# Read model
load(paste0(dir_model_folder, "fit.data"))

# Test
posterior_sim(data, fit)
posterior_forecast(data, 5, fit)

# Predict for 5 (and repeat for 10, 15, 20, 25)
n_samples <- 1000

pfile <- paste0(dir_model_folder, "ts.csv")
if(!file.exists(pfile)) {

    dfs <- lapply(seq(5, model_params$va, 5), function(ptime) {

        print(paste0("-------------- Forecast duration: ", ptime, " years"))

        first_year <- max(data_raw$year) - model_params$va

        # Using posterior_sim, predict using data itself
        predictions_sim <- mclapply(1:n_samples, mc.cores = 1, function(ii) {
            predictions_actual <- posterior_sim(data_ref, fit)
            predictions_actual <- lapply(
                predictions_actual, function(x) {
                    idx1 <- (length(x)-model_params$va+1)
                    idx2 <- (length(x)-model_params$va+ ptime)
                    x[idx1:idx2]
            })
            predictions_actual
        })

        # Using posterior_forecast, predict using naive method
        predictions_forecast <- mclapply(
            1:n_samples, mc.cores = 1, function(ii) {
                posterior_forecast(data, ptime, fit)
        })

        # Coerce these lists of lists to data.table
        sim_li <- lapply(1:n_samples, function(i) {
            x <- predictions_sim[[i]]
            list_to_df(x, i)
        })

        forecast_li <- lapply(1:n_samples, function(i) {
            x <- predictions_forecast[[i]]
            list_to_df(x, i)
        })

        sim_df <- rbindlist(sim_li)
        sim_df$type <- "forecast"
        forecast_df <- rbindlist(forecast_li)
        forecast_df$type <- "naive forecast"
        df <- rbind(forecast_df, sim_df)

        # Wide to long
        df_long <- melt(df, id.vars = c("group", "sim", "type"))
        names(df_long)[which(names(df_long) == "variable")] <- "year"
        names(df_long)[which(names(df_long) == "value")] <- "model"
        df_long$year <-
            as.integer(gsub("year_", "", df_long$year)) + first_year - 1
        df_long$group <- mapping[match(df_long$group, mapping$group),]$groupname

        # Merge with actual counts
        df_obs <- data.table(data_raw)[,
            list(obs = .N),
            by = c("year", "group")
        ]

        df_long <- merge(
            df_long, df_obs,
            by = c("year", "group")
        )

        df_long$ptime <- ptime

        df_long

    })

    # Calculate MAPE
    dfs <- rbindlist(dfs)
    dfs$diff <- abs(dfs$model - dfs$obs)
    dfs$perc <- dfs$diff / dfs$obs
    fwrite(dfs, pfile) # persist

}

dfs <- fread(pfile)

prop <- 1 # proportion of MAPE
summary <- dfs[, list(MAPE = mean(perc)), by = c("ptime", "type")]
summary$MAPE1pt5 <- summary$MAPE * prop
summary$MAPEplt <- ifelse(
    summary$type == "naive forecast",
    summary$MAPE1pt5,
    summary$MAPE
)

# Plot MAPE against ptime

# "naive forecast": not using data
# "forecast": using data
# "best window": largest window where MAPE of "naive forecast" >= "forecast"

lab_naive <- ifelse(
    prop == 1,
    paste0("Naive forecast (no data)"),
    paste0("Naive forecast (no data) * ", prop)
)

p1 <- ggplot(summary, aes(x = ptime, y = summary$MAPEplt, fill = type)) +
    geom_bar(stat = "identity", position = "dodge") + theme +
    ylab("MAPE (%)\n") + xlab("\nPrediction duration") +
    scale_fill_manual(
        values = c('#999999','#E69F00'),
        name = "",
        labels = c("Validation forecast (using data)", lab_naive)
    ) + theme(legend.position="bottom")

output <- paste0(dir_model_folder, "ts.png")
ggsave(p1, file = output, width = 7, height = 4)

# Boxplot
# p2 <- ggplot(summary, aes(x = as.character(ptime), y = MAPE, fill = type)) +
#     geom_boxplot() + theme +
#     ylab("MAPE (%)\n") + xlab("\nPrediction duration") +
#     scale_fill_manual(
#         values = c('#999999','#E69F00'),
#         name = "Type"
#     )

# p2


#' @title calculate_roc_binary_classifier
#' @description
#' Given a fitted binary classification from caret training and tuning, and a test set,
#' calculate the ROC curve and AUC, returning a list of both.  Uses the ROCR package
#' since it can handle the original factors and doesn't need the levels to be turned
#' numeric first.
#'
#' @param fit Tuned and fitting model from caret's train() function
#' @param test Data frame representing test data
#' @param label_class Column name representing the true label in the test set
#' @param curve_title String representing the legend and/or plot title for this ROC curve, used by
#' \code{\link{plot_roc}}, \code{\link{plot_multiple_roc}} and \code{\link{plot_multiple_roc_from_list}}.
#' @return list List with a ROC object and AUC value
#' @export

calculate_roc_binary_classifier <- function(fit = NULL, test = NULL, label_class = NULL, curve_title = NULL, label.order = NULL) {
  require(ROCR)
  rf.pr = predict(fit,type="prob",newdata=test)[,2]
  rf.pred = prediction(rf.pr, test[,label_class], label.ordering = label.order)
  rf.perf = performance(rf.pred, "tpr", "fpr")
  rf.auc = performance(rf.pred, "auc")
  retval <- list("roc" = rf.perf, "auc" = rf.auc, "title" = curve_title)
  retval
}

#'@title plot_roc
#'@description
#'Plots a single ROC curve with diagonal abline, given output objects from calculate_roc_binary_classifier()
#'
#'@param list Output object from calculate_roc_binary_classifier()
#'@export

plot_roc <- function(roc_obj) {
  require(ROCR)
  require(ggplot2)
  require(ggthemes)

  rocData <- roc_obj[["roc"]]
  auc_obj <- roc_obj[["auc"]]
  #aval <- round(auc_obj@y.values[[1]], 4)
  #label_text <- paste(sep = "", "AUC = ", aval)
  plot_title <- paste(sep = "", "ROC Analysis: ", roc_obj[["title"]])

  rocDataFrame <- data.frame(x=rocData@x.values[[1]],y=rocData@y.values[[1]])
  rocr.plot <- ggplot(data=rocDataFrame, aes(x=x, y=y), ) + geom_path(size=1, color="red") #+ geom_text(aes(x=1, y= 0, hjust=1, vjust=0, label=label_text,colour="black",size=8))
  rocr.plot <- rocr.plot + coord_fixed()
  rocr.plot <- rocr.plot + xlab("False Positive Rate") + ylab("True Positive Rate") + ggtitle(plot_title)
  rocr.plot <- rocr.plot + geom_abline(intercept = 0, slope = 1, color="grey")
  rocr.plot <- rocr.plot + theme_pander()
  rocr.plot
}

#' @title plot_multiple_roc
#' @description
#' Plots multiple ROC curves with diagonal abline, given multiple output objects from calculate_roc_binary_classifier()
#'
#' @param multiple Output objects from calculate_roc_binary_classifier()
#' @return ggplot2 plot object
#' @export

plot_multiple_roc <- function(...) {
  require(ROCR)
  require(ggplot2)
  require(ggthemes)

  input_list <- list(...)
  plot_multiple_roc_impl(input_list)
}

#' @title plot_multiple_roc_from_list
#' @description
#' Plots multiple ROC curves with diagonal abline, given a list of output objects from calculate_roc_binary_classifier().
#' Alternate wrapper for the function given that sometimes we'll already have a list of objects, say from a long-running
#' analysis, and not be passing in individual objects.
#'
#' @param multiple Output objects from calculate_roc_binary_classifier()
#' @return ggplot2 plot object
#' @export

plot_multiple_roc_from_list <- function(input_list) {
  plot_multiple_roc_impl(input_list)
}

# not exported, internal function
plot_multiple_roc_impl <- function (input_list) {
  plot_df <- data.frame(t(rep(NA,3)))
  names(plot_df) <- c("x","y","curve_label")

  for (roc_obj in input_list) {
    rocData <- roc_obj[["roc"]]
    curve <- roc_obj[["title"]]

    rocDataFrame <- data.frame(x=rocData@x.values[[1]],y=rocData@y.values[[1]],curve_label=curve)
    plot_df <- rbind(plot_df, rocDataFrame)
  }

  # remove the initializer of NA's from the data frame
  plot_df <- na.omit(plot_df)

  rocr.plot <- ggplot(data=plot_df, aes(x=x, y=y, color=curve_label), ) + geom_path(size=1)
  rocr.plot <- rocr.plot + coord_fixed() + labs(color="ROC Comparison")
  rocr.plot <- rocr.plot + xlab("False Positive Rate") + ylab("True Positive Rate")
  rocr.plot <- rocr.plot + geom_abline(intercept = 0, slope = 1, color="grey")
  rocr.plot <- rocr.plot + theme_pander()
  rocr.plot
}

#' @title train_randomforest
#' @description
#' Using the training and tuning function from the caret library, tune a random forest
#' model on the training fraction of a data frame, after excluding a set of columns.
#' Tuning occurs given the control and tuning grid objects passed, and the final fitted
#' object is returned along with the elapsed time, training and test data sets in a list.
#'
#'  @param data.frame the full data set, without splitting into train/test
#'  @param num the fraction of the data to use for training
#'  @param object A tuning grid object of the type used by the caret library (in this case a vector of mtry values)
#'  @param object A training control object of the type used by the caret library
#'  @param character A vector of the names of columns to exclude from the analysis
#'  @return list A list with the fitted result, the training and test data sets, and the elapsed time
#'  @export

train_randomforest <- function(df, training_fraction, class_field, tuning_grid, training_control, exclude) {
  retval <- list()
  df_excluded_fields <- df[,!(names(df) %in% exclude)]

  nonTestIndex <- createDataPartition(df_excluded_fields[[class_field]], p = training_fraction,
                                      list = FALSE,
                                      times = 1)

  df_train <- df_excluded_fields[ nonTestIndex,]
  df_test  <- df_excluded_fields[-nonTestIndex,]

  start_time <- proc.time()[["elapsed"]]

  fit <- train(two_class_label ~ ., data = df_train,
               method="rf",
               verbose=FALSE,
               trControl = training_control,
               tuneGrid = tuning_grid)

  end_time <- proc.time()[["elapsed"]]
  sampled_training_minutes <- (end_time - start_time) / 60

  retval <- list("test_data" = df_test, "train_data" = df_train, "tunedmodel" = fit, "elapsed" = sampled_training_minutes)

  retval
}

#' @title train_gbm_classifier
#' @description
#' Using the training and tuning function from the caret library, tune a random forest
#' model on the training fraction of a data frame, after excluding a set of columns.
#' Tuning occurs given the control and tuning grid objects passed, and the final fitted
#' object is returned along with the elapsed time, training and test data sets in a list.
#'
#'  @param data.frame the full data set, without splitting into train/test
#'  @param num the fraction of the data to use for training
#'  @param character the name of the column which contains true class labels
#'  @param object A tuning grid object of the type used by the caret library (in this case a vector of mtry values)
#'  @param object A training control object of the type used by the caret library
#'  @param character A vector of the names of columns to exclude from the analysis
#'  @return list A list with the fitted result, the training and test data sets, and the elapsed time
#'  @export

train_gbm_classifier <- function(df, training_fraction, class_field, tuning_grid, training_control, exclude, verbose = FALSE) {
  retval <- list()
  df_excluded_fields <- df[,!(names(df) %in% exclude)]

  nonTestIndex <- createDataPartition(df_excluded_fields[[class_field]], p = training_fraction,
                                      list = FALSE,
                                      times = 1)

  df_train <- df_excluded_fields[ nonTestIndex,]
  df_test  <- df_excluded_fields[-nonTestIndex,]

  form <- as.formula(paste(class_field, "~", ".", sep = " "))

  start_time <- proc.time()[["elapsed"]]

  fit <- train(form, data = df_train,
               method="gbm",
               trControl = training_control,
               tuneGrid = tuning_grid,
               verbose=verbose)

  end_time <- proc.time()[["elapsed"]]
  sampled_training_minutes <- (end_time - start_time) / 60

  retval <- list("test_data" = df_test, "train_data" = df_train, "tunedmodel" = fit, "elapsed" = sampled_training_minutes)

  retval
}

#' @title get_sorted_variable_importance
#' @description
#' Given a fitted model object from caret's train() method, this utility method
#' produces a properly sorted data frame with the predictor names in a column
#' rather than as row.names, renames the columns for use in publications, and sorts
#' by importance value in descending order.  The resulting data frame produces a
#' good table in pander() and other methods.
#'
#' @param model Fitted and tuned caret model object
#' @return data.frame Sorted and rectified variable importance table
#' @export

get_sorted_variable_importance <- function(model) {
  require(dplyr)
  varimp <- varImp(model)
  varimp_df <- varimp[["importance"]]
  varimp_df$Predictor <- row.names(varimp_df)
  names(varimp_df)[names(varimp_df)=="Overall"] <- "Importance"
  arrange(varimp_df, desc(Importance))
}

#' @title get_parsed_binary_confusion_matrix_stats
#' @description
#' Helper function which takes a caret package confusionMatrix object, created by
#' the confusionMatrix() function, and produces a single-row data frame with common variables
#' parsed from the object.  These include the overall misclassification rate (1-accuracy), accuracy,
#' Cohen's kappa, ppv and npv, sensitivity and specificity, and a field which indicates the "positive"
#' label for those stats which treat one label as a "positive identification".
#'
#' @param confusionMatrix Caret package confusionMatrix object, produced typically with test data
#' @return data.frame
#' @export

get_parsed_binary_confusion_matrix_stats <- function(cm) {
  total_n <- cm$table[[1]] + cm$table[[2]] + cm$table[[3]] + cm$table[[4]]
  misclassification_rate <- (cm$table[[2]] + cm$table[[3]]) / total_n

  stats <- list("misclassification_rate" = misclassification_rate,
                "accuracy" = cm$overall[["Accuracy"]],
                "kappa" = cm$overall[["Kappa"]],
                "ppv" = cm$byClass[["Pos Pred Value"]],
                "npv" = cm$byClass[["Neg Pred Value"]],
                "sensitivity" = cm$byClass[["Sensitivity"]],
                "specificity" = cm$byClass[["Specificity"]],
                "positive_label"= cm$positive)

  as.data.frame(stats)
}

calc_f1_impl <- function(cm) {
  f1 <- 2 * ((cm$byClass[["Pos Pred Value"]] * cm$byClass[["Sensitivity"]]) / (cm$byClass[["Pos Pred Value"]] + cm$byClass[["Sensitivity"]]))
  f1
}


#R script for running cartography analysis on the given network file. Here for F. graminearum network file.
#It can be adopted for a given connected component of the network given appropriate connected component network (edge) file is available

install.packages("rnetcarto")
library("rnetcarto")
fg<-read.csv("new_FGids.txt", header= FALSE, sep = "\t")
options(max.print =1000000); capture.output(netcarto(fg, seed = as.integer(floor(runif(1, 1, 100000001))), iterfac = 1, coolingfac = 0.995, bipartite = FALSE),file = "newFG_ids.out")


paper<-F                   # output on paper (=TRUE) or screen (=FALSE)
file.name<-'meanWeights'             # graphical output file if paper<-TRUE
Portrait<-F                 # graphical output orientation

first.year<- 1963                #first year on plot, negative value means value defined by data
last.year<- 2011                 #last year on plot
plotVar<-'weca'                  # plot wsea or weca
plotVar<-'west'                  # plot wsea or weca

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

cleanup()

if (paper) dev<-"wmf" else dev<-"screen"
nox<-1; noy<-1;
noxy<-nox*noy

dat<-Read.summary.data()

dat<-subset(dat,Year<=last.year,select=c(Year,Quarter,Species.n,Age,west,weca,C.obs))

if (first.year>0) dat<-subset(dat,Year>=first.year )
if (plotVar=="weca") {
  dat$w<-dat$west
  dat<-subset(dat,Quarter==1,select=c(Year,Species.n,Age,w))
} else {
  dat$CW<-dat$weca*dat$C.obs
  dat<-aggregate(list(cw=dat$CW,C=dat$C.obs),list(Year=dat$Year,Species.n=dat$Species.n,Age=dat$Age),sum)
  dat$w<-dat$cw/dat$C
  dat<-subset(dat,!is.na(w),select=c(Year,Species.n,Age,w))
}

for (sp in (first.VPA:nsp)){
    newplot(dev,nox,noy,filename=paste(file.name,'_',sp.names[sp],sep=''),Portrait=Portrait)
    par(mar=c(3,4,3,2))
    s<-subset(dat,Species.n==sp)
    minA<-min(s$Age)
    aa<-subset(s,Age==minA)
    plot(aa$Year,aa$w,ylim=c(0,max(s$w)),t='b',pch=minA,ylab='Weight (kg)',main=sp.names[sp])
    for (a in ((minA+1):SMS.control@species.info[sp,1])) {
       aa<-subset(s,Age==a)
       lines(aa$Year,aa$w,t='b',pch=a)
    }
}