# This code is for mapping North American hummingbird banding data from the Bird Banding
# Laboratory (BBL). Recapture data is available through 2013 and was last updated 11 April 2014.
# Miscellaneous old code at end (to be cleaned/deleted)
#(c) 2013 Marisa Lim, Stony Brook University

# required packages
require(maps)
require(geosphere)
require(raster)
require(ggplot2)

--------------------------------------------------------------------------------------------
# To Do:
# Clean up code
--------------------------------------------------------------------------------------------

# set working directory

wd = "C:/Users/mcwlim/Dropbox/NASA_Anusha/MarisaRAstuff/BBLrecapproj"
setwd(wd)

################# Updated BBL 11April2014 #################
BBLdat <- read.csv("11April14_BBLdata.csv", sep=",", header=T)
head(BBLdat)
names(BBLdat)
dim(BBLdat)

# First, let's clean up the data. Information that needs to be cleaned: (quick filter check of excel file shows that these need cleaning)
# 1. incorrect months of year (in ENCOUNTER_MONTH)
# 2. incorrect days of month (in ENCOUNTER_DAY)
# 3. unidentified species (in B_SPECIES_NAME)
# 4. missing lat/long information (in E_LAT_DECIMAL_DEGREES, E_LON_DECIMAL_DEGREES)

BBLdat1 <- subset(BBLdat, BBLdat$ENCOUNTER_MONTH <= 12)
BBLdat2 <- subset (BBLdat1, BBLdat1$ENCOUNTER_DAY <= 31)
BBLdat3 <- subset(BBLdat2, BBLdat2$B_SPECIES_NAME != "Unidentified Hummingbird")
BBLdat4 <- subset(BBLdat3, BBLdat3$E_LAT_DECIMAL_DEGREES != "NA")
dim(BBLdat4)

# based on 11April14 data, there were 28 entries removed, 1293 records used

# set extent
xlim <- c(-171.738281, -56.601563)
ylim <- c(8, 71.856229)
# set color for connecting lines
colors <- "#FF3300"

# maps of each species, banding and recapture points connected with a line
species <- unique(BBLdat4$B_SPECIES_NAME)
for(i in 1:length(species)){
  jpeg(paste("species_", species[i], ".jpg"), height=5, width=5, units="in", res=500)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- BBLdat4[BBLdat4$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  bandnums <- unique(birdies$BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.35)
  title(sub=paste("# unique birds = ", length(bandnums)), cex.sub=1.5, line=0.5)
  for(j in 1:nrow(birdies)){
    inter <- gcIntermediate(c(birdies[j,]$B_LON_DECIMAL_DEGREES, birdies[j,]$B_LAT_DECIMAL_DEGREES),
                            c(birdies[j,]$E_LON_DECIMAL_DEGREES, birdies[j,]$E_LAT_DECIMAL_DEGREES),
                            n=50, addStartEnd=TRUE,)
    lines(inter, col=colors, lwd=2)
    points(birdies$B_LAT_DECIMAL_DEGREES ~ birdies$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="black")
  }
  dev.off()
}

#--------------- plot rufous that are intially captured east of 103 (outside western flyway)
rufous <- BBLdat4[BBLdat4$B_SPECIES_NAME == "Rufous Hummingbird", ]
bands <- unique(rufous$BAND_NUM)
eastern <- rufous[rufous$B_LON_DECIMAL_DEGREES > -103,]
western <- rufous[rufous$B_LON_DECIMAL_DEGREES <= -103,]
alleast <- rufous[rufous$B_LON_DECIMAL_DEGREES > -103 & rufous$E_LON_DECIMAL_DEGREES > -103,]

#-------------- plot histogram of months rufous captured outside of Western Flyway
ggplot(alleast, aes(ENCOUNTER_MONTH)) + xlab("encounter month") +
  geom_histogram(fill = "grey40", col="black", binwidth=1) +
  theme_classic() + theme(text=element_text(size=20)) +
  scale_x_continuous(breaks = seq(1, 12, 2), limits = c(1,12))

#-------------- plot histogram of rufous captured outside of Western Flyway
ggplot(eastern, aes(BANDING_YEAR)) + ylab("Number birds banded") +
  xlab("Banding Year") + geom_histogram(fill = "grey40", col = "black", binwidth=1) +
  theme_classic() + theme(text=element_text(size=20), axis.text.x = element_text(angle = 60, hjust=1)) +
  scale_x_continuous(breaks = seq(1980, 2013, 5), limits = c(1980,2013))

#-------------- plot where these eastern captures went
plot(NA, NA, xlim=c(-170,-50), ylim=c(15,75), xlab="", ylab="", main = "Rufous Hummingbird recaptures")
for(k in 1:nrow(western)){
  if(western[k,]$E_LON_DECIMAL_DEGREES <= -103) { color = "black"}
  else { color = "indianred" }
  inter <- gcIntermediate(c(western[k,]$B_LON_DECIMAL_DEGREES, western[k,]$B_LAT_DECIMAL_DEGREES),
                          c(western[k,]$E_LON_DECIMAL_DEGREES, western[k,]$E_LAT_DECIMAL_DEGREES),
                          n=50, addStartEnd=TRUE,)
  lines(inter, col=color, lwd=2)
}
for(j in 1:nrow(eastern)){
  if(eastern[j,]$E_LON_DECIMAL_DEGREES > -103) { color = "cadetblue"}
  else { color = "indianred" }
  inter <- gcIntermediate(c(eastern[j,]$B_LON_DECIMAL_DEGREES, eastern[j,]$B_LAT_DECIMAL_DEGREES),
                          c(eastern[j,]$E_LON_DECIMAL_DEGREES, eastern[j,]$E_LAT_DECIMAL_DEGREES),
                          n=50, addStartEnd=TRUE,)
  lines(inter, col=color, lwd=2)
}
map("worldHires", c("usa", "canada", "mexico"), add=TRUE, cex = 0.5)

#--------------------------
#       plot black-chinned that are captured east of 103 (outside western flyway)
#--------------------------
bc <- BBLdat4[BBLdat4$B_SPECIES_NAME == "Black-chinned Hummingbird", ]
bands <- unique(bc$BAND_NUM)
eastern <- bc[bc$B_LON_DECIMAL_DEGREES > -103,]
western <- bc[bc$B_LON_DECIMAL_DEGREES <= -103,]
alleast <- bc[bc$B_LON_DECIMAL_DEGREES > -103 & bc$E_LON_DECIMAL_DEGREES > -103,]

#-------------- plot histogram of months bc captured outside of Western Flyway
ggplot(alleast, aes(ENCOUNTER_MONTH)) + xlab("encounter month") +
  geom_histogram(fill = "grey40", col="black", binwidth=1) +
  theme_classic() + theme(text=element_text(size=20)) +
  scale_x_continuous(breaks = seq(1, 12, 2), limits = c(1,12))

#-------------- plot histogram of bc captured outside of Western Flyway
ggplot(eastern, aes(BANDING_YEAR)) + ylab("Number birds banded") +
  xlab("Banding Year") + geom_histogram(fill = "grey40", col = "black", binwidth=1) +
  theme_classic() + theme(text=element_text(size=20), axis.text.x = element_text(angle = 60, hjust=1)) +
  scale_x_continuous(breaks = seq(1980, 2013, 5), limits = c(1980,2013))

#-------------- plot where these eastern captures went
plot(NA, NA, xlim=c(-130,-60), ylim=c(15,50), xlab="", ylab="", main = "Black-chinned Hummingbird recaptures")
for(k in 1:nrow(western)){
  if(western[k,]$E_LON_DECIMAL_DEGREES <= -103) { color = "black"}
  else { color = "indianred" }
  inter <- gcIntermediate(c(western[k,]$B_LON_DECIMAL_DEGREES, western[k,]$B_LAT_DECIMAL_DEGREES),
                          c(western[k,]$E_LON_DECIMAL_DEGREES, western[k,]$E_LAT_DECIMAL_DEGREES),
                          n=50, addStartEnd=TRUE,)
  lines(inter, col=color, lwd=2)
}
for(j in 1:nrow(eastern)){
  if(eastern[j,]$E_LON_DECIMAL_DEGREES > -103) { color = "cadetblue"}
  else { color = "indianred" }
  inter <- gcIntermediate(c(eastern[j,]$B_LON_DECIMAL_DEGREES, eastern[j,]$B_LAT_DECIMAL_DEGREES),
                          c(eastern[j,]$E_LON_DECIMAL_DEGREES, eastern[j,]$E_LAT_DECIMAL_DEGREES),
                          n=50, addStartEnd=TRUE,)
  lines(inter, col=color, lwd=2)
}
map("worldHires", c("usa", "mexico"), add=TRUE, cex = 0.5)

#--------------------------------------------------------------------------------------

################# Test data with time, connections, sex, and age #################

humtest <- read.csv("humtest27aug.csv", sep=",", header=T)
humtest <- humtest[order(humtest$B_SPECIES_NAME, humtest$B_BAND_NUM, humtest$BANDING_YEAR, humtest$BANDING_MONTH, humtest$BANDING_DATE),]
head(humtest)
names(humtest)
dim(humtest)

# set extent
xlim <- c(-171.738281, -56.601563)
ylim <- c(8, 71.856229)
# set color for connecting lines
colors <- "#FF3300"

# maps of each species, banding and recapture points connected with a line
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("species_", species[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  bandnums <- unique(birdies$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  for(j in 1:nrow(birdies)){
    inter <- gcIntermediate(c(birdies[j,]$B_LON_DECIMAL_DEGREES, birdies[j,]$B_LAT_DECIMAL_DEGREES),
                            c(birdies[j,]$E_LON_DECIMAL_DEGREES, birdies[j,]$E_LAT_DECIMAL_DEGREES),
                            n=50, addStartEnd=TRUE,)
    lines(inter, col=colors, lwd=2)
    points(birdies$B_LAT_DECIMAL_DEGREES ~ birdies$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="black")  }
  dev.off()
}

# maps of each species, points colored by sex (classes are defined as female or male)
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("Sp_", species[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
  females <- birdies[birdies$B_SEX_CODE == "5" | birdies$B_SEX_CODE == "7", ]
  males <- birdies[birdies$B_SEX_CODE == "4" | birdies$B_SEX_CODE == "6", ]
  points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="red")
  points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="blue")
  legend("left", ncol=2, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=20, cex=1, col=c("red", "blue"), c("Female", "Male"))
  title(main=species[i])
  dev.off()
}

# maps connecting recaptures, with 1st banding and recapture in same row and,
# unique individuals (male or female) are marked as points, they are shown for the original banding location only
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("species_", species[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  bandnums <- unique(birdies$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  for(j in 1:nrow(birdies)){
    inter <- gcIntermediate(c(birdies[j,]$B_LON_DECIMAL_DEGREES, birdies[j,]$B_LAT_DECIMAL_DEGREES),
                            c(birdies[j,]$E_LON_DECIMAL_DEGREES, birdies[j,]$E_LAT_DECIMAL_DEGREES),
                            n=50, addStartEnd=TRUE,)
    lines(inter, col=colors, lwd=2)
    females <- birdies[birdies$B_SEX_CODE == "5" | birdies$B_SEX_CODE == "7", ]
    points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="red")
    males <- birdies[birdies$B_SEX_CODE == "4" | birdies$B_SEX_CODE == "6", ]
    points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="blue")
  }
  dev.off()
}

# mapping males and females with the lines, separately
# Males only.
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("species_", species[i], "_m", ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  males <- birdies[birdies$B_SEX_CODE == "4" | birdies$B_SEX_CODE == "6", ] #all rows for a specificed sex
  bandnums <- unique(males$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="blue")
  for(j in 1:nrow(males)){
    if(nrow(males) != 0){
      inter <- gcIntermediate(c(males[j,]$B_LON_DECIMAL_DEGREES, males[j,]$B_LAT_DECIMAL_DEGREES),
                              c(males[j,]$E_LON_DECIMAL_DEGREES, males[j,]$E_LAT_DECIMAL_DEGREES),
                              n=50, addStartEnd=TRUE,)
      lines(inter, col=colors, lwd=0.5)
    }
  }
  dev.off()
}
# Females only.
# note: had to add the if statement because some species have no female records
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("species_", species[i], "_f", ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  females <- birdies[birdies$B_SEX_CODE == "5" | birdies$B_SEX_CODE == "7", ] #all rows for a specificed sex
  bandnums <- unique(females$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=1, col="red")
  for(j in 1:nrow(females)){
    if(nrow(females) != 0){
      inter <- gcIntermediate(c(females[j,]$B_LON_DECIMAL_DEGREES, females[j,]$B_LAT_DECIMAL_DEGREES),
                              c(females[j,]$E_LON_DECIMAL_DEGREES, females[j,]$E_LAT_DECIMAL_DEGREES),
                              n=50, addStartEnd=TRUE,)
      lines(inter, col=colors, lwd=0.5)
    }
  }
  dev.off()
}

# age data
# Males and age
species <- unique(humtest$B_SPECIES_NAME)

for(i in 1:length(species)){
  pdf(paste("species_", species[i], "_m", ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  males <- birdies[birdies$B_SEX_CODE == "4" | birdies$B_SEX_CODE == "6", ] #all rows for a specificed sex
  males <- males[order(males$B_AGE_CODE), ]
  bandnums <- unique(males$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  for(j in 1:nrow(males)){
    if(nrow(males) != 0){
      inter <- gcIntermediate(c(males[j,]$B_LON_DECIMAL_DEGREES, males[j,]$B_LAT_DECIMAL_DEGREES),
                              c(males[j,]$E_LON_DECIMAL_DEGREES, males[j,]$E_LAT_DECIMAL_DEGREES),
                              n=50, addStartEnd=TRUE,)
      lines(inter, col=colors, lwd=0.5)
      ages <- unique(males$B_AGE_CODE)
      points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=ages, col="blue")
      legend("left", col="blue", pch=ages, legend=ages, bg="whitesmoke")
    }
  }
  dev.off()
}
# Females & age
# note: had to add the if statement because some species have no female records
species <- unique(humtest$B_SPECIES_NAME)
for(i in 1:length(species)){
  pdf(paste("species_", species[i], "_f", ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=T, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  females <- birdies[birdies$B_SEX_CODE == "5" | birdies$B_SEX_CODE == "7", ] #all rows for a specificed sex
  females <- females[order(females$B_AGE_CODE), ]
  bandnums <- unique(females$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  for(j in 1:nrow(females)){
    if(nrow(females) != 0){
      inter <- gcIntermediate(c(females[j,]$B_LON_DECIMAL_DEGREES, females[j,]$B_LAT_DECIMAL_DEGREES),
                              c(females[j,]$E_LON_DECIMAL_DEGREES, females[j,]$E_LAT_DECIMAL_DEGREES),
                              n=50, addStartEnd=TRUE,)
      lines(inter, col=colors, lwd=0.5)
      ages <- unique(females$B_AGE_CODE)
      points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=ages, col="red")
      legend("left", col="red", pch=ages, legend=ages, bg="whitesmoke")
    }
  }
  dev.off()
}

# For RUHU: showing how points change within year, can track the migration pattern, also showing ages
RUHU <- humtest[humtest$B_SPECIES_NAME == "RUFOUS HUMMINGBIRD", ]
RUHUorder <- RUHU[order(RUHU$BANDING_MONTH), ]
RUHUmonth <- unique(RUHUorder$BANDING_MONTH)
for(i in 1:length(RUHUmonth)){
  pdf(paste("Month_", RUHUmonth[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  title(main=RUHUmonth[i])
  mopts <- RUHU[RUHU$BANDING_MONTH == RUHUmonth[i], ]
  mopts <- mopts[order(mopts$B_AGE_CODE), ]
  ages <- unique(mopts$B_AGE_CODE)
  points(mopts$B_LAT_DECIMAL_DEGREES ~ mopts$B_LON_DECIMAL_DEGREES, col="black", cex=1, pch=ages)
  legend("left", col="black", pch=ages, legend=ages, bg="whitesmoke")
  dev.off()
}

# For RUHU: same as above, but adding points to show male vs. female - is there a difference in timing of migration between the sexes?
RUHU <- humtest[humtest$B_SPECIES_NAME == "RUFOUS HUMMINGBIRD", ]
RUHUorder <- RUHU[order(RUHU$BANDING_MONTH), ]
RUHUmonth <- unique(RUHUorder$BANDING_MONTH)
for(i in 1:length(RUHUmonth)){
  pdf(paste("Month_", RUHUmonth[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  title(main=RUHUmonth[i])
  mopts <- RUHU[RUHU$BANDING_MONTH == RUHUmonth[i], ]
  mopts <- mopts[order(mopts$B_AGE_CODE), ]
  ages <- unique(mopts$B_AGE_CODE)
  females <- mopts[mopts$B_SEX_CODE == "5" | mopts$B_SEX_CODE == "7", ]
  males <- mopts[mopts$B_SEX_CODE == "4" | mopts$B_SEX_CODE == "6", ]
  points(mopts$B_LAT_DECIMAL_DEGREES ~ mopts$B_LON_DECIMAL_DEGREES, col="black", cex=1, pch=ages)
  points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="red")
  points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="blue")
  legend("left", col="black", pch=ages, legend=ages, bg="whitesmoke")
  dev.off()
}

# maps for each species by month (pts are colored by sex and shaped by age)
species <- unique(humtest$B_SPECIES_NAME)
hummonth <- unique(humtest$BANDING_MONTH)
for(i in 1:length(species)){
  birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
  for(j in 1:length(hummonth)){
    pdf(paste("Sp_", species[i], "_Month_", hummonth[j], ".pdf", sep=""), width=11, height=7)
    map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
    title(main=hummonth[j])
    mopts <- birdies[birdies$BANDING_MONTH == hummonth[j], ]
    mopts <- mopts[order(mopts$B_AGE_CODE), ]
    females <- mopts[mopts$B_SEX_CODE == "5" | mopts$B_SEX_CODE == "7", ]
    males <- mopts[mopts$B_SEX_CODE == "4" | mopts$B_SEX_CODE == "6", ]
    points(females$B_LAT_DECIMAL_DEGREES ~ females$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="red")
    points(males$B_LAT_DECIMAL_DEGREES ~ males$B_LON_DECIMAL_DEGREES, cex=1, pch=20, col="blue")
    ages <- unique(mopts$B_AGE_CODE)
    if(length(ages) != 0){
      points(mopts$B_LAT_DECIMAL_DEGREES ~ mopts$B_LON_DECIMAL_DEGREES, col="black", cex=1, pch=ages)
      colors <- c(rep("black", length(ages)), "red", "blue")
      legend("left", col=colors, pch=c(ages, 20, 20), legend=c(ages, "Female", "Male"), bg="whitesmoke")
      }
    dev.off()
  }
}

# by year for RUHU, RTHU, BCHU - where banded and recap'ed in same year
# pattern with el nino years? are hummers doing something different in each year?
colors <- rainbow(12, start=0.4, end=1, alpha=0.8)
BCHUpts <- humtest[humtest$B_SPECIES_NAME == "BLACK-CHINNED HUMMINGBIRD", ]
BCHUpts <- BCHUpts[order(BCHUpts$BANDING_YEAR), ]
# new df of all birds that were recaptured in the same year that they were banded
BCHUpts <- BCHUpts[BCHUpts$BANDING_YEAR == BCHUpts$ENCOUNTER_YEAR, ]
BCHUyr <- unique(BCHUpts$BANDING_YEAR)
for(i in 1:length(BCHUyr)){
  yrpts <- BCHUpts[BCHUpts$BANDING_YEAR == BCHUyr[i], ]
  pdf(paste("BCHU_", BCHUyr[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  title(main=BCHUyr[i])
  for(j in 1:nrow(yrpts)){
    inter <- gcIntermediate(c(yrpts[j,]$B_LON_DECIMAL_DEGREES, yrpts[j,]$B_LAT_DECIMAL_DEGREES),
                          c(yrpts[j,]$E_LON_DECIMAL_DEGREES, yrpts[j,]$E_LAT_DECIMAL_DEGREES),
                          n=50, addStartEnd=TRUE,)
  lines(inter, col="#FF3300", lwd=2)
  points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, col="black", bg=colors, cex=1.5, pch=21)
  legend("left", ncol=4, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=21, cex=1, col="black", pt.bg=colors, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
  }
  dev.off()
}
RUHUpts <- humtest[humtest$B_SPECIES_NAME == "RUFOUS HUMMINGBIRD", ]
RUHUpts <- RUHUpts[order(RUHUpts$BANDING_YEAR), ]
RUHUpts <- RUHUpts[RUHUpts$BANDING_YEAR == RUHUpts$ENCOUNTER_YEAR, ]
RUHUyr <- unique(RUHUpts$BANDING_YEAR)
for(i in 1:length(RUHUyr)){
  yrpts <- RUHUpts[RUHUpts$BANDING_YEAR == RUHUyr[i], ]
  pdf(paste("RUHU_", RUHUyr[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  title(main=RUHUyr[i])
  for(j in 1:nrow(yrpts)){
    inter <- gcIntermediate(c(yrpts[j,]$B_LON_DECIMAL_DEGREES, yrpts[j,]$B_LAT_DECIMAL_DEGREES),
                            c(yrpts[j,]$E_LON_DECIMAL_DEGREES, yrpts[j,]$E_LAT_DECIMAL_DEGREES),
                            n=50, addStartEnd=TRUE,)
    lines(inter, col="#FF3300", lwd=2)
    points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, col="black", bg=colors, cex=1.5, pch=21)
    legend("left", ncol=4, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=21, cex=1, col="black", pt.bg=colors, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
  }
  dev.off()
}
RTHUpts <- humtest[humtest$B_SPECIES_NAME == "RUBY-THROATED HUMMINGBIRD", ]
RTHUpts <- RTHUpts[order(RTHUpts$BANDING_YEAR), ]
RTHUpts <- RTHUpts[RTHUpts$BANDING_YEAR == RTHUpts$ENCOUNTER_YEAR, ]
RTHUyr <- unique(RTHUpts$BANDING_YEAR)
for(i in 1:length(RTHUyr)){
  yrpts <- RTHUpts[RTHUpts$BANDING_YEAR == RTHUyr[i], ]
  pdf(paste("RTHU_", RTHUyr[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  title(main=RTHUyr[i])
  for(j in 1:nrow(yrpts)){
    inter <- gcIntermediate(c(yrpts[j,]$B_LON_DECIMAL_DEGREES, yrpts[j,]$B_LAT_DECIMAL_DEGREES),
                            c(yrpts[j,]$E_LON_DECIMAL_DEGREES, yrpts[j,]$E_LAT_DECIMAL_DEGREES),
                            n=50, addStartEnd=TRUE,)
    lines(inter, col="#FF3300", lwd=2)
    points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, col="black", bg=colors, cex=1.5, pch=21)
    legend("left", ncol=4, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=21, cex=1, col="black", pt.bg=colors, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
  }
  dev.off()
}

################# BBL basic metrics of the data #################
# counting number of individuals, females, males, and juveniles per species
numbers <- function(){
  indiv.v <- c()
  species <- unique(humtest$B_SPECIES_NAME)
  for(i in 1:length(species)){
    birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
    indivs <- length(unique(birdies$B_BAND_NUM))
    indiv.v[i] <- indivs
  }
  fem.v <- c()
  for(i in 1:length(species)){
    birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
    females <- birdies[birdies$B_SEX_CODE == "5" | birdies$B_SEX_CODE == "7", ]
    females <- length(unique(females$B_BAND_NUM))
    fem.v[i] <- females
  }
  male.v <- c()
  for(i in 1:length(species)){
    birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
    males <- birdies[birdies$B_SEX_CODE == "4" | birdies$B_SEX_CODE == "6", ]
    males <- length(unique(males$B_BAND_NUM))
    male.v[i] <- males
  }
  #assuming juveniles are AHY, HY, or J
  juv.v <- c()
  for(i in 1:length(species)){
    birdies <- humtest[humtest$B_SPECIES_NAME == species[i], ]
    juvs <- birdies[birdies$B_AGE_CODE == "1" | birdies$B_AGE_CODE == "2" | birdies$B_AGE_CODE == "3", ]
    juvs <- length(unique(juvs$B_BAND_NUM))
    juv.v[i] <- juvs
  }
  allnums <- data.frame(species, indiv.v, fem.v, male.v, juv.v)
  write.table(allnums, file="24sep13_BBLdata.csv", sep=",")
}
numbers()

# calculating the distance between points in km, Euclidian distance
A <- SpatialPointsDataFrame(coords=cbind(humtest$B_LON_DECIMAL_DEGREES,humtest$B_LAT_DECIMAL_DEGREES),humtest)
B <- SpatialPointsDataFrame(coords=cbind(humtest$E_LON_DECIMAL_DEGREES,humtest$E_LAT_DECIMAL_DEGREES),humtest)
distances <- pointDistance(A, B, longlat=TRUE)/1000 # /1000 to get km instead of meters
hist(distances, col="plum4")
newhumtest <- data.frame(A, distances)
newhumtest2 <- data.frame(humtest, distances)

distcalcs <- function(){
  species <- unique(newhumtest2$B_SPECIES_NAME)
  meandist.v <- c()
  sddist.v <- c()
  meddist.v <- c()
  rangedist.m <- matrix(nrow=14, ncol=2)
  for(i in 1:length(species)){
    birdies <- newhumtest2[newhumtest2$B_SPECIES_NAME == species[i], ]
    #for each species, i want to calculate the mean distance, sd, median + include the range of values
    meandist <- mean(birdies$distances)
    sddist <- sd(birdies$distances)
    meddist <- median(birdies$distances)
    rangedist <- range(birdies$distances)
    meandist.v[i] <- meandist
    sddist.v[i] <- sddist
    meddist.v[i] <- meddist
    rangedist.m[i, ] <- rangedist
  }
  allcalcs <- data.frame(meandist.v, sddist.v, meddist.v, rangedist.m)
  write.table(allcalcs, file="25sep13_distcalcs.csv", sep=",")
}

distcalcs()

################# SDM test code #################
# not working yet
hum.sp<-SpatialPointsDataFrame(coords=cbind(humtest$B_LON_DECIMAL_DEGREES,humtest$B_LAT_DECIMAL_DEGREES),humtest)

require(dismo)
USA<-getData('GADM', country='USA', level=1)

plot(USA)

require(raster)
u<-raster()
r<-rasterize(USA,u)
plot(r)
r[r>0]<-1
plot(r)
plot(r,ext=extent(hum.sp))
points(hum.sp)

predictors <- stack(list.files(path=paste(system.file(package="dismo"), '/ex', sep=''),
                               pattern='grd', full.names=TRUE ))
me<-maxent(predictors,hum.sp)

################# OLD/test code for recap connections by species #################
# need to clean up/delete?

library(maps)
library(geosphere)
library(adegenet)

xlim <- c(-171.738281, -56.601563)
ylim <- c(8, 71.856229)

allhum <- read.csv("testhummerdata.csv", sep=",", header=TRUE)
names(allhum)
head(allhum)
allhum2 <- data.frame(allhum[,1:9]) #allhum has 6 empty columns for some reason, got rid of here
head(allhum2)
#putting data in order by species, bandnumber, year, month, and then day
allhum2 <- allhum2[order(allhum2$B_SPECIES_NAME, allhum2$B_BAND_NUM, allhum2$BANDING_YEAR, allhum2$BANDING_MONTH, allhum2$BANDING_DATE), ]
head(allhum2)
species <- unique(allhum2$B_SPECIES_NAME)
colors <- "#FF3300"
# pal <- colorRampPalette(c("orange", "green"))
# colors <- pal(50)

# ##test plotting of datapoints by species
# plot.new()
# map("world", xlim=xlim, ylim=ylim, col="whitesmoke", fill=T, bg="azure3", lwd=0.05)
# birdies <- allhum2[allhum2$B_SPECIES_NAME == species[11], ]
# points(birdies$B_LAT_DECIMAL_DEGREES ~ birdies$B_LON_DECIMAL_DEGREES, cex=2, col="red", pch=20)

for(i in 1:length(species)){
  pdf(paste("species_", species[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  birdies <- allhum2[allhum2$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
  bandnums <- unique(birdies$B_BAND_NUM)
  par(adj=0.5)
  title(main=species[i], col.main="black")
  par(adj=0.55)
  title(sub=length(bandnums), cex.sub=1.5, line=0.5)
  par(adj=0.35)
  title(sub="# unique birds =", line=0.5, cex.sub=1.5)
  for(j in 1:length(bandnums)){
    bird <- subset(birdies, B_BAND_NUM == bandnums[j])
    #     bird <- bird[order(bird$BANDING_DATE), ] #how does R read dates?
    for(k in 1:nrow(bird)){
      if((k+1) <= nrow(bird)){
        temp <- bird[k:(k+1), ]
        inter <- gcIntermediate(c(temp[1,]$B_LON_DECIMAL_DEGREES, temp[1,]$B_LAT_DECIMAL_DEGREES),
                                c(temp[2,]$B_LON_DECIMAL_DEGREES, temp[2,]$B_LAT_DECIMAL_DEGREES),
                                n=50, addStartEnd=TRUE, )
        lines(inter, col=colors, lwd=2)
      }
    }
  }
  dev.off()
}

#new code gets rid of this: Error in if (antipodal(p1, p2)) { : missing value where TRUE/FALSE needed

#code below goes through individual species at a time for recap maps
ALHU <- allhum2[allhum2$B_SPECIES_NAME == "ALLEN'S HUMMINGBIRD", ] #df with just data for Allen's hbird
ANHU <- allhum2[allhum2$B_SPECIES_NAME == "ANNA'S HUMMINGBIRD", ]
BCHU <- allhum2[allhum2$B_SPECIES_NAME == "BLACK-CHINNED HUMMINGBIRD", ]
BLUH <- allhum2[allhum2$B_SPECIES_NAME == "BLUE-THROATED HUMMINGBIRD", ]
BBLH <- allhum2[allhum2$B_SPECIES_NAME == "BROAD-BILLED HUMMINGBIRD", ]
BTLH <- allhum2[allhum2$B_SPECIES_NAME == "BROAD-TAILED HUMMINGBIRD", ] #problematic
BUFH <- allhum2[allhum2$B_SPECIES_NAME == "BUFF-BELLIED HUMMINGBIRD", ]
CAHU <- allhum2[allhum2$B_SPECIES_NAME == "CALLIOPE HUMMINGBIRD", ]
COHU <- allhum2[allhum2$B_SPECIES_NAME == "COSTA'S HUMMINGBIRD", ]
MAHU <- allhum2[allhum2$B_SPECIES_NAME == "MAGNIFICENT HUMMINGBIRD", ]
RTHU <- allhum2[allhum2$B_SPECIES_NAME == "RUBY-THROATED HUMMINGBIRD", ] #problematic
RUHU <- allhum2[allhum2$B_SPECIES_NAME == "RUFOUS HUMMINGBIRD", ]
VCHU <- allhum2[allhum2$B_SPECIES_NAME == "VIOLET-CROWNED HUMMINGBIRD", ]
WEHU <- allhum2[allhum2$B_SPECIES_NAME == "WHITE-EARED HUMMINGBIRD", ]

# prints out the number of samples/species
for(i in 1:length(species)){
  birdies <- allhum2[allhum2$B_SPECIES_NAME == species[i], ]
  bands <- unique(birdies$B_BAND_NUM)
  print(length(bands))
}

#returns rows with same band number -> so it shows the original and recapture
# bird1 <- allhum2[allhum2$B_BAND_NUM == allens[20, ]$B_BAND_NUM, ]

#tutorial testdrive data
# plot.new()
# map("world", col="#f2f2f2", fill=TRUE, bg="white", lwd=0.05, xlim=xlim, ylim=ylim)
#
# allenslato <- 37.91667
# allenslongo <- -122.75
# allenslatr <- 29.00
# allenslongr <- -120.00
# inter <- gcIntermediate(c(allenslongo, allenslato), c(allenslongr, allenslatr), n=50, addStartEnd=TRUE)
# lines(inter, col="green")
# lat_tx <- 29.954935
# lon_tx <- -98.701172
# inter2 <- gcIntermediate(c(allenslongo, allenslato), c(lon_tx, lat_tx), n=50, addStartEnd=TRUE)
# lines(inter2, col="red")
# inter3 <- gcIntermediate(c(allenslongr, allenslatr), c(lon_tx, lat_tx), n=50, addStartEnd=TRUE)
# lines(inter3, col="blue")

############################### Old temporal data by species code
# all points
plot.new()
map("world", col="#f2f2f2", fill=TRUE, bg="steelblue", lwd=0.05, xlim=xlim, ylim=ylim)
points(allhum2$B_LAT_DECIMAL_DEGREES ~ allhum2$B_LON_DECIMAL_DEGREES, pch=20, cex=0.5)

# pal <- colorRampPalette(c("orange", "blue"))
# colors <- pal(14)
# plot.new()
# map("world", col="#f2f2f2", fill=TRUE, bg="steelblue", lwd=0.05, xlim=xlim, ylim=ylim)
# points(RUHU$B_LAT_DECIMAL_DEGREES ~ RUHU$B_LON_DECIMAL_DEGREES, pch=20, cex=1, col=transp(colors))

#maps out points by species, colors by month
# birdyears <- unique(birdies$BANDING_YEAR)
# for(i in 1:length(species)){
#   pdf(paste("species_", species[i], ".pdf", sep=""), width=11, height=7)
#   map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
#   birdies <- allhum2[allhum2$B_SPECIES_NAME == species[i], ] #all rows for a specified species i
#   par(adj=0.5)
#   title(main=species[i], col.main="black")
# #   legend("bottomleft", ncol=2, y.intersp=0.8, x.intersp=0.4, xjust=0, bg="whitesmoke", col=birdies$BANDING_MONTH, pch=20, cex=2, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
#   for(j in 1:length(birdyears)){
#     bird <- subset(birdies, BANDING_YEAR == birdyears[j])
#     points(birdies$B_LAT_DECIMAL_DEGREES ~ birdies$B_LON_DECIMAL_DEGREES, col=birdies$BANDING_MONTH, cex=1.5, pch=21)
#   }
#   dev.off()
# }

# pal <- colorRampPalette(c("orange", "blue"))
# colors <- pal(12)

#loop goes through each species and plots all points for unique years of data of that species
plot.new()
species <- unique(allhum2$B_SPECIES_NAME)
colors <- rainbow(12, start=0.4, end=1, alpha=0.8)
for(i in 1:length(species)){
  birdies <- allhum2[allhum2$B_SPECIES_NAME == species[i], ]
  birdyears <- unique(birdies$BANDING_YEAR)
  for(j in 1:length(birdyears)){
    yrpts <- birdies[birdies$BANDING_YEAR == birdyears[j], ]
    pdf(paste("Sp_", species[i], "_Year_", birdyears[j], ".pdf", sep=""), width=11, height=7)
    map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
    points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, cex=1.5, pch=20, col=colors)
    title(main=birdyears[j])
    legend("left", ncol=4, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=21, cex=1, col="black", pt.bg=colors, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
    dev.off()
  }
}

#for one species at a time
plot.new()
RUHUorder <- RUHU[order(RUHU$BANDING_YEAR), ]
RUHUyears <- unique(RUHUorder$BANDING_YEAR)
for(i in 1:length(RUHUyears)){
  yrpts <- RUHU[RUHU$BANDING_YEAR == RUHUyears[i], ]
  pdf(paste("Year_", RUHUyears[i], ".pdf", sep=""), width=11, height=7)
  map("world", col="whitesmoke", fill=TRUE, bg="azure3", lwd=0.05, xlim=xlim, ylim=ylim)
  points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, col=colors, cex=1.5, pch=20)
  title(main=RUHUyears[i])
  legend("left", ncol=4, y.intersp=1, x.intersp=0.5, xjust=0, bg="whitesmoke", pch=21, cex=1, col="black", pt.bg=colors, c("J", "F", "M", "A", "M", "J", "J", "A", "S", "O", "N", "D"))
  dev.off()
}

#manual way of plotting different years, have to change ALHUyears number
plot.new()
map("world", xlim=xlim, ylim=ylim)
yrpts <- ALHU[ALHU$BANDING_YEAR == ALHUyears[4], ]
points(yrpts$B_LAT_DECIMAL_DEGREES ~ yrpts$B_LON_DECIMAL_DEGREES, col="pink", cex=1.5, pch=20)


#!/usr/bin/Rscript

args = commandArgs(TRUE)
data = read.csv(args[1],sep = ',', dec = '.',  header = TRUE, stringsAsFactors = FALSE)

frame = data.frame(data)
frame$Fitness <- as.numeric(frame$Fitness)
frame$Generation <- as.numeric(frame$Generation)

png('result.png', width = 1024)
boxplot(Fitness ~ Generation, frame)
dev.off()

dev.new()
png('result-victories-scatter.png', width = 1024)
plot(frame$Generation, frame$Fitness, col=frame$Victory+2, ylab="Victories", xlab = "Generations")
dev.off()

dev.new()
png('result-victories.png', width = 1024)
plot(aggregate(frame$Victory, by=list(frame$Generation), FUN=sum), ylab="Victories", xlab = "Generations")
dev.off()


###################################################################
#
# Mark Cembrowski, Janelia Research Campus, Nov 11 2016
#
# This single-serving script plots the results of looking for
# barcoded genes across all hippocampal populations.
#
###################################################################

geneBar125Heatmap <- function(label=F){
	# Identify probes that are part of pop'n RNA-seq dataset.
	probesInPop <- genesBar125%in%unlist(idToSym(rownames(fpkmPoolMat)))

	# Extract these genes.
	probesInPop <- genesBar125[probesInPop]

	# Get maximum FPKM values for these genes.
	maxFpkm <- apply(subFpkmMatrix(probesInPop),1,max)

	# Sort by FPKM.
	maxSort <- probesInPop[order(maxFpkm)]

	# Plot.
	fpkmHeatmap(maxSort,rMax=10,label=label)
}


library(testthat)
library(digest)

test_1 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg1$coefficients[1], 3)), "56f04106b0d09f24d95010b891573eea")
  })
  print("Success!")
}

test_2 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg2$coefficients[1], 3)), "a4dd2bedaafa1f6b52eb1e6b4820fbde")
  })
  print("Success!")
}

test_3 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg3$coefficients[1], 3)), "f02741b40f9113aeb5a5e87fb9b2ab23")
  })
  print("Success!")
}

test_4 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg4$coefficients[1], 3)), "f02741b40f9113aeb5a5e87fb9b2ab23")
  })
  print("Success!")
}

test_5 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(reg5$residuals[1], 3)), "02cba6d8393bb07ad6a077228a380f34")
  })
  print("Success!")
}

test_6 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(census_data$resid[1], 3)), "bbfd349bb38017dca76e637fb2dc5373")
  })
  print("Success!")
}

test_7 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(WT$coefficients[1], 2)), "0da67aa7287597c3912d21e461eb1e44")
  })
  print("Success!")
}

test_8 <- function() {
  test_that("Solution is incorrect", {
    expect_equal(digest(round(BPstat,1)), "b5063b59d220cc2a6d8e7a6a56eb9568")
  })
  print("Success!")
}


#' Split array, apply function, and return results in an array.
#'
#' For each slice of an array, apply function, keeping results as an array.
#'
#' This function is very similar to \code{\link{apply}}, except that it will
#' always return an array, and when the function returns >1 d data structures,
#' those dimensions are added on to the highest dimensions, rather than the
#' lowest dimensions.  This makes \code{aaply} idempotent, so that
#' \code{aaply(input, X, identity)} is equivalent to \code{aperm(input, X)}.
#'
#' @section Warning:Passing a data frame as first argument may lead to
#' unexpected results, see \url{https://github.com/hadley/plyr/issues/212}.
#'
#' @template ply
#' @template a-
#' @template -a
#' @export
#' @examples
#' dim(ozone)
#' aaply(ozone, 1, mean)
#' aaply(ozone, 1, mean, .drop = FALSE)
#' aaply(ozone, 3, mean)
#' aaply(ozone, c(1,2), mean)
#'
#' dim(aaply(ozone, c(1,2), mean))
#' dim(aaply(ozone, c(1,2), mean, .drop = FALSE))
#'
#' aaply(ozone, 1, each(min, max))
#' aaply(ozone, 3, each(min, max))
#'
#' standardise <- function(x) (x - min(x)) / (max(x) - min(x))
#' aaply(ozone, 3, standardise)
#' aaply(ozone, 1:2, standardise)
#'
#' aaply(ozone, 1:2, diff)
aaply <- function(.data, .margins, .fun = NULL, ..., .expand = TRUE,
                  .progress = "none", .inform = FALSE, .drop = TRUE,
                  .parallel = FALSE, .paropts = NULL) {
  pieces <- splitter_a(.data, .margins, .expand)

  laply(.data = pieces, .fun = .fun, ...,
    .progress = .progress, .inform = .inform, .drop = .drop,
    .parallel = .parallel, .paropts = .paropts)
}


folder <- "E:\\ML_Samples_new_2\\features"
all_features <- read_features_performance(folder = folder, sample_size = 250)
all_features <- make_median_artificial(all_features)
all_features <- make_balanced(all_features)

best_data <- table(as.factor(all_features$best))
#folder <- "E:\\gecco_ml_samples_new\\features"
folder <- "E:\\gecco_ml_samples\\features"
coco_features <- read_features_performance_coco(folder = folder, sample_size = 250)
coco_features <- make_median_coco(coco_features)
coco_features <- as.data.frame(coco_features$data)

cnames <- colnames(coco_features)
cnames <- str_remove(cnames, "data.")
colnames(coco_features)<-cnames

best_coco_multiple <- readMat("E:\\matlab_results\\10\\all_best5.mat")$allBest
best_coco <- best_coco_multiple[,1]
best_coco_multiple <- transform_best_coco(best_coco_multiple)

algs <- c("ABC","ACO","CMAES","CSO","DE","FEP","GA","PSO","SA","Rand")
best_coco <- algs[best_coco]

combined_cols <- intersect(colnames(all_features$data), colnames(coco_features))

all_features$data <- all_features$data[,combined_cols]
coco_features <- coco_features[,combined_cols]
all_features$data <- rbind(all_features$data, coco_features)
all_features$best <- c(all_features$best, best_coco)

total = nrow(all_features$data)

X_temp <- all_features$data[1:total,]
best <- all_features$best[1:total]

X_temp <- as.data.frame(X_temp)
X_temp$basic.objective_min <- NULL
X_temp$basic.objective_max <- NULL
X_temp$basic.upper_max <- NULL
X_temp$basic.upper_min <- NULL
X_temp$basic.lower_min <- NULL
X_temp$basic.lower_max<- NULL
X_temp$basic.blocks_min <- NULL
X_temp$basic.blocks_max <- NULL
X_temp$basic.cells_total <- NULL
X_temp$basic.cells_filled <- NULL
X_temp$basic.minimize_fun <- NULL
X_temp$basic.costs_fun_evals <- NULL
X_temp$basic.dim <- NULL
X_temp$basic.observations <- NULL

X_temp$basic.lower_max <- NULL
X_temp$basic.lower_min <- NULL
X_temp$basic.costs_runtime <- NULL
X_temp$pca.costs_runtime <- NULL
X_temp$pca.costs_fun_evals <- NULL
X_temp$nbc.costs_fun_evals <- NULL
X_temp$nbc.costs_runtime<- NULL
X_temp$limo.costs_runtime<- NULL
X_temp$limo.costs_fun_evals<- NULL
X_temp$disp.costs_fun_evals<- NULL
X_temp$disp.costs_runtime<- NULL
X_temp$ic.costs_fun_evals<- NULL
X_temp$ic.costs_runtime<- NULL
X_temp$ela_meta.costs_fun_evals<- NULL
X_temp$ela_level.costs_fun_evals<- NULL
X_temp$ela_meta.costs_runtime<- NULL
X_temp$ela_level.costs_runtime<- NULL
X_temp$cm_grad.costs_fun_evals <- NULL
X_temp$cm_grad.costs_runtime<- NULL
X_temp$cm_angle.costs_runtime <- NULL
X_temp$cm_angle.costs_fun_evals<- NULL
X_temp$cm_grad.costs_fun_evals <- NULL

X_temp$ic.eps.ratio <- NULL #contians infinite values

combined_cols <- colnames(X_temp)
coco_features <- coco_features[,combined_cols]

X_temp <- sapply(X_temp, as.numeric)
X_temp <- as.data.frame(X_temp)

best <- as.numeric(as.factor(best))
classes <- best
classes <- as.factor(classes)
X_temp$class <- classes
X_temp <- X_temp[ , colSums(is.na(X_temp)) == 0]
X_temp <- X_temp[ , colSums(is.nan(as.matrix(X_temp))) == 0]
X_temp <- X_temp[ , colSums(is.infinite(as.matrix(X_temp))) == 0]

X_temp$func <- NULL

train_rows <- 1:500
test_rows <- 501:860
train <- X_temp[train_rows,]
test <- X_temp[test_rows,]
columns_2 <- intersect(colnames(train), colnames(test))
test <- test[columns_2]
train <- train[columns_2]

saveRDS(test, "landscape_features/processed/coco.RDS")
saveRDS(train, "landscape_features/processed/artificial.RDS")


# forecast to NEON sites using delgao-ramirez calibration models.

rm(list=ls())
library(data.table)
source('paths.r')
source('paths_fall2019.r')
source('NEFI_functions/tic_toc.r')
source('NEFI_functions/precision_matrix_match.r')
source('NEFI_functions/ddirch_forecast_noLogMap.r')

# source ddirch_forecast
library(RCurl)
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/ddirch_forecast.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

#set output path.----
output.path <- NEON_cps_fcast_ddirch_16S.path

#load prior model results.----
all.mod <- readRDS(prior_delgado_ddirch_16S.path)

#get core-level covariate means and sd.----
dat <- readRDS(hierarch_filled_data.path)
dat <- lapply(dat, function(x) x[!(names(x) %in% c("pH", "conifer"))])
dat <- lapply(dat, function(x) setnames(x, old = "pH_water", new = "pH", skip_absent = TRUE))
dat <- mapply(cbind, dat, "study_id"=200)

core_mu <- dat$core.core.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#site_mu$map <- log(site_mu$map) # the function already takes the log of map

#merge together.
plot_mu$siteID <- NULL
core.preds <- merge(core_mu   , plot_mu)
core.preds <- merge(core.preds, site_mu)
core.preds$relEM <- NULL
names(core.preds)[names(core.preds)=="b.relEM"] <- "relEM"

#get core-level SD.
core_sd <- dat$core.core.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd

#merge together.
plot_sd$siteID <- NULL
core.sd <- merge(core_sd   , plot_sd)
core.sd <- merge(core.sd, site_sd)
core.sd$relEM <- NULL
names(core.sd)[names(core.sd)=="b.relEM"] <- "relEM"

#get plot-level covariate means and sd.----
core_mu <- dat$core.plot.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#merge together, .
plot_mu$siteID <- NULL
plot.preds <- merge(core_mu,plot_mu)
plot.preds <- merge(plot.preds,site_mu)
plot.preds$relEM <- NULL
names(plot.preds)[names(plot.preds)=="b.relEM"] <- "relEM"

#get plot-level SD.
core_sd <- dat$core.plot.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together
plot_sd$siteID <- NULL
plot.sd <- merge(core_sd,plot_sd)
plot.sd <- merge(plot.sd,site_sd)
plot.sd$relEM <- NULL
names(plot.sd)[names(plot.sd)=='b.relEM'] <- "relEM"

#get site-level covariate means and sd.----
core_mu <- dat$core.site.mu
plot_mu <- dat$plot.site.mu
site_mu <- dat$site.site.mu
#merge together
site.preds <- merge(core_mu, plot_mu)
site.preds <- merge(site.preds,site_mu)
names(site.preds)[names(site.preds)=='b.relEM'] <- "relEM"

#get site-level SD.
core_sd <- dat$core.site.sd
plot_sd <- dat$plot.site.sd
site_sd <- dat$site.site.sd
#merge together.
site.sd <- merge(core_sd,plot_sd)
site.sd <- merge(site.sd,site_sd)
names(site.sd)[names(site.sd)=='b.relEM'] <- "relEM"

# # add dummy vars for study effects
# fcast.preds <- list()
# for (h in 1:3){
#   hier <- list(core.preds, plot.preds, site.preds)
#   nrow <- nrow(hier[[h]])
#
#   all_vars <- unique(all.mod[[1]]$species_parameter_output[[1]]$predictor)
#   dummy_vars <- all_vars[grep("study_id_", all_vars)]
#   dummy_mat <- matrix(0, nrow = nrow, ncol = length(dummy_vars))
#   colnames(dummy_mat) <- dummy_vars
#   out <- cbind(hier[[h]], dummy_mat)
#   fcast.preds[[h]] <- out
# }
#
#
# fcast.sd <- list()
# for (h in 1:3){
#   hier <- list(core.sd, plot.sd, site.sd)
#   nrow <- nrow(hier[[h]])
#
#   all_vars <- unique(all.mod[[1]]$species_parameter_output[[1]]$predictor)
#   dummy_vars <- all_vars[grep("study_id_", all_vars)]
#   dummy_mat <- matrix(0.01, nrow = nrow, ncol = length(dummy_vars))
#   colnames(dummy_mat) <- dummy_vars
#   out <- cbind(hier[[h]], dummy_mat)
#   fcast.sd[[h]] <- out
# }

#Get forecasts from ddirch_forecast.----
fcast.output <- list()

cat('Making forecasts...\n')
for(i in 1:length(all.mod)){

    tic()
  mod <- all.mod[[i]]
  #mod$jags_model$mcmc <- runjags::combine.mcmc(mod$jags_model, return.samples = 2000, collapse.chains = FALSE)
  core.fit <- ddirch_forecast_noLogMap(mod=mod, cov_mu=core.preds, cov_sd=core.sd, names=core.preds$sampleID, n.samp = 1000)
  plot.fit <- ddirch_forecast_noLogMap(mod=mod, cov_mu=plot.preds, cov_sd=plot.sd, names=plot.preds$plotID  , n.samp = 1000)
  site.fit <- ddirch_forecast_noLogMap(mod=mod, cov_mu=site.preds, cov_sd=site.sd, names=site.preds$siteID  , n.samp = 1000)

  #store output as a list and save.----
  output <- list(core.fit,plot.fit,site.fit,core.preds,plot.preds,site.preds,core.sd,plot.sd,site.sd)
  names(output) <- c('core.fit','plot.fit','site.fit',
                     'core.preds','plot.preds','site.preds',
                     'core.sd','plot.sd','site.sd')
  fcast.output[[i]] <- output
  cat(paste0(i,' of ',length(all.mod),' forecasts complete. '))
  toc()
}
cat('All forecasts complete.')
toc()

#Save output.----
names(fcast.output) <- names(all.mod)
saveRDS(fcast.output, output.path)


## Author: Yunchuan Kong
## Copyright Reserved 2018

library(igraph)

# Match GO terms with GO IDs
# library(GO.db)
# GO.names<-mget(names(GO.select), GOTERM, ifnotfound=NA)
# findTerm=function(obj){
#     if (is.na(obj)!=T)
#         return(Term(obj))
#     else
#         return(NA)
# }
# GOdict<-as.vector(unlist(lapply(GO.names, findTerm)))

##############################################################################################
## Supervised section

## INPUT: net, label, GO.select
plot_entrie_sup <- function(net, label, GO.select, folds=10){

  # pick up those larger than f fold change
  k=dim(net)[1] # net is fully normalized
  f=folds # fold change
  net_vec_sel=as.vector(net)
  net_vec_sel[net_vec_sel<f]=0
  net_sel=array(net_vec_sel,c(k,k,k))
  elist=which(net_sel>0,arr.ind=TRUE)
  ewgt=net_sel[elist]
  elist=cbind(elist,ewgt)
  V=length(unique(as.vector(elist[,1:3]))) # num of modules that contain selected edges
  # print(V)

  # fold as weight, allow multi-edge
  el=rbind(elist[,c(1,2,4)],elist[,c(1,3,4)],elist[,c(2,3,4)])
  g=graph.edgelist(apply(el[,1:2],2,as.character), directed = F)
  E(g)$weight=el[,3]
  degrees=table(el[,1:2]) # number of connections for each node
  dlevels=sort(unique(degrees),decreasing=T) # degree levels
  nocol=length(dlevels) # number of colors
  rgb.palette <- colorRampPalette(c("red","orange","yellow"
                                  # ,"green","cyan","blue"
                                  ), space = "rgb",bias=0.5)
  col<-rgb.palette(nocol)
  color=rep(NA,V)
  ind=match(names(degrees),names(V(g)))
  for (i in 1:nocol){
    color[ind[which(degrees==dlevels[i])]]=col[i]
  }
  V(g)$color=color
  vlabels=names(GO.select)[as.numeric(names(V(g)))]

  # ewidth=(E(g)$weight-f)/(mean(E(g)$weight)-f)
  ewidth = log(E(g)$weight-f+1)

  pdf(paste("full_sup (f=",f,").pdf",sep=''))
#   png("Figure1.png")
  plot(g, # http://igraph.org/r/doc/plot.common.html
      edge.width=ewidth,
      edge.color='grey75',
      vertex.label=vlabels,
      vertex.label.cex=0.3,
      vertex.label.color='black',
      vertex.frame.color=NA,
      vertex.size=5)
  dev.off()
  cat("A full hypergraph plot (2-D version) for the supervised approach has been saved.\n")
  res <- NULL
  res$elist <- elist
  res$g <- g
  res$folds <- f
  return(res)
}

## INPUT: g, elist from plot_entire_sup(), and folds should be consistent
plot_top_sup <- function(g, elist, label, GO.select, folds, n_keep=15){
  library(GO.db)
  f = folds
  hdegrees=table(elist[,1:3])
  nokeep=n_keep # number of nodes to keep
  keep=as.numeric(names(sort(hdegrees,decreasing = T)[1:nokeep]))
  find_keep=function(x)return(all(x %in% keep))
  found_keep=apply(elist[,1:3],1,find_keep)
  helist=elist[found_keep,]
  noe=dim(helist)[1]
  hel=NULL
  hedge_type=NULL
  for (i in 1:noe){
    he1=c(as.character(helist[i,1]),paste("E",i,sep=''),helist[i,4])
    he2=c(as.character(helist[i,2]),paste("E",i,sep=''),helist[i,4])
    he3=c(as.character(helist[i,3]),paste("E",i,sep=''),helist[i,4])
    if (length(unique(helist[i,1:3]))==1)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"blue"))
    else if (length(unique(helist[i,1:3]))==2)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"cyan"))
    else
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"green"))
    hel=rbind(hel,he1,he2,he3)
  }
  rownames(hel)=NULL
  hg=graph.edgelist(hel[,1:2], directed = F)
  hind=match(names(V(hg)),names(V(g)))
  V(hg)$color=V(g)$color[hind]
  for (i in 1:length(hind)){
    if (is.na(hind[i]))
      V(hg)$color[i]=hedge_type[which(hedge_type==names(V(hg)[i]),arr.ind = T)[1],2]
  }
  V(hg)$shape='circle'
  V(hg)$shape[is.na(hind)]='csquare'
  V(hg)$size[is.na(hind)]=4
  hvlabels=rep(NA,length(hind))
  hvlabels[!is.na(hind)]=names(GO.select)[as.numeric(names(V(hg))[!is.na(hind)])]
  hvlabels=as.vector(Term(hvlabels))
  hewgt=as.numeric(hel[,3])
  hewidth=log(hewgt-f+1)
  noc=ncol(label)-1 # num of clusters
  labelSum=apply(label[,1:noc],2,sum)
  hvsizes=labelSum[as.numeric(names(V(hg))[!is.na(hind)])]
  hvsizes=(hvsizes-min(hvsizes))/(mean(hvsizes)-min(hvsizes))
  hvsizes=4 * (hvsizes+2)
  V(hg)$size[!is.na(hind)]=hvsizes

  pdf(paste("Top",nokeep,"Connected_sup (f=",f,").pdf",sep=''))
#   png("Figure1.png")
  plot(hg, # http://igraph.org/r/doc/plot.common.html
       edge.width=hewidth,
       edge.color='grey80',
       vertex.label=hvlabels,
       vertex.label.cex=1,
       vertex.label.color='black',
       vertex.frame.color=NA)

  legend("bottomleft"
         # 0.85,-0.75
         ,c("type1","type2","type3")
         ,col=c("blue","cyan","green")
         ,pch=15 # square
         # ,lwd=4
         # ,title="legend"
  )
  dev.off()
  cat("A hypergraph plot of the",nokeep,"most connected vertices for the supervised approach has been saved.\n")
}

## INPUT: g, elist from plot_entire_sup(), and folds should be consistent
plot_one_sup <- function(g, elist, label, GO.select, folds, GOID, max_num_display=15){
  library(GO.db)
  f = folds
  term = Term(GOID)
  groupID = which(names(GO.select)==GOID)
  find_keep=function(x)return(all(groupID %in% x))
  found_keep=apply(elist[,1:3],1,find_keep)
  if (length(which(found_keep==T))==0){
    cat("WARNING: the group is not involved under the current fold change threshold!\n")
    return(NULL)
  }
  helist=elist[found_keep,]
  if (length(which(found_keep==T))==1){
    cat("WARNING: the group has only one edge. No hypergraph will be drawn.\n")
    cat("The edge connects:\n",Term(names(GO.select)[helist[1]]),"\n",
        Term(names(GO.select)[helist[2]]),"\n",
        Term(names(GO.select)[helist[3]]),"\n")
    return(NULL)
  }
  ## If want a limited number of connections per plot:
  else if (nrow(helist)>max_num_display){
      ord = order(helist[,4],decreasing = T)
      helist = helist[ord[1:15],]
      noe=dim(helist)[1]
      cat("Only display at most", max_num_display, "of connections, according to the fold change rank.\n")
  } else {
    noe=dim(helist)[1]
  }

  hel=NULL
  hedge_type=NULL
  for (i in 1:noe){
    he1=c(as.character(helist[i,1]),paste("E",i,sep=''),helist[i,4])
    he2=c(as.character(helist[i,2]),paste("E",i,sep=''),helist[i,4])
    he3=c(as.character(helist[i,3]),paste("E",i,sep=''),helist[i,4])
    if (length(unique(helist[i,1:3]))==1)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"blue"))
    else if (length(unique(helist[i,1:3]))==2)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"cyan"))
    else
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"green"))
    hel=rbind(hel,he1,he2,he3)
  }
  rownames(hel)=NULL
  hg=graph.edgelist(hel[,1:2], directed = F)
  hind=match(names(V(hg)),names(V(g)))
  V(hg)$color=V(g)$color[hind]
  for (i in 1:length(hind)){
    if (is.na(hind[i]))
      V(hg)$color[i]=hedge_type[which(hedge_type==names(V(hg)[i]),arr.ind = T)[1],2]
  }
  V(hg)$shape='circle'
  V(hg)$shape[is.na(hind)]='csquare'
  V(hg)$size[is.na(hind)]=6
  hvlabels=rep(NA,length(hind))
  hvlabels[!is.na(hind)]=names(GO.select)[as.numeric(names(V(hg))[!is.na(hind)])]
  hvlabels=as.vector(Term(hvlabels))
  hewgt=as.numeric(hel[,3])
  # hewidth=(hewgt-f)/(mean(hewgt)-f)
  hewidth=log(hewgt-f+1)

  noc=ncol(label)-1 # num of clusters
  labelSum=apply(label[,1:noc],2,sum)
  hvsizes=labelSum[as.numeric(names(V(hg))[!is.na(hind)])]
  hvsizes=(hvsizes-min(hvsizes))/(mean(hvsizes)-min(hvsizes))
  hvsizes=4 * (hvsizes+2)
  V(hg)$size[!is.na(hind)]=hvsizes

  pdf(paste(term,"_sup (f=",f,").pdf",sep=''))
  plot(hg, # http://igraph.org/r/doc/plot.common.html
       edge.width=hewidth,
       edge.color='grey80',
       vertex.label=hvlabels,
       vertex.label.cex=1,
       vertex.label.color='black',
       vertex.frame.color=NA,
       margin=c(0,0,0,0)
  )

  legend("bottomleft"
         # 0.85,-0.75
         ,c("type1","type2","type3")
         ,col=c("blue","cyan","green")
         ,pch=15 # square
         # ,lwd=4
         # ,title="legend"
  )
  dev.off()
  cat("A hypergraph plot of",GOID,"and its connected vertices has been saved.\n")
}

##############################################################################################
## plot gene level hypergraph for a given module level hyper-edge

query <- function(triplet, c1, c2, c3){
  n=dim(triplet)[1]
  k1 <- length(c1)
  k2 <- length(c2)
  k3 <- length(c3)
  res <- rep(c(0,0,0), k1*k2*k3)
  .C('query',tri=as.integer(as.vector(t(triplet))),
     n=as.integer(n),
     c1=as.integer(c1),
     c2=as.integer(c2),
     c3=as.integer(c3),
     k1=as.integer(k1),
     k2=as.integer(k2),
     k3=as.integer(k3),
     res=as.integer(res))$res
}

find_Vhg <- function(str){
  if (unlist(strsplit(str,""))[1] == "E" ){
    return(NA)
  } else {
    return(1)
  }
}

plot_gene_level <- function(hyperedge, module_names,
                            net, label, triplets, glist,
                            folds){
  net_sel <- net
  net_sel[net<folds] <- 0
  hyperedge <- sort(hyperedge, decreasing=T)
  if (net_sel[hyperedge[1],hyperedge[2],hyperedge[3]] == 0){
    cat("The hyperedge does not exist under the current fold change.\n")
  }

  c1 <- label[,hyperedge[1]]
  c1 <- which(c1==1)
  c2 <- label[,hyperedge[2]]
  c2 <- which(c2==1)
  c3 <- label[,hyperedge[3]]
  c3 <- which(c3==1)

  sel_list <- query(triplets, c1, c2, c3)
  sel_list <- sel_list[sel_list!=0]
  sel_list <- matrix(sel_list, ncol=3, byrow=T)

  helist <- sel_list
  noe=dim(helist)[1]
  hel=NULL
  hedge_type=NULL
  for (j in 1:noe){
    he1=c(as.character(helist[j,1]),paste("E",j,sep=''))
    he2=c(as.character(helist[j,2]),paste("E",j,sep=''))
    he3=c(as.character(helist[j,3]),paste("E",j,sep=''))
    if (length(unique(hyperedge))==1)
      hedge_type=rbind(hedge_type,c(paste("E",j,sep=''),adjustcolor("blue", alpha.f = .5)))
    else if (length(unique(hyperedge))==2)
      hedge_type=rbind(hedge_type,c(paste("E",j,sep=''),adjustcolor("cyan", alpha.f = .5)))
    else
      hedge_type=rbind(hedge_type,c(paste("E",j,sep=''),adjustcolor("green", alpha.f = .5)))
    hel=rbind(hel,he1,he2,he3)
  }
  rownames(hel)=NULL
  hg=graph.edgelist(hel[,1:2], directed = F)
  hind <- apply(as.matrix(names(V(hg))),1,find_Vhg)

  for (k in 1:length(hind)){
    if (is.na(hind[k])){
      V(hg)$color[k]=hedge_type[which(hedge_type==names(V(hg)[k]),arr.ind = T)[1],2]
    } else if (hyperedge[1] %in% which(label[as.numeric(names(V(hg)[k])),]==1)){
      V(hg)$color[k] <- adjustcolor("purple1", alpha.f = .5)
    } else if (hyperedge[2] %in% which(label[as.numeric(names(V(hg)[k])),]==1)){
      V(hg)$color[k] <- adjustcolor("orchid1", alpha.f = .5)
    } else {
      V(hg)$color[k] <- adjustcolor("navajowhite", alpha.f = .5)
    }
  } ## for k
  V(hg)$shape='circle'
  V(hg)$shape[is.na(hind)]='csquare'
  V(hg)$size[is.na(hind)]=1
  # V(hg)$size[!is.na(hind)]=6
  hvlabels=rep(NA,length(hind))
  hvlabels[!is.na(hind)]=glist[as.numeric(names(V(hg))[!is.na(hind)])]

  noc=ncol(label)-1 # num of clusters
  freq <- table(helist)
  hvsizes=freq[match(names(V(hg))[!is.na(hind)], names(freq))]
  # hvsizes=(hvsizes-min(hvsizes))/(mean(hvsizes)-min(hvsizes))
  hvsizes=3 * (hvsizes+1)
  V(hg)$size[!is.na(hind)]=hvsizes

  pdf(paste0("graph_gene_level.pdf"))
#   layout <- layout_with_kk(hg)
  # set.seed(2)
  plot(hg, # http://igraph.org/r/doc/plot.common.html
       layout=layout_with_lgl(hg), # layout_on_sphere(hg),
       edge.width=0.4,
       edge.color='grey80',
       vertex.label=hvlabels,
       vertex.label.cex=0.8,
       vertex.label.color=adjustcolor("black", alpha.f = .5),
       vertex.frame.color=NA,
       margin=c(0,0,0,0)
  )
  legend("bottomleft"
         # 0.85,-0.75
         ,module_names[hyperedge]
         ,col=c("purple1","orchid1","navajowhite")
         ,pch=15 # square
         # ,lwd=4
         # ,title="legend"
  )
  dev.off()
}

##############################################################################################
## Unsupervised section

## INPUT: label, net
plot_entrie_unsup <- function(net, label, folds=10){
  # pick up those larger than f fold change
  k=dim(net)[1]
  f=folds
  net_vec_sel=as.vector(net)
  net_vec_sel[net_vec_sel<f]=0
  net_sel=array(net_vec_sel,c(k,k,k))
  elist=which(net_sel>0,arr.ind=TRUE)
  ewgt=net_sel[elist]
  elist=cbind(elist,ewgt)
  V=length(unique(as.vector(elist[,1:3]))) # num of modules that contain selected edges
  # print(V)

  # fold as weight, allow multi-edge
  el=rbind(elist[,c(1,2,4)],elist[,c(1,3,4)],elist[,c(2,3,4)])
  g=graph.edgelist(apply(el[,1:2],2,as.character), directed = F)
  E(g)$weight=el[,3]
  degrees=table(el[,1:2]) # number of connections for each node
  dlevels=sort(unique(degrees),decreasing=T) # degree levels
  nocol=length(dlevels) # number of colors
  rgb.palette <- colorRampPalette(c("red","orange","yellow"
                                    # ,"green","cyan","blue"
  ), space = "rgb",bias=0.5)
  col<-rgb.palette(nocol)
  color=rep(NA,V)
  ind=match(names(degrees),names(V(g)))
  for (i in 1:nocol){
    color[ind[which(degrees==dlevels[i])]]=col[i]
  }
  V(g)$color=color
  # ewidth=(E(g)$weight-f)/(mean(E(g)$weight)-f)
  ewidth = log(E(g)$weight-f+1)

  pdf(paste("full_unsup (f=",f,").pdf",sep=''))
  plot(g, # http://igraph.org/r/doc/plot.common.html
       edge.width=ewidth,
       edge.color='grey75',
       # vertex.label=vlabels,
       vertex.label.cex=0.5,
       vertex.label.color='black',
       vertex.frame.color=NA,
       vertex.size=5)
  dev.off()
  cat("A full hypergraph plot (2-D version) for the unsupervised approach has been saved.\n")
  res <- NULL
  res$elist <- elist
  res$g <- g
  res$folds <- f
  return(res)
}

## INPUT: g, elist from plot_entire_unsup(), and folds should be consistent
plot_top_unsup <- function(g, elist, label, folds, n_keep=15){
  f = folds
  hdegrees=table(elist[,1:3])
  nokeep=n_keep # number of nodes to keep
  keep=as.numeric(names(sort(hdegrees,decreasing = T)[1:nokeep]))
  find_keep=function(x)return(all(x %in% keep))
  found_keep=apply(elist[,1:3],1,find_keep)
  length(which(found_keep==T))
  helist=elist[found_keep,]
  noe=dim(helist)[1]
  hel=NULL
  hedge_type=NULL
  for (i in 1:noe){
    he1=c(as.character(helist[i,1]),paste("E",i,sep=''),helist[i,4])
    he2=c(as.character(helist[i,2]),paste("E",i,sep=''),helist[i,4])
    he3=c(as.character(helist[i,3]),paste("E",i,sep=''),helist[i,4])
    if (length(unique(helist[i,1:3]))==1)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"blue"))
    else if (length(unique(helist[i,1:3]))==2)
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"cyan"))
    else
      hedge_type=rbind(hedge_type,c(paste("E",i,sep=''),"green"))
    hel=rbind(hel,he1,he2,he3)
  }
  rownames(hel)=NULL
  hg=graph.edgelist(hel[,1:2], directed = F)
  hind=match(names(V(hg)),names(V(g)))
  V(hg)$color=V(g)$color[hind]
  for (i in 1:length(hind)){
    if (is.na(hind[i]))
      V(hg)$color[i]=hedge_type[which(hedge_type==names(V(hg)[i]),arr.ind = T)[1],2]
  }
  V(hg)$shape='circle'
  V(hg)$shape[is.na(hind)]='csquare'
  V(hg)$size[is.na(hind)]=5
  hvlabels=rep(NA,length(hind))
  hvlabels[!is.na(hind)]=names(V(hg))[!is.na(hind)]
  # hvlabels=as.vector(Term(hvlabels))
  hewgt=as.numeric(hel[,3])
  # hewidth=(hewgt-f)/(mean(hewgt)-f)
  hewidth = log(hewgt-f+1)
  noc=ncol(label)-1 # num of clusters
  labelSum=apply(label[,1:noc],2,sum)
  hvsizes=labelSum[as.numeric(names(V(hg))[!is.na(hind)])]
  hvsizes=(hvsizes-min(hvsizes))/(mean(hvsizes)-min(hvsizes))
  hvsizes=6 * (hvsizes+2)
  V(hg)$size[!is.na(hind)]=hvsizes

  pdf(paste("Top",nokeep,"Connected_unsup (f=",f,").pdf",sep=''))
  plot(hg, # http://igraph.org/r/doc/plot.common.html
       edge.width=hewidth,
       edge.color='grey80',
       vertex.label=hvlabels,
       vertex.label.cex=1,
       vertex.label.color='black',
       vertex.frame.color=NA)

  legend("bottomleft"
         # 0.85,-0.75
         ,c("type1","type2","type3")
         ,col=c("blue","cyan","green")
         ,pch=15 # square
         # ,lwd=4
         # ,title="legend"
  )
  dev.off()
  cat("A hypergraph plot of the",nokeep,"most connected vertices for the unsupervised approach has been saved.\n")
}


#' @title
#' Calculate changes at all intervals within each cluster
#'
#' @description
#' Create and run generalised linear models and post-hoc tukey contrasts at all time points for each cluster.
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#'
#' @return A list (with same length as number of clusters) containing the Tukey summaries.
#'
#'
#' @importFrom multcomp glht mcp
#' @importFrom stats glm
#' @importFrom methods is
#'
#'
#' @seealso \code{\link[e1071]{cmeans}} for clustering.
#'
#' @export
calcClusterChng <- function(Tc, clusters){

	# 1. split into matrix for each cluster...
	# 2. convert to df. of required format for glm
	# 3. for each cluster run glm.
	# 4. for each glm result run tukey contrast. (which can give the summary directly or which can initially give the full matrix (between each time point))
	# another function to do the plotting.

	stopifnot(is(Tc, "matrix"), (length(clusters) == nrow(Tc)))

	list_matrices <- splitIntoSubMatrices(Tc, clusters)
	list_dfsGlm <- convertMatToDfForGlmFormat(list_matrices)

	list_lm <- runGlmForEachCluster(list_dfsGlm)
	# print("Note: finished creating glm's")

	list_resSummaries <- runPostHocTukeyForEachClus(list_lm)
	# print("Note: finished post-hoc tukey")

	# list_resSummaries <- createGlmTukeyForEachClus(list_dfsGlm)
	# return (list_resSummaries)

	class(list_resSummaries) <- "clusterChange"
	return (list_resSummaries)
}

#' @title
#' Summarize the Tukey constrasting results for consecutive intervals.
#'
#' @description
#' Summarize results obtained by running the \code{calcClusterChng} function. Specifically this function extracts z-scores and p-values for consecutive intervals.
#'
#' @param list_resSummaries A list returned by the \code{calcClusterChng} function.
#' @param Tc The time course data
#'
#' @return A list containing two items, where the first item is a z-score matrix, and the second item is a p-value matrix.
#'
#' @importFrom methods is
#'
#' @seealso \code{\link{calcClusterChng}}
#'
#' @export
summaryGetZP <- function(list_resSummaries, Tc){

	stopifnot(is(list_resSummaries,"clusterChange"), is(Tc, "matrix"))

	list_concTpSummary <- list()
	colNames = c()

	zScores <- matrix(nrow=length(list_resSummaries), ncol=ncol(Tc)-1)
	pValues <- matrix(nrow=length(list_resSummaries), ncol=ncol(Tc)-1)

	for(clustNum in 1:length(list_resSummaries)){
		for(tp in 2:ncol(Tc)){

			selName = paste(tp, "-", (tp-1))
			if (!is.null(colnames(Tc))){
				name = paste(colnames(Tc)[tp], "-", colnames(Tc)[(tp-1)])
			}
			else{
				name = selName
			}

			# print(name)
			if(clustNum == 1){
				colNames <- c(colNames, name)
			}

			zScores[clustNum, tp-1] <- list_resSummaries[[clustNum]]$test$tstat[selName]

			idx = which(names(list_resSummaries[[clustNum]]$test$tstat) == selName)

			pValues[clustNum, tp-1] <- list_resSummaries[[clustNum]]$test$pvalues[[idx]]

		}
	}

	colnames(zScores) <- colNames
	colnames(pValues) <- colNames

	list_concTpSummary[[1]] <- zScores
	list_concTpSummary[[2]] <- pValues

	class(list_concTpSummary) <- "summary.clusterChange"

	return(list_concTpSummary)
}

#' @title
#' Print changes in consecutive contrasting intervals
#'
#' @description
#' Prints two matrices, the first containing z-scores, and the second, p-values, where each row corresponds to each cluster, and each column corresponds to the time-interval.
#'
#' @param list_concTpSummary Z-scores and p-values extracted from tukey-constrasts for glm's of each cluster.
#'
#'
#' @seealso \code{\link{summaryGetZP}}
#'
#' @export
printZP <- function(list_concTpSummary){
	cat('===== list_[[1]] - zScores\n')
	print(list_concTpSummary[[1]])
	cat('\n\n')

	cat('===== list_[[2]] - pValues\n')
	print(list_concTpSummary[[2]])
	cat('\n\n')
}

#' @title
#' Plot a Z-score heatmap
#'
#' @description
#' Plot a heatmap of z-scores, masking the z-scores at insignificant p-values. Rows in the heatmap correspond to clusters, and columns in the heatmap correspond to time intervals.
#'
#' @param list_concTpSummary Z-scores and p-values extracted from tukey-constrasts of consecutive time intervals for each cluster. Obtained by running the \code{summaryGetZP} function.
#' @param significanceTh Tukey's p-value cutoff to be applied for significance.
#'
#' @return Displays a plot and returns a matrix, with z-scores masked (NA) according to the signficance (p-value) threshold specified.
#'
#'
#' @seealso \code{\link{summaryGetZP}}
#'
#' @importFrom gplots heatmap.2
#' @importFrom grDevices colorRampPalette
#' @importFrom methods is
#'
#' @export
plotZP <- function(list_concTpSummary, significanceTh=0.05){

	stopifnot(is(list_concTpSummary, "summary.clusterChange"), (significanceTh >0 && significanceTh <= 1))

	theSignifs <- list_concTpSummary[[2]] < significanceTh

	matToPlot <- list_concTpSummary[[1]]

	rwb <- grDevices::colorRampPalette(colors = c("blue", "#cfcfcf", "red"))(n=299)

	if (!all(theSignifs)){
		zscore_largest <- ceiling(max(c(abs(min(matToPlot)), abs(max(matToPlot)))))
		theBreaks <- seq(-zscore_largest, zscore_largest, length.out=299)

		zscore_largest_noSignif <- max(c(abs(max(matToPlot[!theSignifs])), abs(min(matToPlot[!theSignifs]))))
		idx_forGray50 <- theBreaks <= zscore_largest_noSignif & theBreaks >= -zscore_largest_noSignif

		rwb[idx_forGray50] <- "#cfcfcf"

		matToPlot[!theSignifs] <- NA
	}

	titleTxt = paste("Significant changes\n(z-values of intervals,\n with significance p \u003C", significanceTh, ")", sep="")

	gplots::heatmap.2(matToPlot, main=titleTxt, xlab="Time interval", ylab="Cluster", Rowv=FALSE, Colv=FALSE, dendrogram="none", col=rwb, na.color="#cfcfcf", tracecol=NA, density.info="none", sepcolor="#cfcfcf", sepwidth=c(0.001, 0.001), colsep=0:ncol(matToPlot), rowsep=0:nrow(matToPlot), srtCol=45, cexCol=0.8)

	return (matToPlot)
}

plotZP_eachCluster <- function(list_resSummaries, Tc, glmTukeyForEachClus){

	# stopifnot(is(list_resSummaries,"clusterChange"), is(Tc, "matrix"))

	list_matsToPlot <- list()

	for (clusNum in 1:length(list_resSummaries)){
		mat_aClus <- matrix(nrow=ncol(Tc), ncol=ncol(Tc))

		# names_r <- c()
		# names_c <- c()
		# for (i in length(glmTukeyForEachClus[[clusNum]]$test$tstat)){

		# }

		for (tp2 in 1:ncol(Tc)){
			for (tp1 in tp2:ncol(Tc)){
				if (tp2 != tp1){
					# print(paste(tp1, '-', tp2))
					selName = paste(tp1, "-", (tp2))

					# names_r <- c(names_r, paste(colnames(Tc)[tp1], '-', colnames(Tc)[tp2]))

					mat_aClus[tp1, tp2] = as.numeric(glmTukeyForEachClus[[clusNum]]$test$tstat[selName])

					mat_aClus[tp2, tp1] = -1 * as.numeric(glmTukeyForEachClus[[clusNum]]$test$tstat[selName])
				}
				else{
					mat_aClus[tp1, tp2] = 0
				}
			}
		}
		# print(names_r)
		colnames(mat_aClus) <- colnames(Tc)
		rownames(mat_aClus) <- colnames(Tc)
		list_matsToPlot[[clusNum]] <- mat_aClus

	}
	doThePlotting(list_matsToPlot)
	return (list_matsToPlot)
}

getAbsMaxValue <- function(list_matsToPlot){

	largestAbsVal <- 0
	for (clusNum in 1:length(list_matsToPlot)){
		newMax <- max(abs(list_matsToPlot[[clusNum]]))

		if (newMax > largestAbsVal){
			largestAbsVal <- newMax
		}
	}

	return (largestAbsVal)
}

doThePlotting <- function(list_matsToPlot){

	pdf("allByAllHeatmaps.pdf", height=10, width=10)

	par(mfrow=c(ceiling(length(list_matsToPlot)/8), 8))

	rwb <- grDevices::colorRampPalette(colors = c("blue", "#cfcfcf", "red"))(n=99)

	largestAbsVal <- getAbsMaxValue(list_matsToPlot)
	zscore_largest <- ceiling(largestAbsVal)

	theBreaks <- sort(seq(-zscore_largest, zscore_largest, length.out=100))

	print(theBreaks)

	for (clusNum in 1:length(list_matsToPlot)){

		# zscore_largest_noSignif <- max(c(abs(max(matToPlot[!theSignifs])), abs(min(matToPlot[!theSignifs]))))
		# idx_forGray50 <- theBreaks <= zscore_largest_noSignif & theBreaks >= -zscore_largest_noSignif

		# rwb[idx_forGray50] <- "#cfcfcf"

		# matToPlot[!theSignifs] <- NA

		titleTxt = paste("Cluster ", clusNum, sep="")

		gplots::heatmap.2(list_matsToPlot[[clusNum]], main=titleTxt, xlab="Time interval", ylab="Time interval", Rowv=FALSE, Colv=FALSE, dendrogram="none", col=rwb, na.color="#cfcfcf", tracecol=NA, density.info="none", sepcolor="#cfcfcf", sepwidth=c(0.001, 0.001), colsep=0:ncol(list_matsToPlot[[clusNum]]), rowsep=0:nrow(list_matsToPlot[[clusNum]]), srtCol=45, cexCol=0.8, breaks=theBreaks)
	}
	dev.off()
}

##################################### PRIVATE FUNCTIONS
#' Run tukey post-hoc evaluations for the glm's.
#'
#' @param list_lms A list containing a lm for each cluster.
#' @return A list of tukey evaluations
#'
runPostHocTukeyForEachClus <- function(list_lms){
	list_tukeys <- list()

	for (clustNum in 1:length(list_lms)){
		# list_tukeys[[clustNum]] <- emmeans(list_lms[[clustNum]], pairwise ~ fac_timepoint, adjust="tukey")

		list_tukeys[[clustNum]] <- summary(multcomp::glht(list_lms[[clustNum]], multcomp::mcp(fac_timepoint="Tukey")))
	}

	return (list_tukeys)
}

#' Run glm for each cluster.
#'
#' @param list_dfsGlm A list of dataframes (for each cluster) of the time series data.
#' @return A list of glm's for each cluster.
#'
runGlmForEachCluster <- function(list_dfsGlm){

	list_lm <- list()

	for (dfNum in 1:length(list_dfsGlm)){
		aGlm <- list_dfsGlm[[dfNum]]
		list_lm[[dfNum]] <- stats::glm(formula=experimentalObs ~ fac_profileNum + fac_timepoint, data=aGlm)
	}

	return (list_lm)
}

#' Convert a list of matrices of each cluster, to a list of data frames (in the required glm format) for each cluster. Timepoint, and profileNum are factors, and experimentalObs (ratio) is y.
#'
#' @param list_matrices A list of matrices for each cluster
#' @return A list containing glm's for each cluster.
#'
convertMatToDfForGlmFormat <- function(list_matrices){
	list_dfsGlm <- list()

	# converting each matrix to a data_frame for GLM.
	for (clustNum in 1:length(list_matrices)){

		fac_timepoint = c()
		fac_profileNum = c()
		experimentalObs = c()

		for (tp in 1:ncol(list_matrices[[clustNum]])){

			fac_timepoint <- append(fac_timepoint, c(rep(tp, nrow(list_matrices[[clustNum]]))))

			fac_profileNum <- append(fac_profileNum, 1:nrow(list_matrices[[clustNum]]))

			experimentalObs <- append(experimentalObs, list_matrices[[clustNum]][,tp])

		}

		glmDf <- data.frame(fac_timepoint, fac_profileNum, experimentalObs)
		# add this df to the list
		# print(glmDf$fac_timepoint)
		glmDf$fac_timepoint <- factor(glmDf$fac_timepoint, ordered=TRUE)
		glmDf$fac_profileNum <- factor(glmDf$fac_profileNum) # , ordered=TRUE)

		list_dfsGlm[[clustNum]] <- glmDf

	}

	return(list_dfsGlm)
}

#' Split a matrix into cluster based submatrices.
#'
#' @param Tc A matrix containing time course data.
#' @param clusters A vector with same length as number of profiles. The cluster labels are assumed to be numbers, starting from 1.
#'
#' @return A list of matrices
#'
splitIntoSubMatrices <- function(Tc, clusters){

	list_matrices <- list()

	for (i in 1:max(clusters)){
		list_matrices[[i]] <- matrix(nrow=0, ncol=ncol(Tc))
	}

	for (i in 1:nrow(Tc)){
		rn <- rownames(Tc)[i]
		# print(rn)
		clusterOfRow <- clusters[[rn]]

		list_matrices[[clusterOfRow]] <- rbind(list_matrices[[clusterOfRow]], Tc[i,])

		rownames(list_matrices[[clusterOfRow]])[nrow(list_matrices[[clusterOfRow]])] <- rownames(Tc)[i]
	}

	return(list_matrices)
}


#!/usr/bin/Rscript

## data2plot.r -- takes as input a space-separated text file, converts
## it into a plot

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

usage <- function(){
  cat("usage: cat <file> | ./data2plot.r( p<name> <range from> <range to>)*\n");
}

popNames <- NULL;
popLimits <- NULL;

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(substr(commandArgs(TRUE)[argLoc],1,1) == "p"){
    inName <- substring(commandArgs(TRUE)[argLoc],2);
    popNames <- append(popNames, sub("_"," ",inName));
    popLimits <- cbind(popLimits,c(as.numeric(commandArgs(TRUE)[argLoc+1]),
                                   as.numeric(commandArgs(TRUE)[argLoc+2])));
    argLoc <- argLoc + 2;
  }
  argLoc <- argLoc + 1;
}

data.df <- read.table(file("stdin"));
pdf("output.pdf", paper = "a4r", height = 8, width = 11);
plot(data.df$V2);
dummy <- dev.off();

dm <- abs(mean(data.df$V2[popLimits[1,1]:popLimits[2,1]]) -
          mean(data.df$V2[popLimits[1,2]:popLimits[2,2]]));

if(dim(popLimits)[2] == 2){
  cat(sprintf("Difference of means: %f (adjusted = %f)\n",
              dm, dm / diff(range(data.df$V2))));
}


#library(dplyr)
#library(readr)
#library(tidyr)

titanicCsvImport <- function(filename) {
  data <- read_csv(filename, col_names = T, skip_empty_rows = T)
  if('Survived' %in% colnames(data)) {
    data <- data %>%
      #select(Survived, Age, Sex, Fare, Pclass, SibSp, Ticket, Parch, Cabin) %>%
      mutate( Survived = as.factor(Survived) )
  } else {
      #data <- data %>%
      #  select(Age, Sex, Fare, Pclass, SibSp, Ticket, Parch, Cabin)
  }

  data <- data %>%
    replace(., is.na(.), "" ) %>%
    #drop_na() %>%
    mutate( Age = as.numeric(Age) ) %>%
    mutate( Sex = as.factor(Sex) ) %>%
    mutate( Pclass = as.factor(Pclass) ) %>%
    mutate( Embarked = as.factor(Embarked) ) %>%
    mutate( Ticket = as.factor(Ticket) ) %>%
    mutate( Name = as.factor(Name) ) %>%
    mutate( CabinClass = substring(Cabin,1,1) ) %>%
    mutate( CabinClass = as.factor(CabinClass) ) %>%
    mutate( Cabin = as.factor(Cabin) ) %>%
    mutate( Fare = as.numeric(Fare) ) %>%
    mutate( hasTicket = Ticket != '') %>%
    mutate( knowsCabin = Cabin != '') %>%
    mutate( knowsAge = !is.na(Age) )

  cabins <- data %>%
    select(Cabin) %>%
    group_by(Cabin) %>%
    summarise( peopleInCabin = n() ) %>%
    arrange(desc(peopleInCabin))
  cabins[cabins$peopleInCabin > 50, ]$peopleInCabin <- 0
  data <- data %>% left_join(cabins, by = 'Cabin')

  return(data)
}


library("ggplot2")

sims <- read.table("all_te_similarity_0106.txt",sep="\t",header=F)
names(sims) <- c("type","element","length","similarity")
sims$type <- factor(sims$type,
	     	  levels = c("copia","gypsy","unclassified-ltr","trim","hAT",
		  "mutator","tc1-mariner","unclassified-tir"),
		  labels = c("Copia","Gypsy","Unclassified-LTR","TRIM","hAT",
		  "Mutator","Tc1-Mariner","Unclassified-TIR"))

ggplot(sims, aes(similarity, y=..density..)) +
	     geom_histogram(binwidth=.3,fill="cornsilk",colour="grey60",size=.2) +
	     geom_density(size=1,alpha=.3) +
	     scale_x_reverse() +
	     theme_bw() +
	     facet_grid(type ~ .) +
	     ylab("Density") +
	     xlab("LTR/TIR similarity")


#' Create cylinders.
#'
#' Create cylinders to cover events encoded in \code{observation.matrix}
#' and evaluate their exceedances with respect to \code{baseline}.

#' If \code{observation.matrix} and \code{baseline} have the same matrix dimension,
#' the exceedances are computed calling \code{compute}. Otherwise the function
#' this function assumes that the baseline is an \code{expand.grid} data.frame and
#' exceedancies are computed with \code{compute.from.tab.baseline}.
#' @param observation.matrix A 2D \code{Matrix} or {sparseMatrix} object.
#' @param baseline A 2D \code{matrix} or a Nx4 \code{expand.grid} data frame.
#' @param week.range A \code{numeric} vector to set the lower and upper limit to the heigh of the cylinders.
#' @param n.cylinders An \code{integer}, total number of drawn cylinders.
#' @param p.val.threshold A \code{numeric}. If the probability of observed exceedance is < \code{p.val.threshold}, flag the cylinder as anomalous.
#' @param size_factor A \code{numeric} multiplier to increase or reduce the cylinder heights and radia.
#' @examples
#' CreateCylinders(observation.matrix, baseline.matrix, week.range = c(0,99), n.cylinders = 10000)
#' CreateCylinders(observation.matrix, baseline.tab, week.range = c(0,99), n.cylinders = 100)
CreateCylinders<-function(observation.matrix, baseline, week.range,
                          n.cylinders=1000,
                          p.val.threshold=0.05,
                          size_factor=1, coord.df=NULL, only.last=FALSE){

  # load("~/Documents/Rancovr/Data/postcode2coord.RData")
  if (is.null(coord.df)){
    coord.df = PostcodeMap(observation.matrix)
  }
  #postcode2coord
  test = all(dim(baseline) == dim(observation.matrix))
  if (test){
    baseline = baseline[!(rownames(baseline) == 'NA'),]
    baseline = baseline[,!(colnames(baseline) == 'NA')]

    radia_and_heights = f_radia_and_heights(baseline, 1:24) * size_factor
    if (sum(baseline) > 2 * sum(observation.matrix)){
      print(sum(baseline))
      print(sum(observation.matrix))
      warning(
        sprintf(
          "Warning: the baseline might be too high. If you are working with typed data, please check that it is scaled by type factor."
        )
      )
    }
  }else{
    radia_and_heights = f_radia_and_heights_(baseline, 1:24) * size_factor
  }

  observation.matrix = observation.matrix[!(rownames(observation.matrix) == 'NA'),]
  observation.matrix = observation.matrix[,!(colnames(observation.matrix) == 'NA')]

  init = Sys.time()
  coord.df = coord.df[!is.na(coord.df$latitude),]
  coord.km.df = coord.df
  coord.km.df[,c('y','x')]= vlatlong2km(coord.df[,c("latitude","longitude")])
  week.range = range(as.integer(week.range))
  if ((week.range[1] < min(as.integer(colnames(observation.matrix)))) | (week.range[2] > max(as.integer(colnames(observation.matrix))))){
    A = sprintf("%d-%d", week.range[1], week.range[2])
    B = range(as.integer(colnames(observation.matrix)))
    B = sprintf("%d-%d", B[1], B[2])
    stop(paste0("`week.range`` is ", A, ", while the range of `observation.matrix` is ", B, "." ))
  }
  # week.range = range(
  #   as.integer(week.range)) + 1 - min(as.integer(colnames(observation.matrix))
  #   )

  cat("Evaluating cylinder exceedances from ",
        as.character(week2Date(week.range[1])),   # this interactive output doesnt work in the prospective mode
        " to ",
        as.character(week2Date(week.range[2])), ".\n")

  # # generate cylinders
  # print(week.range)
  # week.range = week.range + 2 - min(as.integer(colnames(observation.matrix)), na.rm=T)

  cylinders = rcylinder(n.cylinders, observation.matrix, week.range, radia_and_heights, coord.km.df, only.last)
#  print(any(cylinders$t.low == cylinders$t.upp))
  if (NROW(cylinders) > 0){
    if (test){
      tmp = t(apply(cylinders, 1, compute, observation.matrix, baseline, coord.km.df))
    }else{
      tmp = t(apply(cylinders, 1, compute.from.tab.baseline, observation.matrix, baseline, coord.km.df))
    }

    cylinders[,c('n_obs', 'mu', 'p.val')] = tmp
    cylinders$warning = cylinders$p.val < p.val.threshold
  }else{
    cat("No cases in the selected week range.\n")
  }
  print(Sys.time() - init)
  return(cylinders)
}

#'
#' n.cylinders=10000 takes around 3 hours for the whole dataset, to end up with 300 non-empty cylinders
#' observation.matrix  and baseline.matrix have dimension
#' This function scans the matrices
#' -1 in observation.matrix index means that we are excluding from week NA
#' @inheritParams CreateCylinders
#' @param observation.matrix.untyped A 2D matrix.
#' @param baseline.matrix.untyped A 2dD matrix.
CreateCylinders.delay<-function(observation.matrix.typed, baseline.matrix.typed,
                                observation.matrix.untyped, baseline.matrix.untyped,
                                emmtype,
                                week.range, n.cylinders=1000,
                                p.val.threshold=0.05, coord.df=postcode2coord,  size_factor=1){
  observation.matrix.typed = as.matrix(observation.matrix.typed[!(rownames(observation.matrix.typed) == 'NA'),])
  baseline.matrix.typed = as.matrix(baseline.matrix.typed[!(rownames(baseline.matrix.typed) == 'NA'),])
  observation.matrix.untyped = as.matrix(observation.matrix.untyped[!(rownames(observation.matrix.untyped) == 'NA'),])
  baseline.matrix.untyped = as.matrix(baseline.matrix.untyped[!(rownames(baseline.matrix.untyped) == 'NA'),])

  week.range = range(as.integer(week.range))
  c1 = sum(baseline.matrix.typed) > 2 * sum(observation.matrix.typed)
  c2 = sum(baseline.matrix.untyped) > 2 * sum(observation.matrix.untyped)
  if (c1){
    warning("Warning: the typed baseline is very high.")
  }
  if (c2){
    warning("Warning: the untyped baseline seems is very high.")
  }
  init = Sys.time()
  coord.df = coord.df[!is.na(coord.df$latitude),]
  coord.km.df = coord.df
  coord.km.df[,2:3] = vlatlong2km(coord.df[,2:3])
  if ((week.range[1] < min(as.integer(colnames(observation.matrix.typed)))) | (week.range[2] > max(as.integer(colnames(observation.matrix.typed))))){
    # line = sprintf("Try with `starting.week` < %d", ncol(observation.matrix)-2)
    # writeLines(c("`starting.week` is bigger than the matrix length.", line))
    A = sprintf("%d-%d", week.range[1], week.range[2])
    B = range(as.integer(colnames(observation.matrix.typed)))
    B = sprintf("%d-%d", B[1], B[2])
    writeLines(paste0("Error: `week.range` is ", A, ", while the range of `observation.matrix` is ", B, "." ))
    return(NA)
  }
  # weeks = as.integer(colnames(observation.matrix)[-seq(1:(starting.week+2))])
  # weeks = weeks[seq(1, length(weeks), 20)]
  # cylinders0 = data.frame(x=double(), y=double(), rho=double(), t.low=integer(), t.upp=integer(), n_obs=integer(), mu=double(), lower=integer(), upper=integer(), p.val=double(), warning=logical())
  radia_and_heights = f_radia_and_heights(baseline.matrix.typed, 1:24) * size_factor
  cat("Evaluating cylinder exceedances from ",
      as.character(week2Date(week.range[1])),   # this interactive output doesnt work in the prospective mode
      " to ",
      as.character(week2Date(week.range[2])),
      " for emm type ", emmtype, ".\n")

  # generate cylinders
  cylinders = rcylinder(n.cylinders, observation.matrix.typed + observation.matrix.untyped, week.range, radia_and_heights, coord.km.df)
  if (NROW(cylinders) > 0){
    cylinders[,c('n_obs.typed', 'mu.typed', 'p.val.typed')] = t(apply(cylinders, 1, compute,
                                                                observation.matrix.typed,
                                                                baseline.matrix.typed,
                                                                coord.km.df))
    cylinders[,c('n_obs.untyped', 'mu.untyped', 'p.val.untyped')] = t(apply(cylinders, 1, compute,
                                                                            observation.matrix.untyped,
                                                                            baseline.matrix.untyped,
                                                                            coord.km.df))
  }else{
    cat("No (typed) cases in the selected week range.\n")
  }
  cylinders$warning = (cylinders$p.val.typed < p.val.threshold) | (cylinders$p.val.untyped < p.val.threshold)
  print(Sys.time() - init)
  return(cylinders)
}

SaveCylinders<-function(cylinders, file.basename){
  write.csv(cylinders, paste0(file.basename,'.csv'), quote = F, row.names = F)
  save.and.tell("cylinders", file = paste0(file.basename,'.RData'))
}

Evaluate<-function(case.file, cylinders, emmtype, p.val.threshold = 0.05,
                          warning.score.name = 'warning.score', date.time.field = 'SAMPLE_DT_numeric'){
  case.df<-tryCatch({
    load(paste0(case.file, ".RData"))
    case.df
  },
  error = function(e){
    case.df = Init(case.file)
    return(case.df$case.df)
  })
  if (!('x' %in% names(case.df) & ('y' %in% names(case.df)))){
    writeLines("Inserting coordinates...")
    if (!('latitude' %in% names(case.df) & ('longitude' %in% names(case.df)))){
      case.df[,c("latitude", "longitude")] = t(apply(case.df, 1, postcode.to.location2))
    }
    case.df[,c("y", "x")] = vlatlong2km(case.df[,c("latitude", "longitude")])
    writeLines("...Done.")
    save.and.tell('case.df', file=paste0(case.file, ".RData"))
  }
  idx = case.df$emmtype == emmtype
  writeLines(paste0("Computing warning scores for emmtype ", emmtype, "..."))
  case.df[idx, warning.score.name] = apply(case.df[idx,], 1, FUN=warning.score, cylinders, date.time.field)
  writeLines("...Done.")
  return(case.df)
}

Cluster<-function(case.df, emmtype, makeplot=FALSE, warning.score='warning.score'){
  if(requireNamespace("tsne")){
    # idx = rownames(observation.matrix) != 'NA'
    # observation.matrix = observation.matrix[idx,]
    # idx = rownames(postcode2coord.km) != 'NA'
    # postcode2coord.km = postcode2coord.km[idx,]
    # cases = which(observation.matrix>0, arr.ind=TRUE)
    # cases = as.data.frame(cases)
    # c3 = apply(cases, 1, function(x){postcode2coord.km[x['row'], 3]})
    # c2 = apply(cases, 1, function(x){postcode2coord.km[x['row'], 2]})
    # cases2 = cbind(cases,c2,c3)
    idx = ((case.df$emmtype == emmtype) & !is.na(case.df$x))
    case.df = case.df[idx, ]
    X = tsne(case.df[,c('x', 'y', 'SAMPLE_DT_numeric')])
    # palette = colorRampPalette(c('blue', 'red'))(max(case.df$SAMPLE_DT_numeric))
    if (makeplot == TRUE){
      if(requireNamespace(viridisLite)){
        palette = viridis(max(case.df$SAMPLE_DT_numeric), begin = 0, end = 1)
      }else{

      }
      warning.marker = 20 #ifelse(case.df[,warning.score] > 0.9, 20, 1)
      plot(X[,1],X[,2], xlab='C1', ylab='C2', col=palette[case.df$SAMPLE_DT_numeric], pch=warning.marker,
           main=emmtype)

      palette = viridis(max(case.df$SAMPLE_DT_numeric), alpha = 1, begin = 0, end = 1)
      idx = ifelse(case.df[,warning.score] > 0.9, T, F)
      points(X[idx,1],X[idx,2], xlab='C1', ylab='C2', col=palette[case.df[idx, "SAMPLE_DT_numeric"]], pch=1, cex=2)
    }
    return(X)
  }else{
    writeLines("This function requires tsne package.")
  }
}


#!/usr/bin/env Rscript
#
# Use WGCNA to make a network.
#

library(data.table)
library(WGCNA)

options(stringsAsFactors=FALSE)

argv = commandArgs(trailingOnly=TRUE)

geno_file = argv[1]
ld_var_file = argv[2]
block_size = as.numeric(argv[3])
n_threads = as.numeric(argv[4])
trans_pow = as.numeric(argv[5])

enableWGCNAThreads(n_threads)

# Get list of variants
vars_to_use = scan(ld_var_file, what='character')

# Read in genotype data
geno_data = fread(geno_file, header=TRUE)

# Remove unwanted variants
geno_data = geno_data[geno_data$rs %in% vars_to_use, ]

# Transform into WGCNA format and eliminate variants with no
# variation
geno_mat = t(geno_data[, -(1:3)])
geno_sd = apply(geno_data, 2, sd, na.rm=TRUE)
geno_mat = geno_mat[, geno_sd > 0]

# Check for excessive missing data and remove samples and variants
# if necessary
gsg = goodSamplesGenes(geno_mat, verbose=3)
cat('No missing data issues?', gsg$allOK, '\n')
if(!gsg$allOK) {
    # Optionally, print the gene and sample names that were removed:
    if (sum(!gsg$goodGenes)>0)
        printFlush(paste('Removing genes:', paste(names(geno_mat)[!gsg$goodGenes], collapse=', ')))
    if (sum(!gsg$goodSamples)>0)
        printFlush(paste('Removing samples:', paste(rownames(geno_mat)[!gsg$goodSamples], collapse=', ')))
    # Remove the offending genes and samples from the data:
    geno_mat = geno_mat[gsg$goodSamples, gsg$goodGenes]
}

# Make the network; there are lots of options to tinker with
# in this function
net = blockwiseModules(geno_mat, maxBlockSize=block_size,
                         power=trans_pow,
                         TOMType='unsigned', minModuleSize=10,
                         reassignThreshold=0, mergeCutHeight=0.25,
                         numericLabels=TRUE,
                         saveTOMs=TRUE,
                         saveTOMFileBase="output.wgcna",
                         verbose=3)

# Plotting
pdf('output.wgnca.dendrogram.pdf', width=12, height=9)
clrs = labels2colors(net$colors)
plotDendroAndColors(net$dendrograms[[1]], clrs[net$blockGenes[[1]]],
                    'Module colors',
                    dendroLabels=FALSE, hang=0.03,
                    addGuide=TRUE, guideHang=0.05)
dev.off()


Edge Path 0:
1 -> 2
2 -> 4
4 -> 1
1 -> 3
3 -> 1
1 -> 4
Edge Path 1:
1 -> 2
2 -> 4
4 -> 1
1 -> 3
3 -> 3
3 -> 4


library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for each of the three data sets coming out of the experiment
# "equifinality-4", for binary analysis.
#
# Assumes that data-preparation.r has previously loaded CSV files and created binary
# data files, stored in a local data directory.
#
# Reduces the four class data into a two class problem for basic classifier analysis, and it splits off
# a test data set, placing it in the environment.
#
# NOTE:  This analysis takes a LONG time to run, so it is kept separate from the Rmarkdown
# analysis script.  At the completion of the analysis, it saves an environment image, which
# other scripts, such as RMarkdown documents, can load, and access the fitted model popsampled_results.
#
# Only the model training and fitting is done in this script.  The test data set is not analyzed
# here, since it can be done quickly enough that I want to be working in RMarkdown to examine different
# options.

log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "population-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4", filename = "equifinality-3-4-population-data.rda", args = clargs)
}

load(pop_data_file)

flog.info("Loaded data file: %s", pop_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-4 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (2:10)*50,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# set up popsampled_results data frames
experiment_names <- c("Population Census")
popsampled_results <- data.frame()

results_roc <- NULL
results_model <- NULL
results_cm <- NULL

###### Population Data ######

flog.info("Starting analysis of population census data", name='cl')

# first row of results
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq4_pop_df$two_class_label <- factor(ifelse(eq4_pop_df$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate")

#######

#model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq4_pop_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

results_model[["population_census"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
results_cm[["population_census"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
results_roc[["population_census"]]  <- population_roc

results <- rbind(popsampled_results, results)

############## Complete Processing and Save popsampled_results ##########3

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duratio
#plot_multiple_roc_from_list(popsampled_results_roc)

if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "classification-population-results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "classification-population-results-gbm-dfOnly.RData")

} else {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                              filename = "classification-population-results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-4",
                                      filename = "classification-population-results-gbm-dfOnly.RData", args = clargs)
}

flog.info("Saving results of analysis to R environment snapshot: %s", image_file, name='cl')
save(results, results_model, results_roc, results_cm, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(results, file=image_file_results)

# End
flog.info("Analysis complete", name='cl')