# National Monuments Analysis - Generate zonal statistics for protected areas

library(raster)
library(sp)
library(sf)
library(rgeos)
library(rgdal)
library(dplyr)
library(ggplot2)
library(tidyverse)
library(rvest)
library(maptools)
library(matrixStats)
library(velox)
library(doParallel)
library(foreach)
library(snow)

infolder <- "C:/Users/Tyler/Desktop/Monuments/GeneratedData"  # data folder

###################################################################################################################################################
# specify which geographic subset you want to work with:
subset <- "lower48"   # options are "lower48", "east", or "west"
###################################################################################################################################################

### READ IN PREPPED SPATIAL DATA
rich.bird <- raster(paste(infolder, "/rich.bird.tif", sep=""))  # bird richness
rich.mammal <- raster(paste(infolder, "/rich.mammal.tif", sep=""))  # mammal richness
rich.tree <- raster(paste(infolder, "/rich.tree.tif", sep=""))  # tree richness
rich.reptile <- raster(paste(infolder, "/rich.reptile.tif", sep=""))  # reptile richness
rich.fish <- st_read(paste(infolder, "/rich.fish.shp", sep=""), stringsAsFactors=FALSE)  # fish richness
rich.amphib <- st_read(paste(infolder, "/rich.amphib.shp", sep=""), stringsAsFactors=FALSE)  # amphibian richness
rich.natserv <- raster(paste(infolder, "/natserv.tif", sep=""))  # rarity weighted richness from NatureServ
natlandcover <- raster("C:/Users/Tyler/Desktop/Monuments/GeneratedData/gap_landfire_nationalterrestrialecosystems2011/gap_landfire_nationalterrestrialecosystems2011.tif")  # ecological systems
impervious <- raster(paste(infolder, "/impervious.tif", sep=""))  # percent impervious surface
climate <- raster(paste(infolder, "/climate.tif", sep=""))   # climate refugial potential
PA <- st_read(paste(infolder, "/post1996_PAs_", subset, ".shp", sep=""), stringsAsFactors=FALSE)   # protected area polygons
# rename attributes (st_write abbreviates these to match ESRI character limitations)
names(PA) <- c("UnitName", "InReview", "CurDesType","CurDesAuth", "OriDesAuth", "CurDesYear", "AntiqYear", "area_m2", "area_ac", "DesMode", "clipped_area_m2", "clipped_area_ac", "clipped_fraction", "geometry")
st_crs(PA) <- proj4string(natlandcover)
PA.sp <- as(PA, "Spatial") # convert sf polygon layer to a spatial layer first (required for extract function)

### GET MEAN PERCENT IMPERVIOUS SURFACE FOR EACH PA
mean.impervious <- as.vector(raster::extract(impervious, y=PA.sp, fun=mean, na.rm=TRUE, progress="window"))  # extract percent impervious pixels within each PA
cell.count <- raster::extract(natlandcover, y=PA.sp, na.rm=TRUE, progress="window")  # get number of natlandcover pixels associated with each PA (will tell me how many can be sampled in rarefaction for ecological systems richness)
cell.count.vect <- unlist(lapply(cell.count, length))

# remove PAs that have >1/3 impervious surface or are Redesignated PAs
impervious.discards <- c("First Ladies National Historic Site", "New Bedford Whaling National Historical Park", "Stonewall National Monument", # list of PAs with >
              "Carter G. Woodson National Historic Site", "Pullman National Monument", "Birmingham Civil Rights National Monument",
              "Belmont-Paul Women's Equality National Monument", "Little Rock Central High School National Historic Site",
              "President William Jefferson Clinton Birthplace Home National Historic Site", "Manhattan Project National Historical Park",
              "African Burial Ground National Monument", "Ronald Reagan Boyhood Home National Historic Site")
desmode.discards <- c("Pinnacles National Park", "Great Sand Dunes National Park", "Great Sand Dunes National Preserve", "Black Canyon of the Gunnison National Park",
                      "First State National Historical Park", "Harriet Tubman Underground Railroad National Historical Park")
discards <- c(impervious.discards, desmode.discards)
PA.keep <- PA[-which(PA$UnitName %in% discards),]
PA.discard <- PA[which(PA$UnitName %in% discards),]
PA.keep.sp <- as(PA.keep, "Spatial")

### PA ZONAL STATISTICS FOR RASTER INPUTS ###
inputnames <- c("climate", "rich.bird", "rich.mammal", "rich.tree", "rich.reptile", "rich.natserv")  # rasters for which we want to calculate zonal stats
for(i in 1:length(inputnames)) {  # calculate zonal stats for each input raster
  start <- Sys.time()
  zonalvals <- raster::extract(x=get(inputnames[i]), y=PA.keep.sp, weights=TRUE, progress="window")  # extract raster values and weights (e.g., cell area proportions) within each PA polygon
  prop.nonNA <- sapply(zonalvals, function(x) sum(x[which(is.na(x[,1])==FALSE),2]) / sum(x[,2]))  # get proportion of PA area that is non-NA (i.e., has value in raster layer)
  meanvals <- sapply(zonalvals, function(x) ifelse(sum(is.na(x[,1])==FALSE)==0, NA, weightedMean(x[,1], x[,2], na.rm=TRUE)))   # calculate weighted mean (excluding NA cells)
  meanvals[which(prop.nonNA<0.9)] <- NA   # set mean val to NA for PAs with data available for <90% of their area
  assign(paste("mean",inputnames[i],sep="."),meanvals)  # write to output variable
  maxvals <- sapply(zonalvals, function(x) ifelse(sum(is.na(x[,1])==FALSE)==0, NA, max(x[,1], na.rm=TRUE))) # calculate max
  maxvals[which(prop.nonNA<0.9)] <- NA    # set max val to NA for PAs with data available for <90% of their area
  assign(paste("max",inputnames[i],sep="."),maxvals)   # write to output variable
  minvals <- sapply(zonalvals, function(x) ifelse(sum(is.na(x[,1])==FALSE)==0, NA, min(x[,1], na.rm=TRUE)))# calculate min
  minvals[which(prop.nonNA<0.9)] <- NA    # set min val to NA for PAs with data available for <90% of their area
  assign(paste("min",inputnames[i],sep="."),minvals)   # write to output variable
  end <- Sys.time()
  process <- end - start   # calculate processing time
  print(paste0(i, "Process=", process))
}

### PA ZONAL STATISTICSS FOR ECOLOGICAL SYSTEM RICHNESS ###

# use rarefaction method to account for differences in PA area
ecol.systems <- raster::extract(natlandcover, PA.keep.sp, progress="window")  # list of ecological systems (by ID) within each PA
system.richness <- as.numeric(lapply(ecol.systems, function(x) length(unique(x[is.na(x)==FALSE])))) # calculate raw number of ecological systems (i.e., without controlling for PA area)
mincells <- min(unlist(lapply(ecol.systems, function(x) length(x[is.na(x)==FALSE]))))  # get smallest number of non-NA cells within a PA
nsamples <- 1000  # number of random samples you want to use for rarefaction
richness.mat <- matrix(nrow=length(ecol.systems), ncol=nsamples) # preallocate matrix to hold means of sample
for(i in 1:nsamples) {  # loop through 1000 random samples
  sample.data <- lapply(ecol.systems, function(x) sample(x[is.na(x)==FALSE], size=mincells, replace=FALSE))  # sample mincells (without replacement) from non-NA values for each PA
  sample.richness <- as.numeric(lapply(sample.data, function(x) length(unique(x)))) # calculate number of unique values in sample (i.e., richness)
  richness.mat[,i] <- sample.richness  # write richness values for sample i to matrix
}
system.richness.rare <- rowMeans(richness.mat)  # calculate mean across samples for each PA
# set richness value to NA for PAs with <90 percent non-NA data
prop.nonNA <- lapply(ecol.systems, function(x) 1 - sum(is.na(x)) / length(x))
system.richness[prop.nonNA<0.9] <- NA
system.richness.rare[prop.nonNA<0.9] <- NA

### PA ZONAL STATISTICS FOR VECTOR INPUTS ###

# Fish richness
temp.rich.fish <- st_intersection(rich.fish, PA.keep) %>%  # intersect PAs and richness polygons
  mutate(intersectPolyArea =  as.numeric(st_area(geometry))) %>%  # calculate areas of intersection polygons
  group_by(UnitName) %>%  # group intersection polygons by PA
  mutate(sumIntersectArea = sum(intersectPolyArea)) %>% # get the sum of intersect polygon areas associated with each PA (could be different than PA area because of missing data (e.g., watersheds with no fish richness))
  mutate(overlapProportion = intersectPolyArea/sumIntersectArea) %>% # get the proportion of the summed intersect areas associated with each intersect polygon (these are the "weights")
  group_by(UnitName) %>%
  summarise(weightedMean = weightedMean(Join_Count, overlapProportion, na.rm=TRUE), weightedMedian = weightedMedian(Join_Count, overlapProportion, na.rm=TRUE), max=max(Join_Count), min=min(Join_Count), prop.nonNA=mean(sumIntersectArea)/mean(clipped_area_m2))  # get weighted mean, weighted median, maximum, minimum, and proportion of the total PA area with non-NA values
# for those PAs with less than 90% coverage of non-NA richness data, assign overall NA value
temp.rich.fish$weightedMean[temp.rich.fish$prop.nonNA<0.9] <- NA
temp.rich.fish$weightedMedian[temp.rich.fish$prop.nonNA<0.9] <- NA
temp.rich.fish$max[temp.rich.fish$prop.nonNA<0.9] <- NA
temp.rich.fish$min[temp.rich.fish$prop.nonNA<0.9] <- NA
# deal with PAs that overlap blank spots in richness map, and are therefore not represented in results of above richness calculation
rich.fish.df <- data.frame(UnitName=temp.rich.fish$UnitName, weightedMean=temp.rich.fish$weightedMean, weightedMedian=temp.rich.fish$weightedMedian, max=temp.rich.fish$max, min=temp.rich.fish$min, stringsAsFactors=FALSE) # create dataframe out of temp.rich.fish
fish.PAnames <- rich.fish.df$UnitName  # get list of PA names in the richness output
all.PAnames <- PA.keep$UnitName  # get list of all PA names, including those missing from richness output
'%notin%' <- function(x,y) !(x %in% y)
missing.fish.PAnames <- PA.keep$UnitName[which(PA.keep$UnitName %notin% rich.fish.df$UnitName)]  # find PAs missing from richness output
rich.fish.df.corrected <- data.frame(UnitName=c(rich.fish.df$UnitName, missing.fish.PAnames), mean.rich.fish=c(rich.fish.df$weightedMean, rep(NA, length(missing.fish.PAnames))), median.rich.fish=c(rich.fish.df$weightedMedian, rep(NA, length(missing.fish.PAnames))), max.rich.fish=c(rich.fish.df$max, rep(NA, length(missing.fish.PAnames))), min.rich.fish=c(rich.fish.df$min, rep(NA, length(missing.fish.PAnames))))  # add missing PAs to new dataframe with NA for mean, min, and max richness value

# Amphibian richness
temp.rich.amphib <- st_intersection(rich.amphib, PA.keep) %>%  # intersect PAs and richness polygons
  mutate(intersectPolyArea =  as.numeric(st_area(geometry))) %>%  # calculate areas of intersection polygons
  group_by(UnitName) %>%  # group intersection polygons by PA
  mutate(sumIntersectArea = sum(intersectPolyArea)) %>% # get the sum of intersect polygon areas associated with each PA (could be different than PA area because of missing data (e.g., watersheds with no amphib richness))
  mutate(overlapProportion = intersectPolyArea/sumIntersectArea) %>% # get the proportion of the summed intersect areas associated with each intersect polygon (these are the "weights")
  group_by(UnitName) %>%
  summarise(weightedMean = weightedMean(Join_Count, overlapProportion, na.rm=TRUE), weightedMedian = weightedMedian(Join_Count, overlapProportion, na.rm=TRUE), max=max(Join_Count), min=min(Join_Count), prop.nonNA=mean(sumIntersectArea)/mean(clipped_area_m2))  # get weighted mean, weighted median, maximum, minimum, and proportion of the total PA area with non-NA values
# for those PAs with less than 90% coverage of non-NA richness data, assign overall NA value
temp.rich.amphib$weightedMean[temp.rich.amphib$prop.nonNA<0.9] <- NA
temp.rich.amphib$weightedMedian[temp.rich.amphib$prop.nonNA<0.9] <- NA
temp.rich.amphib$max[temp.rich.amphib$prop.nonNA<0.9] <- NA
temp.rich.amphib$min[temp.rich.amphib$prop.nonNA<0.9] <- NA
# deal with PAs that overlap blank spots in richness map, and are therefore not represented in results of above richness calculation
rich.amphib.df <- data.frame(UnitName=temp.rich.amphib$UnitName, weightedMean=temp.rich.amphib$weightedMean, weightedMedian=temp.rich.amphib$weightedMedian, max=temp.rich.amphib$max, min=temp.rich.amphib$min, stringsAsFactors=FALSE) # create dataframe out of temp.rich.amphib
amphib.PAnames <- rich.amphib.df$UnitName  # get list of PA names in the richness output
all.PAnames <- PA.keep$UnitName  # get list of all PA names, including those missing from richness output
'%notin%' <- function(x,y) !(x %in% y)
missing.amphib.PAnames <- PA.keep$UnitName[which(PA.keep$UnitName %notin% rich.amphib.df$UnitName)]  # find PAs missing from richness output
rich.amphib.df.corrected <- data.frame(UnitName=c(rich.amphib.df$UnitName, missing.amphib.PAnames), mean.rich.amphib=c(rich.amphib.df$weightedMean, rep(NA, length(missing.amphib.PAnames))), median.rich.amphib=c(rich.amphib.df$weightedMedian, rep(NA, length(missing.amphib.PAnames))), max.rich.amphib=c(rich.amphib.df$max, rep(NA, length(missing.amphib.PAnames))), min.rich.amphib=c(rich.amphib.df$min, rep(NA, length(missing.amphib.PAnames))))  # add missing PAs to new dataframe with NA for mean, min, and max richness value

# SOCIOPOLITICAL VARIABLE ZONAL STATS

# buffer PAs by difference distances (units are m)
PA.econproj <- st_transform(PA.keep, proj4string(forestry.stack)) # reproject PA layer to match economic layers
PA.buf10 <- st_buffer(PA.econproj, dist=10000)
PA.buf20 <- st_buffer(PA.econproj, dist=20000)
PA.buf50 <- st_buffer(PA.econproj, dist=50000)
PA.buf100 <- st_buffer(PA.econproj, dist=100000)
PA.buf250 <- st_buffer(PA.econproj, dist=250000)

# clip buffers to lower48
'%notin%' <- function(x,y) !(x %in% y)  #remove islands (HA, PR, VI) and AK, then dissolve
states <- st_read(paste(infolder,"/states2.shp",sep="")) %>%
  filter(STATE %notin% c("Hawaii","Puerto Rico","U.S. Virgin Islands", "Alaska"))
lower48 <- st_union(states, by_feature=FALSE)# create outline polygon for lower 48 states
lower48 <- st_transform(lower48, proj4string(forestry.stack))
croplayernames <- c("PA.buf10", "PA.buf20", "PA.buf50", "PA.buf100", "PA.buf250")  # names of layers you want to crop
lower48.sp <- as(lower48, "Spatial") # convert lower48 sf layer to sp (so extent can be extracted by crop function)
for(k in 1:length(croplayernames)) {
  sp.input <- as(get(croplayernames[k]), "Spatial")
  temp <- raster::crop(sp.input, lower48.sp, progress = 'text')
  assign(croplayernames[k], temp)
}
PA.buf.list <- list(PA.buf10, PA.buf20, PA.buf50, PA.buf100, PA.buf250) # combine buffer layers in a list
bufdists <- c("10km", "20km", "50km", "100km", "250km")

# Set up parallel processing
UseCores <- detectCores() - 1   # number of cores (leave one open for other processing tasks)
cl <- makeCluster(UseCores)  # initiate cluster
registerDoParallel(cl)   # register cluster

# FORESTRY: calculate mean, min, and max values for each PA (at each buffer level)
forestry.stack <- stack(list.files("C:/Users/Tyler/Desktop/Monuments/GeneratedData/TimberRasters/", full.names=TRUE))  # read in annual forestry rasters as stacks
forestry.out <- foreach(i=1:length(PA.buf.list), .packages=c("raster", "sf", "sp")) %dopar% {# loop through buffer distances (parallelize with foreach?)
  PA.buf.select <- PA.buf.list[[i]]  # pull the correct buffered PA layer
  out.df <- data.frame(mean.val=rep(NA,nrow(PA.buf.select)), min.val=rep(NA,nrow(PA.buf.select)), max.val=rep(NA,nrow(PA.buf.select)))
  for(j in 1:length(PA.buf.select)){ # loop through individual PAs
    PA.indiv.select <- PA.buf.select[j,] # pull the correct individual PA polygon
    min.year <- as.numeric(PA.indiv.select$CurDesYear) - 8  # start year for assessing econ for selected PA
    max.year <- min(2015,(as.numeric(PA.indiv.select$CurDesYear)-1))  # end year for assessing econ for select PA
      # I used min argument in above line, because we only have econ data through 2015, so code would otherwise break for PAs designated in 2017
    forestry.stack.subset <- subset(forestry.stack, subset=(min.year-1986):(max.year-1986))  # subset the stack to the appropriate set of 8 years
    bbox <- extent(as(PA.indiv.select, "Spatial"))  # get bounding box for polygon
    forestry.stack.subset.crop <- crop(forestry.stack.subset, bbox)  # crop stack to the minimum bounding box of the buffered polygon (will make following steps much faster)
    mean.rast <- calc(forestry.stack.subset.crop, fun=mean) # calculate pixel-wise mean across the years in the stack
    zonalvals <- unlist(raster::extract(x=mean.rast, y=PA.indiv.select))  # extract raster values and weights (e.g., cell area proportions) within each PA polygon
    prop.nonNA <- length(which(is.na(zonalvals)==FALSE)) / length(zonalvals)  # get proportion of PA area that is non-NA (i.e., has value in raster layer)
    if(prop.nonNA>=0.9) {  # for PAs with >90% data coverage, calculate statistics
      out.df$mean.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, mean(zonalvals, na.rm=TRUE))
      out.df$min.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, min(zonalvals, na.rm=TRUE))
      out.df$max.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, max(zonalvals, na.rm=TRUE))
    }
  }
  return(out.df)
}
# output is a list of dataframes (one per PA buffer layer), with each dataframe giving the mean, min, and max forestry values for cells within each PA
# convert dataframe to set of vectors with informative names
for(i in 1:length(forestry.out)){ # loop through dataframes (one per buffer distance)
  df <- forestry.out[[i]]
  assign(paste0("mean.forestry.",bufdists[i],"Buffer"), df$mean.val)
  assign(paste0("min.forestry.",bufdists[i],"Buffer"), df$min.val)
  assign(paste0("max.forestry.",bufdists[i],"Buffer"), df$max.val)
}

# MINING: calculate mean, min, and max values for each PA (at each buffer level)
mining.stack <- stack(list.files("C:/Users/Tyler/Desktop/Monuments/GeneratedData/MineRasters/MineRst/", full.names=TRUE))  # read in annual mining rasters as stack
mining.out <- foreach(i=1:length(PA.buf.list), .packages=c("raster", "sf", "sp")) %dopar% {# loop through buffer distances (parallelize with foreach?)
  PA.buf.select <- PA.buf.list[[i]]  # pull the correct buffered PA layer
  out.df <- data.frame(mean.val=rep(NA,nrow(PA.buf.select)), min.val=rep(NA,nrow(PA.buf.select)), max.val=rep(NA,nrow(PA.buf.select)))
  for(j in 1:length(PA.buf.select)){ # loop through individual PAs
    PA.indiv.select <- PA.buf.select[j,] # pull the correct individual PA polygon
    min.year <- as.numeric(PA.indiv.select$CurDesYear) - 8  # start year for assessing econ for selected PA
    max.year <- min(2015,(as.numeric(PA.indiv.select$CurDesYear)-1))  # end year for assessing econ for select PA
    # I used min argument in above line, because we only have econ data through 2015, so code would otherwise break for PAs designated in 2017
    mining.stack.subset <- subset(mining.stack, subset=(min.year-1986):(max.year-1986))  # subset the stack to the appropriate set of 8 years
    bbox <- extent(as(PA.indiv.select, "Spatial"))  # get bounding box for polygon
    mining.stack.subset.crop <- crop(mining.stack.subset, bbox)  # crop stack to the minimum bounding box of the buffered polygon (will make following steps much faster)
    mean.rast <- calc(mining.stack.subset.crop, fun=mean) # calculate pixel-wise mean across the years in the stack
    zonalvals <- unlist(raster::extract(x=mean.rast, y=PA.indiv.select))  # extract raster values and weights (e.g., cell area proportions) within each PA polygon
    prop.nonNA <- length(which(is.na(zonalvals)==FALSE)) / length(zonalvals)  # get proportion of PA area that is non-NA (i.e., has value in raster layer)
    if(prop.nonNA>=0.9) {  # for PAs with >90% data coverage, calculate statistics
      out.df$mean.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, mean(zonalvals, na.rm=TRUE))
      out.df$min.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, min(zonalvals, na.rm=TRUE))
      out.df$max.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, max(zonalvals, na.rm=TRUE))
    }
  }
  return(out.df)
}
# output is a list of dataframes (one per PA buffer layer), with each dataframe giving the mean, min, and max mining values for cells within each PA
# convert dataframe to set of vectors with informative names
for(i in 1:length(mining.out)){ # loop through dataframes (one per buffer distance)
  df <- mining.out[[i]]
  assign(paste0("mean.mining.",bufdists[i],"Buffer"), df$mean.val)
  assign(paste0("min.mining.",bufdists[i],"Buffer"), df$min.val)
  assign(paste0("max.mining.",bufdists[i],"Buffer"), df$max.val)
}

# LCV: calculate mean, min, and max values for each PA (at each buffer level)
# read in LCV rasters - need to change to have common extent before stacking
lcv.names <- as.list(list.files("C:/Users/Tyler/Desktop/Monuments/GeneratedData/LCVRasters/", full.names=TRUE))
lcv.rasters <- lapply(lcv.names, raster)
# write function for getting maximum extent from list of rasters (to be called within for loop)
getMaxExtent <- function(rasters) {
  extents <- sapply(rasters, FUN = function(x) {
    raster::extent(x)
  })
  r <- raster(ext = extents[[1]], nrows = rasters[[1]]@nrows, ncols = rasters[[1]]@ncols)
  max_extent <- sapply(extents, FUN = function(x) {
    r <<- raster::extend(r, x)
  })
  raster::extent(r)
}
lcv.maxExtent <- getMaxExtent(lcv.rasters)  # get maximum extent
lcv.rasters.extend <- lapply(lcv.rasters, function(x) {extend(x, lcv.maxExtent, value=NA)}) # extend all rasters to maximum extent to allow stacking
LCV.stack <- stack(lcv.rasters.extend)  # stack mosaicked outputs with common extent

LCV.out <- foreach(i=1:length(PA.buf.list), .packages=c("raster", "sf", "sp")) %do% {# parallel version maxes out HAL's memory, so use sequential version
#LCV.out <- foreach(i=1:length(PA.buf.list), .packages=c("raster", "sf", "sp")) %dopar% {# loop through buffer distances (parallelize with foreach?)
  PA.buf.select <- PA.buf.list[[i]]  # pull the correct buffered PA layer
  out.df <- data.frame(mean.val=rep(NA,nrow(PA.buf.select)), min.val=rep(NA,nrow(PA.buf.select)), max.val=rep(NA,nrow(PA.buf.select)))
  for(j in 1:length(PA.buf.select)){ # loop through individual PAs
    PA.indiv.select <- PA.buf.select[j,] # pull the correct individual PA polygon
    min.year <- as.numeric(PA.indiv.select$CurDesYear) - 8  # start year for assessing LCV for selected PA
    max.year <- min(2016,(as.numeric(PA.indiv.select$CurDesYear)-1))  # end year for assessing LCV for select PA
    # I used min argument in above line, because we only have LCV data through 2016, so code would otherwise break for PAs designated in 2017
    LCV.stack.subset <- subset(LCV.stack, subset=(min.year-1971):(max.year-1971))  # subset the stack to the appropriate set of 8 years
    bbox <- extent(as(PA.indiv.select, "Spatial"))  # get bounding box for polygon
    LCV.stack.subset.crop <- crop(LCV.stack.subset, bbox)  # crop stack to the minimum bounding box of the buffered polygon (will make following steps much faster)
    mean.rast <- calc(LCV.stack.subset.crop, fun=mean) # calculate pixel-wise mean across the years in the stack
    zonalvals <- unlist(raster::extract(x=mean.rast, y=PA.indiv.select))  # extract raster values and weights (e.g., cell area proportions) within each PA polygon
    prop.nonNA <- length(which(is.na(zonalvals)==FALSE)) / length(zonalvals)  # get proportion of PA area that is non-NA (i.e., has value in raster layer)
    if(prop.nonNA>=0.9) {  # for PAs with >90% data coverage, calculate statistics
      out.df$mean.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, mean(zonalvals, na.rm=TRUE))
      out.df$min.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, min(zonalvals, na.rm=TRUE))
      out.df$max.val[j] <- ifelse(sum(is.na(zonalvals)==FALSE)==0, NA, max(zonalvals, na.rm=TRUE))
    }
    rm(LCV.stack.subset, bbox, LCV.stack.subset.crop, zonalvals, PA.indiv.select)
    gc()
  }
  return(out.df)
}
# output is a list of dataframes (one per PA buffer layer), with each dataframe giving the mean, min, and max forestry values for cells within each PA
# convert dataframe to set of vectors with informative names
for(i in 1:length(LCV.out)){ # loop through dataframes (one per buffer distance)
  df <- LCV.out[[i]]
  assign(paste0("mean.LCV.",bufdists[i],"Buffer"), df$mean.val)
  assign(paste0("min.LCV.",bufdists[i],"Buffer"), df$min.val)
  assign(paste0("max.LCV.",bufdists[i],"Buffer"), df$max.val)
}

stopCluster(cl)

### REORDER OUTPUTS FROM RASTER OPERATIONS ALPHABETICALLY ###

# Output variables from raster extract are sorted by FID, but outputs from sp operations were sorted alphabetically because the dplyr function "group_by" was used and it automatically alphabetizes results
names.by.alpha <- sort(PA.keep$UnitName)  # alphabetical vector of unit names
names.by.fid <- PA.keep$UnitName   # vector of unit names by FID
reorder <- match(names.by.alpha, names.by.fid)  # order in which elements from raster extract outputs should appear to be alphabetically ordered
mean.climate <- mean.climate[reorder]
max.climate <- max.climate[reorder]
min.climate <- min.climate[reorder]
mean.rich.bird <- mean.rich.bird[reorder]
max.rich.bird <- max.rich.bird[reorder]
min.rich.bird <- min.rich.bird[reorder]
mean.rich.mammal <- mean.rich.mammal[reorder]
max.rich.mammal <- max.rich.mammal[reorder]
min.rich.mammal <- min.rich.mammal[reorder]
mean.rich.tree <- mean.rich.tree[reorder]
max.rich.tree <- max.rich.tree[reorder]
min.rich.tree <- min.rich.tree[reorder]
mean.rich.reptile <- mean.rich.reptile[reorder]
max.rich.reptile <- max.rich.reptile[reorder]
min.rich.reptile <- min.rich.reptile[reorder]
mean.rich.natserv <- mean.rich.natserv[reorder]
max.rich.natserv <- max.rich.natserv[reorder]
min.rich.natserv <- min.rich.natserv[reorder]
mean.impervious <- mean.impervious[reorder]
mean.forestry.10kmBuffer <- mean.forestry.10kmBuffer[reorder]
mean.forestry.20kmBuffer <- mean.forestry.20kmBuffer[reorder]
mean.forestry.50kmBuffer <- mean.forestry.50kmBuffer[reorder]
mean.forestry.100kmBuffer <- mean.forestry.100kmBuffer[reorder]
mean.forestry.250kmBuffer <- mean.forestry.250kmBuffer[reorder]
min.forestry.10kmBuffer <- min.forestry.10kmBuffer[reorder]
min.forestry.20kmBuffer <- min.forestry.20kmBuffer[reorder]
min.forestry.50kmBuffer <- min.forestry.50kmBuffer[reorder]
min.forestry.100kmBuffer <- min.forestry.100kmBuffer[reorder]
min.forestry.250kmBuffer <- min.forestry.250kmBuffer[reorder]
max.forestry.10kmBuffer <- max.forestry.10kmBuffer[reorder]
max.forestry.20kmBuffer <- max.forestry.20kmBuffer[reorder]
max.forestry.50kmBuffer <- max.forestry.50kmBuffer[reorder]
max.forestry.100kmBuffer <- max.forestry.100kmBuffer[reorder]
max.forestry.250kmBuffer <- max.forestry.250kmBuffer[reorder]
mean.mining.10kmBuffer <- mean.mining.10kmBuffer[reorder]
mean.mining.20kmBuffer <- mean.mining.20kmBuffer[reorder]
mean.mining.50kmBuffer <- mean.mining.50kmBuffer[reorder]
mean.mining.100kmBuffer <- mean.mining.100kmBuffer[reorder]
mean.mining.250kmBuffer <- mean.mining.250kmBuffer[reorder]
min.mining.10kmBuffer <- min.mining.10kmBuffer[reorder]
min.mining.20kmBuffer <- min.mining.20kmBuffer[reorder]
min.mining.50kmBuffer <- min.mining.50kmBuffer[reorder]
min.mining.100kmBuffer <- min.mining.100kmBuffer[reorder]
min.mining.250kmBuffer <- min.mining.250kmBuffer[reorder]
max.mining.10kmBuffer <- max.mining.10kmBuffer[reorder]
max.mining.20kmBuffer <- max.mining.20kmBuffer[reorder]
max.mining.50kmBuffer <- max.mining.50kmBuffer[reorder]
max.mining.100kmBuffer <- max.mining.100kmBuffer[reorder]
max.mining.250kmBuffer <- max.mining.250kmBuffer[reorder]
mean.LCV.10kmBuffer <- mean.LCV.10kmBuffer[reorder]
mean.LCV20kmBuffer <- mean.LCV.20kmBuffer[reorder]
mean.LCV.50kmBuffer <- mean.LCV.50kmBuffer[reorder]
mean.LCV.100kmBuffer <- mean.LCV.100kmBuffer[reorder]
mean.LCV.250kmBuffer <- mean.LCV.250kmBuffer[reorder]
min.LCV.10kmBuffer <- min.LCV.10kmBuffer[reorder]
min.LCV.20kmBuffer <- min.LCV.20kmBuffer[reorder]
min.LCV.50kmBuffer <- min.LCV.50kmBuffer[reorder]
min.LCV.100kmBuffer <- min.LCV.100kmBuffer[reorder]
min.LCV.250kmBuffer <- min.LCV.250kmBuffer[reorder]
max.LCV.10kmBuffer <- max.LCV.10kmBuffer[reorder]
max.LCV.20kmBuffer <- max.LCV.20kmBuffer[reorder]
max.LCV.50kmBuffer <- max.LCV.50kmBuffer[reorder]
max.LCV.100kmBuffer <- max.LCV.100kmBuffer[reorder]
max.LCV.250kmBuffer <- max.LCV.250kmBuffer[reorder]
system.richness <- system.richness[reorder]
system.richness.rare <- system.richness.rare[reorder]

### COMBINE OUTPUT VARIABLES IN A SINGLE DATAFRAME AND SAVE ###

PA.df <- tbl_df(PA.keep)[,-ncol(PA.keep)]  # convert to a tbl object (and strip out geometry field)
PA.df <- PA.df[order(PA.df$UnitName),]  # sort original dataframe alphabetically

outputvars <- c("mean.climate", "max.climate", "min.climate", "mean.rich.bird", "max.rich.bird", "min.rich.bird", "mean.rich.mammal", "max.rich.mammal", "min.rich.mammal",
                "mean.rich.tree", "max.rich.tree", "min.rich.tree", "mean.rich.reptile", "max.rich.reptile", "min.rich.reptile", "mean.rich.natserv", "max.rich.natserv",
                "min.rich.natserv", "system.richness", "system.richness.rare", "mean.impervious", "mean.forestry.10kmBuffer", "min.forestry.10kmBuffer", "max.forestry.10kmBuffer",
                "mean.forestry.20kmBuffer", "min.forestry.20kmBuffer", "max.forestry.20kmBuffer", "mean.forestry.50kmBuffer", "min.forestry.50kmBuffer", "max.forestry.50kmBuffer",
                "mean.forestry.100kmBuffer", "min.forestry.100kmBuffer", "max.forestry.100kmBuffer", "mean.forestry.250kmBuffer", "min.forestry.250kmBuffer", "max.forestry.250kmBuffer",
                "mean.mining.10kmBuffer", "min.mining.10kmBuffer", "max.mining.10kmBuffer", "mean.mining.20kmBuffer", "min.mining.20kmBuffer", "max.mining.20kmBuffer",
                "mean.mining.50kmBuffer", "min.mining.50kmBuffer", "max.mining.50kmBuffer","mean.mining.100kmBuffer", "min.mining.100kmBuffer", "max.mining.100kmBuffer",
                "mean.mining.250kmBuffer", "min.mining.250kmBuffer", "max.mining.250kmBuffer", "mean.LCV.10kmBuffer", "min.LCV.10kmBuffer", "max.LCV.10kmBuffer", "mean.LCV.20kmBuffer", "min.LCV.20kmBuffer", "max.LCV.20kmBuffer",
                "mean.LCV.50kmBuffer", "min.LCV.50kmBuffer", "max.LCV.50kmBuffer", "mean.LCV.100kmBuffer", "min.LCV.100kmBuffer", "max.LCV.100kmBuffer", "mean.LCV.250kmBuffer", "min.LCV.250kmBuffer", "max.LCV.250kmBuffer")  # vector of names of all output variables

for(i in 1:length(outputvars)){  # add each output variables as a new column in dataframe
  PA.df <- data.frame(PA.df, get(outputvars[i]))
}
names(PA.df)[(ncol(PA.df)-length(outputvars)+1):ncol(PA.df)] <- outputvars # give names to new output variables in dataframe
rich.fish.amphib.df <- merge(rich.fish.df.corrected, rich.amphib.df.corrected, by="UnitName")
PA.df <- merge(PA.df, rich.fish.amphib.df, by="UnitName")
PA_zonal.df <- PA.df
write.csv(PA_zonal.df, "C:/Users/Tyler/Desktop/PA_zonal_stats_post1996_lower48_28Oct2018.csv")  # write to csv
save(PA_zonal.df, file="C:/Users/Tyler/Desktop/PA_zonal_stats_post1996_lower48_28Oct2018.RData")  # output to workspace file

R code for calculating PA-level statistics.r


#SNOPSIS
#calculates kinship, indbreeding coefficients

#AUTHOR
# Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(methods)
library(rrBLUP)
library(plyr)
library(stringr)
#library(lme4)
library(randomForest)
library(parallel)
library(genoDataFilter)
library(dplyr)
library(tibble)
library(rlang)
library(jsonlite)
library(data.table)

allArgs <- commandArgs()

inputFiles  <- scan(grep("input_files", allArgs, value = TRUE),
                   what = "character")

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

genoData           <- c()

createGenoData <- function(inputFiles) {

    genoFiles <- grep("genotype_data", inputFiles,  value = TRUE)

    genoMetaData <- c()
    filteredGenoFile <- c()

    if (length(genoFiles) > 1) {
        genoData <- combineGenoData(genoFiles)

        genoMetaData   <- genoData$trial
        genoData$trial <- NULL

    } else {

        genoFile <- genoFiles
        genoData <- fread(genoFile,
                          header = TRUE,
                          na.strings = c("NA", " ", "--", "-", "."))

        if (is.null(genoData)) {
            filteredGenoFile <- grep("filtered_genotype_data_",  genoFile, value = TRUE)
            genoData <- fread(filteredGenoFile, header = TRUE)
        }

        genoData <- unique(genoData, by = 'V1')
        genoData <- data.frame(genoData)
        genoData <- column_to_rownames(genoData, 'V1')
    }

    if (is.null(genoData)) {
        stop("There is no genotype dataset.")
        q("no", 1, FALSE)
    } else {

        ##genoDataFilter::filterGenoData
       genoData <- convertToNumeric(genoData)
       genoData <- filterGenoData(genoData, maf=0.01)
       genoData <- roundAlleleDosage(genoData)

        message("No. of geno missing values, ", sum(is.na(genoData)))
        if (sum(is.na(genoData)) > 0) {
            genoData <- na.roughfix(genoData)
        }

        genoData <- data.frame(genoData)
    }
}

genoData <- createGenoData(inputFiles)
genoData <- genoData[order(row.names(genoData)), ]

#change genotype coding to [-1, 0, 1], to use the A.mat ) if  [0, 1, 2]
genoTrCode <- grep("2", genoData[1, ], value = TRUE)
if(length(genoTrCode) != 0) {
  genoData            <- genoData - 1
}

relationshipMatrixFile <- grep("relationship_matrix_adjusted_table", outputFiles, value = TRUE)
relationshipMatrixJsonFile <- grep("relationship_matrix_adjusted_json", outputFiles, value = TRUE)

message('matrix file ', relationshipMatrixFile)
message('json file ', relationshipMatrixJsonFile)

inbreedingFile <- grep('inbreeding_coefficients', outputFiles, value=TRUE)
aveKinshipFile <- grep('average_kinship', outputFiles, value=TRUE)

message('inbreeding file ', inbreedingFile)
message('ave file ', aveKinshipFile)

relationshipMatrix    <- c()
inbreeding <- c()
aveKinship <- c()
relationshipMatrixJson <- c()

relationshipMatrix           <- A.mat(genoData)
diag(relationshipMatrix)     <- diag(relationshipMatrix) + 1e-6
genos <- rownames(relationshipMatrix)

relationshipMatrix <- data.frame(relationshipMatrix)

colnames(relationshipMatrix) <- genos
rownames(relationshipMatrix) <- genos

relationshipMatrix <- relationshipMatrix %>%
    rownames_to_column('genotypes') %>%
	        mutate_if(is.numeric, round, 3) %>%
		    column_to_rownames('genotypes')

inbreeding <- diag(data.matrix(relationshipMatrix))
inbreeding <- inbreeding - 1
diag(relationshipMatrix) <- inbreeding

relationshipMatrix <- relationshipMatrix %>% replace(., . < 0, 0)

inbreeding <- inbreeding %>% replace(., . < 0, 0)
inbreeding <- data.frame(inbreeding)

inbreeding <- inbreeding %>%
    rownames_to_column('genotypes') %>%
    rename(Inbreeding = inbreeding) %>%
    arrange(Inbreeding) %>%
    mutate_at('Inbreeding', round, 3) %>%
    column_to_rownames('genotypes')

aveKinship <- data.frame(apply(relationshipMatrix, 1, mean))

aveKinship <- aveKinship %>%
    rownames_to_column('genotypes') %>%
    rename(Mean_kinship = contains('apply')) %>%
    arrange(Mean_kinship) %>%
    mutate_at('Mean_kinship', round, 3) %>%
    column_to_rownames('genotypes')

relationshipMatrixJson <- relationshipMatrix
relationshipMatrixJson[upper.tri(relationshipMatrixJson)] <- NA

#relationshipMatrixJson <- data.frame(relationshipMatrixJson)
relationshipMatrixList <- list(labels = names(relationshipMatrixJson),
                               values = relationshipMatrixJson)
relationshipMatrixJson <- jsonlite::toJSON(relationshipMatrixList)

#if (file.info(relationshipMatrixFile)$size == 0) {

  fwrite(relationshipMatrix,
         file  = relationshipMatrixFile,
         row.names = TRUE,
         sep   = "\t",
         quote = FALSE,
         )
#}

#if (file.info(relationshipMatrixJsonFile)$size == 0) {

    write(relationshipMatrixJson,
          file  = relationshipMatrixJsonFile,
          )
#}

message('inbreedingfile ', inbreedingFile)
message('ave file', aveKinshipFile)
message('kinshipfile ', relationshipMatrixFile)
#if (file.info(inbreedingFile)$size == 0) {

  fwrite(inbreeding,
         file  = inbreedingFile,
         row.names = TRUE,
         sep   = "\t",
         quote = FALSE,
         )
#}

#if (file.info(aveKinshipFile)$size == 0) {

    fwrite(aveKinship,
           file  = aveKinshipFile,
           row.names = TRUE,
           sep   = "\t",
           quote = FALSE,
           )
#}

message("Done.")

q(save = "no", runLast = FALSE)


library(tidyverse)
library(lubridate)
library(janitor)
library(scales)
library(plotly)
library(timetk)
library(forecast)

###
# Using the GSuite / Google Workplace GAMADV-XTD GAM CLI
# and R to build various data pipelines and
# plots showing daily, weekly and monthly
# changes and cumulative provisioning and deprovisioning events
# and changes in license availabilty
# Data is aggrated and plots are pre-built and saved quick
# loading and rendering in Shiny

# base_log started with initial six month gsuite log license assignment events
# 30 day log license assignment events gam script runs daily:
# "C:\GAMADV-XTD3\gam.exe" report admin event "USER_LICENSE_ASSIGNMENT"
#   start -30d > "C:\scripts\license_assignment_30d.csv"

base_log <- read_csv("c:/scripts/license_assignment_base.csv",
                     col_types = cols(.default = "c"))

last_30_log  <- read_csv("c:/scripts/license_assignment_30d.csv",
                         col_types = cols(.default = "c"))

admin_license_log <- bind_rows(base_log, last_30_log) %>%
  distinct(id.uniqueQualifier, .keep_all = TRUE)

#### UNCOMMENT THIS IN PRODUCTION !!!!  #####
write_csv(admin_license_log, "c:/scripts/license_assignment_base.csv")

admin_license_log$id.time <- admin_license_log$id.time %>%
  strftime(format = "%Y-%m-%d") %>% ymd()

# some days return no license assignment events so no log entry for dates
# need to fix with zeroes for later plotting
all_dates  <- as_tibble(tidyr::full_seq(admin_license_log$id.time,1))

admin_license_log <- admin_license_log %>%
  distinct(USER_EMAIL, .keep_all = TRUE) %>%
  filter(id.time >= "2020-09-01") %>%
  select(NEW_VALUE, USER_EMAIL, id.time) %>%
  mutate(
    license_type = case_when(
      NEW_VALUE == "G Suite Business - Archived User" ~ "archive",
      NEW_VALUE == "G Suite Business" ~ "gsuite")) %>%
  clean_names()

admin_license_log <- left_join(all_dates, admin_license_log, by = c("value" = "id_time"))

net__gsuite_license_log <- admin_license_log %>%
  group_by(day_date = value) %>%
  count(license_type) %>%
  pivot_wider(names_from = license_type, values_from = n) %>%
  rename(no_event = 'NA') %>%
  replace_na(list(archive = 0, gsuite = 0)) %>%
  mutate(net_change = gsuite - archive) %>%
  select(-no_event) %>%
  filter(day_date >= "2020-09-01")

net__gsuite_license_log$cumulative <- cumsum(net__gsuite_license_log$net_change)
net__gsuite_license_log$past_days <- as.integer(rownames(net__gsuite_license_log))
net__gsuite_license_log$past_days <- order(-net__gsuite_license_log$past_days)

net__gsuite_license_weeks <- net__gsuite_license_log %>%
  summarise_by_time(
    .date_var = day_date,
    .by       = "week",
    net_change  = sum(net_change),
    cumulative = last(cumulative)
  )

net__gsuite_license_months <- net__gsuite_license_log %>%
  summarise_by_time(
    .date_var = day_date,
    .by       = "month", # Setup for monthly aggregation
    net_change  = sum(net_change),     # Summarization
    cumulative = last(cumulative)
  )

### plots

# daily
daily_fig <- plot_ly(net__gsuite_license_log)%>%
  add_trace(x = ~day_date,
            y = ~net_change,
            type = 'bar',
            name = ~ifelse(net_change < 0, "Decrease", "Increase"),
            color = ~net_change < 0,
            colors = c("lawngreen", "red")) %>%
  add_trace(x = ~day_date, y = ~cumulative,
            type = 'scatter',
            mode = 'line',
            yaxis = 'y2',
            line = list(color = 'dodgerblue',
                        width = 4),
            name = "Cumulative") %>%
  layout(title = list(text = ' GSuite Daily License Change',
                      y = 0.95, font = list(size = 22))) %>%

  layout(xaxis = list(title = "",
                      tickfont = list(size = 16))) %>%

  layout(yaxis = list(side = 'left',
                      title = 'Net Daily',
                      showgrid = FALSE,
                      zeroline = TRUE,
                      titlefont = list(size = 16),
                      tickfont = list(size = 16))) %>%

  layout(yaxis2 = list(side = 'right',
                       automargin = TRUE,
                       overlaying = "y",
                       showticklabels = TRUE,
                       title = 'Cumulative',
                       showgrid = FALSE,
                       zeroline = TRUE,
                       color = "dodgerblue",
                       titlefont = list(size = 12),
                       tickfont = list(size = 12))) %>%
  layout(hovermode = "x unified") %>%
  plotly::config(displayModeBar = FALSE) %>%
  plotly_build()

# weekly
weekly_fig <- plot_ly(net__gsuite_license_weeks)%>%
  add_trace(x = ~day_date,
            y = ~net_change,
            type = 'bar',
            name = ~ifelse(net_change < 0, "Decrease", "Increase"),
            color = ~net_change < 0,
            colors = c("lawngreen", "red")) %>%
  add_trace(x = ~day_date, y = ~cumulative,
            type = 'scatter',
            mode = 'lines+markers',
            yaxis = 'y2',
            line = list(color = 'dodgerblue',
                        width = 4),
            marker = list(color = 'dodgerblue'),
            name = "Cumulative") %>%
  layout(title = list(text = ' GSuite Weekly License Change',
                      y = 0.95, font = list(size = 22))) %>%

  layout(xaxis = list(title = "",
                      tickfont = list(size = 16))) %>%

  layout(yaxis = list(side = 'left',
                      title = 'Net Weekly',
                      showgrid = FALSE,
                      zeroline = TRUE,
                      color = "black",
                      titlefont = list(size = 16),
                      tickfont = list(size = 16))) %>%

  layout(yaxis2 = list(side = 'right',
                       automargin = TRUE,
                       overlaying = "y",
                       showticklabels = TRUE,
                       title = 'Cumulative',
                       showgrid = FALSE,
                       zeroline = TRUE,
                       color = "dodgerblue",
                       titlefont = list(size = 12),
                       tickfont = list(size = 12))) %>%
  layout(hovermode = "x unified") %>%
  plotly::config(displayModeBar = FALSE) %>%
  plotly_build()

# monthly
monthly_color <- ifelse(net__gsuite_license_months$net_change > 0, "lawngreen", "red")

monthly_fig <- plot_ly(net__gsuite_license_months)%>%
  add_trace(x = ~day_date,
            y = ~net_change,
            type = 'bar',
            name = ~ifelse(net_change < 0, "Decrease", "Increase"),
            marker = list(color = monthly_color)) %>%
  add_trace(x = ~day_date, y = ~cumulative,
            type = 'scatter',
            mode = 'lines+markers',
            yaxis = 'y2',
            line = list(color = 'dodgerblue',
                        width = 4),
            marker = list(color = 'dodgerblue'),
            name = "Cumulative") %>%
  layout(title = list(text = ' GSuite Monthly License Change',
                      y = 0.95, font = list(size = 22))) %>%

  layout(xaxis = list(title = "",
                      tickfont = list(size = 16))) %>%

  layout(yaxis = list(side = 'left',
                      title = 'Net Monthly',
                      showgrid = FALSE,
                      zeroline = TRUE,
                      titlefont = list(size = 16),
                      tickfont = list(size = 16))) %>%

  layout(yaxis2 = list(side = 'right',
                       automargin = TRUE,
                       overlaying = "y",
                       showticklabels = TRUE,
                       title = 'Cumulative',
                       showgrid = FALSE,
                       zeroline = TRUE,
                       color = "dodgerblue",
                       titlefont = list(size = 12),
                       tickfont = list(size = 12))) %>%
  layout(hovermode = "x unified") %>%
  plotly::config(displayModeBar = FALSE) %>%
  plotly_build()

# Save as a list to later read into Shiny app from inputSelect
gsuite_license_plots <- list(daily_fig = (daily_fig), weekly_fig = (weekly_fig), monthly_fig = (monthly_fig))

saveRDS(gsuite_license_plots, "c:/scripts/gsuite_license_plots.rds")


# Make simulations for the null model
# Use data from 3 samples (NEA/Lof 1907-2011-2014)
# best to run on cod node with nohup if many sample sizes to make
# Arguments
#	half: 1, 2, or 3 (which half of loci to run, or 3 for run all)
# 	ncores: number of cores to use
#	trimlowsampsize: 1 to trim loci with less than half of individuals genotypes, 0 to not trim
#	rerunlow: 0 for default, 1 to only run simulations for loci with low p-values in wfs_nullmodel_pos&pvals_07-11-14.rds, 2 to only run even more simulations for loci with low p-values in wfs_nullmodel_outliers_lowp_Lof_07-11-14.tsv.gz

# read arguments
args=(commandArgs(TRUE))
if(length(args)==0){
    print("No arguments supplied.")
	half <- 3 # supply default values
	ncores <- 30
	trimlowsampsize <- 1
	rerunlow <- 0
}else{
	for(i in 1:length(args)){
		eval(parse(text=args[[i]]))
	}
	if(!(half %in% 1:3)) stop('half must be 1, 2, or 3!')
	if(!(ncores > 0)) stop('ncores must be positive')
	if(!(trimlowsampsize %in% 0:1)) stop('trimlowsampsize must be 0 or 1!')
	if(!(rerunlow %in% 0:2)) stop('rerunlow must be 0 or 1 or 2!')
}
print(paste('Arguments: half=', half, ', ncores=', ncores, ', trimlowsampsize=', trimlowsampsize, ', rerunlow=', rerunlow, sep=''))

# set parameters
pop <- 'Lof'; yrs<-'07-11-14'

# load functions
source('scripts/wfs_byf1samp_3samps.r')
if(!grepl('hpc.uio.no', Sys.info()["nodename"])){
	require(parallel)
	require(data.table)
}
if(grepl('hpc.uio.no', Sys.info()["nodename"])){
	require(parallel, lib.loc="/projects/cees/lib/R_packages/")
	require(bit, lib.loc="/projects/cees/lib/R_packages/") # for use with ff
	require(ff, lib.loc="/projects/cees/lib/R_packages/") # for big objects shared across processes
	require(data.table, lib.loc="/projects/cees/lib/R_packages/")
}

# read in Ne and frequency data
if(pop=='Lof'){
	nes <- read.table('analysis/LOF_07_to_LOF_S_11_to_LOF_S_14.w_Ne_bootstrap.txt')[,1] # the values of Ne from wfabc_1
	dat14 <- fread('data_2018.09.05/Frequency_table_Lof07_Lof14.txt', header=TRUE); setnames(dat14, 3:7, c('N_CHR_1', 'Freq_07', 'N_CHR_3', 'Freq_14', 'ABS_DIFF_0714')) # for 1907 vs. 2014
	dat11 <- fread('data_2018.09.05/Frequency_table_Lof07_Lof11.txt', header=TRUE); setnames(dat11, 3:7, c('N_CHR_1', 'Freq_07', 'N_CHR_2', 'Freq_11', 'ABS_DIFF_0711')) # for 1907 vs. 2011
	setkey(dat11, CHROM, POS)
	setkey(dat14, CHROM, POS)

	nchrs <- dat11[dat14, .(CHROM, POS, N_CHR_1, N_CHR_2, N_CHR_3, Freq_07)]
	gen1 <- 11
	gen2 <- 11
} else {
	stop('Pop is not set to Lof!! We do not handle this case yet')
}

# trim out missing loci
	nrow(nchrs)
nchrs <- nchrs[N_CHR_1>0 & N_CHR_2>0 & N_CHR_3>0,]
	print(nrow(nchrs))

# trim to loci with at least half of individuals genotyped?
if(trimlowsampsize==1){
	print('Trimming to loci with at least half of the individuals genotyped')
	nrow(nchrs)
	nchrs <- nchrs[N_CHR_1>=max(N_CHR_1)/2 & N_CHR_2>=max(N_CHR_2)/2 & N_CHR_3>=max(N_CHR_3)/2,]
	print(nrow(nchrs))
}

# trim only to loci with low p-values in wfs_nullmodel_pos&pvals_07-11-14.rds (from a previous run)?
if(rerunlow==1){
	print('Trimming to loci with p<=8e-6 (4 out of 500,000)')
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-11-14.rds'))
	if(pop=='Lof'){
		nchrs <- merge(nchrs, pvals[,.(CHROM, POS, p)]) # merge in p-values for Lof
		print(nrow(nchrs))
		nchrs <- nchrs[p<=8e-6,]
		print(nrow(nchrs))
	} else {
		stop('Pop is not set to Lof!! We do not handle this case yet')
	}
}

# trim only to loci with low p-values in wfs_nullmodel_outliers_lowp_Lof_07-11-14.tsv.gz (from a previous rerunlow=1 run)?
if(rerunlow==2){
	print('Trimming to loci with p<=1e-6 (4 out of 5,000,000)')
	pvals <- fread("gunzip -c analysis/wfs_nullmodel_outliers_lowp_Lof_07-11-14.tsv.gz")

	if(pop=='Lof'){
		nchrs <- merge(nchrs, pvals[,.(CHROM, POS, pLof071114low)], all.x=TRUE) # merge in p-values for Lof
		print(nrow(nchrs))
		nchrs <- nchrs[pLof071114low<=1e-6,]
		print(nrow(nchrs))
	} else {
		stop('Pop is not set to Lof!! We do not handle this case yet')
	}
}

# parameters for the simulation
nsims <- 500000 # number of sims to run for each starting frequency in each sample size (500k)
nreps <- 1 # number of repetitions of the number of simulations
if(rerunlow==1) nreps <- 10 # number of reps to run for loci with low p-values (50M sims total)
if(rerunlow==2) nreps <- 100 # number of reps to run for loci with really low p-values (500M sims total)
print(paste('Running', nreps, 'reps of', nsims, 'simulations for', nreps*nsims, 'total per sample size.'))

c1s <- nchrs[!duplicated(paste(N_CHR_1, N_CHR_2, N_CHR_3)),N_CHR_1] # the sample sizes to simulate (first sample)
c2s <- nchrs[!duplicated(paste(N_CHR_1, N_CHR_2, N_CHR_3)),N_CHR_2]
c3s <- nchrs[!duplicated(paste(N_CHR_1, N_CHR_2, N_CHR_3)),N_CHR_3]
	print(length(c1s))
	print(length(c2s))
	print(length(c3s))

# expand to number of reps (if nreps>1)
print('Expanding sample sizes to number of repetitions')
reps <- rep(1:nreps, times=length(c1s)) # holds repetition counter
c1s <- rep(c1s, each=nreps)
c2s <- rep(c2s, each=nreps)
c3s <- rep(c3s, each=nreps)
	print(length(c1s))
	print(length(c2s))
	print(length(c3s))
	print(length(reps))

# trim to first or second half (or keep all)
if(half==1){
	print('Using first half of sample sizes')
	c1s <- c1s[1:floor(length(c1s)/2)]
	c2s <- c2s[1:floor(length(c2s)/2)]
	c3s <- c3s[1:floor(length(c3s)/2)]
	reps <- reps[1:floor(length(reps)/2)] # also for reps
}
if(half==2){
	print('Using second half of sample sizes')
	c1s <- c1s[(floor(length(c1s)/2)+1):length(c1s)]
	c2s <- c2s[(floor(length(c2s)/2)+1):length(c2s)]
	c3s <- c3s[(floor(length(c3s)/2)+1):length(c3s)]
	reps <- reps[(floor(length(reps)/2)+1):length(reps)]
}
if(half==3){
	print('Using all sample sizes')
}
	print(length(c1s))
	print(length(c2s))
	print(length(c3s))
	print(length(reps))

# check that nes >0
print(summary(nes))
print(paste('Of', length(nes), 'Ne values', sum(nes > 0), 'are >0. Trimming all others out.'))
nes <- nes[nes>0]

# check temp directory for previous simulations (only do this if Ne, gen and other parameters are the same)
if(pop=='Lof' & rerunlow==0){
	torun <- paste(c1s, c2s, c3s, sep=',') # the list of sample sizes we need to run. these have all starting frequencies
	existing <- list.files(path='analysis/temp', pattern='wfs_simsnull_ff.*\\.ffData') # the existing simulations. note that this search string assumes the simulations were made by a previous version of the script that didn't append rep# to the end of the file name (see rerunlow==1 below). Changed in fall 2018.
	existing <- gsub('wfs_simsnull_ff|.ffData', '', existing) # trim file names to just sample sizes

	print('Trimming out files already run for 1 nrep')
	keep <- !(torun %in% existing) # the sample sizes that still need to be run
	c1s <- c1s[keep]
	c2s <- c2s[keep]
	c3s <- c3s[keep]
	reps <- reps[keep]
}
if(pop=='Lof' & rerunlow %in% 1:2){ # if we need more than 1 rep of each sample size. these files only have the starting frequencies we need
	torun <- paste(paste(c1s, c2s, c3s, sep=','), reps, sep='_') # the list of sample sizes we need to run
	existing <- list.files(path='analysis/temp', pattern='wfs_simsnull_ff.+_[[:digit:]]+\\.ffData') # the existing simulations
	existing <- gsub('wfs_simsnull_ff|.ffData', '', existing) # trim file names to just sample sizes and rep#

	print('Trimming out files already run for nrep>1')
	keep <- !(torun %in% existing) # the sample sizes that still need to be run
	c1s <- c1s[keep]
	c2s <- c2s[keep]
	c3s <- c3s[keep]
	reps <- reps[keep]
}

print(length(c1s)) # how many to run?
print(length(c2s))
print(length(c3s))
print(length(reps))

# run simulations for missing sample sizes
if(length(c1s)>0){

	# start cluster
	if(!grepl('hpc.uio.no', Sys.info()["nodename"])){
		cl <- makeCluster(detectCores()-1) # set up cluster on my mac (or another computer), using all but one core
	}
	if(grepl('hpc.uio.no', Sys.info()["nodename"])){
		cl <- makeCluster(ncores) # set up cluster on a cod node
	}
	clusterExport(cl, c('wfs_byf1samp_3samps'))

	# check where this is to monitor temp file creation in the file system /tmp/Rtmpp__
	options('fftempdir')

	# make simulations (parallel way)
	for(i in 1:length(c1s)){ # loop through each set of sample sizes
		print(paste('Sample size rep', i, 'of', length(c1s), 'to do at', Sys.time(), paste(paste(c1s[i], c2s[i], c3s[i], sep=','), '_', reps[i], sep='')))

		# make list of all possible starting sample frequencies and make nsims copies of each
		f1samps=rep((0:c1s[i])/c1s[i], rep(nsims, c1s[i]+1))

		# only run observed starting sample frequencies if just re-running the low p-values
		if(rerunlow %in% 1:2){
			nchr1s <- nchrs[c1s[i]==N_CHR_1 & c2s[i]==N_CHR_2 & c3s[i]==N_CHR_3, round(Freq_07*N_CHR_1)] # number of starting copies of allele for the retained loci
			f1samps=rep((nchr1s)/c1s[i], rep(nsims, length(nchr1s)))
		}

		thisout <- parSapply(cl, f1samps, FUN=wfs_byf1samp_3samps, smin=0, smax=0, c1=c1s[i], c2=c2s[i], c3=c3s[i], gen1=gen1, gen2=gen2, ne=nes, hmin=0.5, hmax=0.5, simplify=TRUE)

		thisout.ff <- ff(thisout, dim=dim(thisout), dimnames=dimnames(thisout)) # create in tempdir

		# save to permanent file (semi-permanent.. but in my temp directory)
		if(pop=='Lof'){
			ffsave(thisout.ff, file=paste('analysis/temp/wfs_simsnull_ff', paste(c1s[i], c2s[i], c3s[i], sep=','), '_', reps[i], sep=''))
		}
		if(pop != 'Lof'){
			stop('pop must be Lof for 3 timepoints!')
		}

		# remove the temp files
		delete(thisout.ff)
		rm(thisout.ff)
	}

	# stop the cluster
	stopCluster(cl)
}


#' \%MinMax of a coding DNA sequence
#'
#' Calculates the \%MinMax (Clarke and Clark, 2008) of a DNA sequence coding a protein of interest.
#'
#' @param x a KZsqns object of the codons for which \%MinMax will be calculated; when a list of such objects are provided, \%MinMax will be calculated for the first object only
#' @param z the width of the sliding window. Default 10
#' @param cut a named numeric array of the codon usage table of the host species. Each entry is the number of codons of genes from the reference species, and the name is the case insensitive three letter base char string of the codon. Optional if \emph{spp} is specified
#' @param y a number denoting the codon table to be used. When \emph{cut} is specified, {y} also needs to be specified. 0 = standard codon table (default), 2 = vertibrate mitchodrial (See dna2aa for additional options). When an option other than those mentioned above is provided, the standard codon table will be used
#' @param spp a character string denoting the host species name on which the codon usage table is based. Sixteen build-in reference tables are available: 'ecoli', E. coli (standard code), default option; 'insect', insect (standard code); 'yeast', yeast (standard code); 'celegans', C. elegans (standard code); 'drosophila', Drosophila melanogaster (standard code); 'human', human (standard code); 'mouse', mouse (standard code); 'rat', rat (standard code); 'pig', pig (standard code); 'pichia', Pichia pastoris (standard code); 'arabidopsis', Arabidopsis thaliana (standard code); 'streptomyces', Streptomyces (standard code); 'zea', Zea mays (standard code); 'nicotiana', Nicotiana tabacum (standard code); 'saccharomyces', Saccharomyces cerevisiae (standard code); 'cricetulus', Cricetulus griseus (standard code). When specified, this option overides {cut}.
#' @return a numerical array of \%MinMax values
#' @details Frequently used codon frequency table in 16 expression host organisms were built-in based on Genscript [1]. In addition, when your host organism is not one of those built-in, you can supply a custom array of codon usage table and the corresponding codon table can be supplied using {cut} and {y} to calculate \%MinMax statistic for additional host organisms.
#' @references [1] https://www.genscript.com/tools/codon-frequency-table [retreaved 2/4/2019]
#' @examples
#'
#' @export

pminmax <- function(x, z=10, cut='n', y=0, spp='ecoli'){
  if(is.list(x)){
    x = x[[1]]
    cat("Expecting a KZsqns object and a list is given\nOnly the first element of the list will be analyzed\n")
  }
  switch(as.character(spp),
         'ecoli' = {
           cft = cft_ecoli[,5]
           names(cft) = cft_ecoli[,1]
           y=0
         },
         'insect' = {
           cft = cft_insect[,5]
           names(cft) = cft_insect[,1]
           y=0
         },
         'yeast' = {
           cft = cft_yeast[,5]
           names(cft) = cft_yeast[,1]
           y=0
         },
         'celegans' = {
           cft = cft_celegans[,5]
           names(cft) = cft_celegans[,1]
           y=0
         },
         'drosophila' = {
           cft = cft_drosophila[,5]
           names(cft) = cft_drosophila[,1]
           y=0
         },
         'human' = {
           cft = cft_human[,5]
           names(cft) = cft_human[,1]
           y=0
         },
         'mouse' = {
           cft = cft_mouse[,5]
           names(cft) = cft_mouse[,1]
           y=0
         },
         'rat' = {
           cft = cft_rat[,5]
           names(cft) = cft_rat[,1]
           y=0
         },
         'pig' = {
           cft = cft_pig[,5]
           names(cft) = cft_pig[,1]
           y=0
         },
         'pichia' = {
           cft = cft_pichia[,5]
           names(cft) = cft_pichia[,1]
           y=0
         },
         'arabidopsis' = {
           cft = cft_arabidopsis[,5]
           names(cft) = cft_arabidopsis[,1]
           y=0
         },
         'streptomyces' = {
           cft = cft_streptomyces[,5]
           names(cft) = cft_streptomyces[,1]
           y=0
         },
         'zea' = {
           cft = cft_zea[,5]
           names(cft) = cft_zea[,1]
           y=0
         },
         'nicotiana' = {
           cft = cft_nicotiana[,5]
           names(cft) = cft_nicotiana[,1]
           y=0
         },
         'saccharomyces' = {
           cft = cft_saccharomyces[,5]
           names(cft) = cft_saccharomyces[,1]
           y=0
         },
         'cricetulus' = {
           cft = cft_cricetulus[,5]
           names(cft) = cft_cricetulus[,1]
           y=0
         },
         {
           cft = cut
         })
  cTable = arg_check(x, 'KZsqns', y)
  temp = table(cTable[,2])[-1]
  xavg = rep(0, 64)
  xmax = rep(0, 64)
  xmin = rep(0, 64)
  aa = names(temp)
  names(xavg) = cTable[,1]
  names(xmax) = cTable[,1]
  names(xmin) = cTable[,1]
  for(i in 1:20){
    codonlist = cft[cTable[cTable[,2]==aa[i],1]]
    xavg[cTable[,2]==aa[i]] = mean(codonlist)
    xmax[cTable[,2]==aa[i]] = max(codonlist)
    xmin[cTable[,2]==aa[i]] = min(codonlist)
  }

  xn = length(x)
  if(xn < z) stop('The width of the sliding window is too large with respect to the DNA sequence provided.')
  ans = rep(0, xn-z+1)
  for(i in 1:(xn-z+1)){
    span = (1:z)+i-1
    num = sum(cft[x[span]]-xavg[x[span]])
    if(num>0){
      den = sum(xmax[x[span]]-xavg[x[span]])
    } else {
      den = sum(xavg[x[span]]-xmin[x[span]])
    }
    ans[i] = num/den
  }
  return(ans)
}


#' Save detection p-value matrix to GDS file
#'
#' @param qc.objects A list of outputs from \code{\link{meffil.create.qc.object}()}.
#' @param gds.filename If not \code{NULL} (default), then saves the output to a GDS (Genomic Data Structure).
#' This is for cases where the output is too large to fit into main memory.
#' @param verbose If \code{TRUE}, then detailed status messages are printed during execution (Default: \code{FALSE}).
#' @param ... Arguments passed to \code{\link[parallel]{mclapply}()}.
#' @return Matrix of probe detection p-values.
#' If \code{gds.filename} is not \code{NULL}, then
#' the output is saved to the GDS file rather than retained
#' in memory and returned.
#' The library 'gdsfmt' must be installed in this case.
#'
#' @export
meffil.save.detection.pvalues <- function(qc.objects,
                                          gds.filename=NULL,
                                          max.bytes=2^30-1,
                                          verbose=F,
                                          ...) {
    stopifnot(all(sapply(qc.objects, is.qc.object)))

    featuresets <- sapply(qc.objects, function(qc.object) qc.object$featureset)
    featureset <- featuresets[1]

    if (is.list(featuresets)) ## backwards compatibility
        featureset <- featuresets <- "450k"

    if (any(featuresets != featureset))
        stop("Multiple feature sets were used to create these QC objects:",
             paste(unique(featuresets), collapse=", "))

    feature.names <- meffil.get.features(featureset)$name

    if (!all(sapply(qc.objects, function(qc.object) exists.rg(qc.object$basename))))
         stop("IDAT files are not accessible for all QC objects")

    require(gdsfmt)
    mcsapply.to.gds(
        qc.objects,
        function(object) {
            if (is.null(object$featureset)) ## backwards compatibility
                object$chip <- "450k"
            rg <- read.rg(object$basename, verbose=verbose)
            probes <- meffil.probe.info(object$chip)
            pvalues <- extract.detection.pvalues(rg, probes, verbose=verbose)
            pvalues[feature.names]
        },
        ...,
        gds.filename=gds.filename,
        storage="float64",
        max.bytes=max.bytes)
    gds.filename
}

#' Retrieve detection p-values from GDS file
#'
#' @param gds.filename Name of GDS file generated by \code{\link{meffil.save.detection.pvalues}()}.
#' @param sites Names of CpG sites to load, if `NULL` then load all (Default: NULL).
#' @param samples Names of samples to load, if `NULL` then load all (Default: NULL).
#' @return Matrix of methylation levels with rows corresponding to CpG sites
#' and columns to samples.  Rows restricted \code{sites} if not \code{NULL},
#' and columns restricted to \code{samples} if not \code{NULL}.
#'
#'
#' @export
meffil.gds.detection.pvalues <- function(gds.filename, sites=NULL, samples=NULL) {
    retrieve.gds.matrix(gds.filename, sites, samples)
}


source("https://gist.githubusercontent.com/mfoll/a4dfbb92068dc559f130/raw/714dc8c2e97987fd4385dcef2722b3ef986d38d6/get_vcf_data.r")

args <- commandArgs(TRUE)
parseArgs <- function(x) {
  res = strsplit(sub("^--", "", x), "=")
  if(length(unlist(res))==1) res[[1]][2]=""
  return(res)
}
argsL <- as.list(as.character(as.data.frame(do.call("rbind", parseArgs(args)))$V2))
names(argsL) <- as.data.frame(do.call("rbind", parseArgs(args)))$V1
args <- argsL;rm(argsL)

if(is.null(args$table) | is.null(args$vcf)) {
  cat("

      Method: add a status to each entry in the --table input: TP if present in the VCF and FP if not. Remove the entry if
              not validate requirements (coverage)

      Mandatory arguments:
      --table=file_name           - annotated table file to add a status
      --vcf=file_name             - VCF file to use for status computations

      Optional argumets:
      --min_qval_vcf=20           - minimum q-value in the VCF to consider a variant
      --min_qval_table=50         - minimum q-value in the table to consider a variant
      --min_ao_q=5                - minimum AO expected in WES to consider a proton FP (if not seen in WES)
      --variable_to_plot          - list of variables in the table to plot, depending on FP/TP status
                                    e.g. --variable_to_plot=RVSB,ERR
      --to_log10                  - list of variables in the table to transform in log10 scale (convenient for plots)
                                    e.g. --to_log10=ERR
      --reformat_indels           - reformat VCF indels: from 'chr1 1 A AT' to 'chr1 1 - T'
      --keep_unrare               - do not remove variant if popfreqmax > 10% or allelic frequency > 10%
      --help                      - print this text

      example: add_positive_status.r --table=test_annotated.txt --vcf=test.vcf \n\n")
  q(save="no")
}

if(is.null(args$min_qval_vcf)) {min_qval_vcf=20} else {min_qval_vcf=as.numeric(args$min_qval_vcf)}
if(is.null(args$min_qval_table)) {min_qval_table=50} else {min_qval_table=as.numeric(args$min_qval_table)}
if(is.null(args$min_ao_q)) {min_ao_q=5} else {min_ao_q=as.numeric(args$min_ao_q)}
if(is.null(args$variable_to_plot)) {variable_to_plot=NULL} else {variable_to_plot=unlist(strsplit(args$variable_to_plot,","))}
if(is.null(args$to_log10)) {to_log10=NULL} else {to_log10=unlist(strsplit(args$to_log10,","))}
if(is.null(args$reformat_indels)) {reformat_indels=FALSE} else {reformat_indels=TRUE}
if(is.null(args$keep_unrare)) {keep_unrare=FALSE} else {keep_unrare=TRUE}

table = read.table(args$table, quote="\"", stringsAsFactors=F, sep="\t", header=T)

# remove entry with QVAL_INV>50 in the table

table = table[which(table$QVAL_INV<50 | is.na(table$QVAL_INV)),]

for(v in to_log10) table[,v] = log10(table[,v])

vcf = read.table(args$vcf,stringsAsFactors=F,header=F,sep="\t")

# get VCF column names
con = file(args$vcf) ; open(con) ; h=""
while ( ! grepl("#CHROM", h)) {
  h = readLines(con, n = 1, warn = FALSE)
} ; close(con)
colnames(vcf) = unlist(strsplit(h, "\t"))

# reformat indels
if(reformat_indels){
  dels = which(nchar(vcf$REF)>1)
  vcf[dels,"ALT"] = "-"
  vcf[dels,"REF"] = substr(vcf[dels,"REF"], 2, nchar(vcf[dels,"REF"]))
  vcf[dels,"POS"] = vcf[dels,"POS"] + 1
  ins = which(nchar(vcf$ALT)>1)
  vcf[ins,"REF"] = "-"
  vcf[ins,"ALT"] = substr(vcf[ins,"ALT"], 2, nchar(vcf[ins,"ALT"]))
}

# remove unrare variants
table$ExAC_nontcga_Max = as.numeric(apply(table[,which(grepl("ExAC_nontcga", colnames(table)) & !grepl("_ALL",colnames(table)))],
                               1, max))
if(!keep_unrare) table = table[which( (is.na(table$ExAC_nontcga_Max) | table$ExAC_nontcga_Max<0.1 ) & table$VF<0.1),]

# correct table indel notation
table[which(table$Ref == 0), "Ref"] = "-"
table[which(table$Alt == 0), "Alt"] = "-"

##### add the postive status ####

table$status = unlist(lapply(1:nrow(table), function(i) {
  dat_table = table[i,]
  min_ao_est_q = qnbinom(0.01, size = 1/0.1, mu = 0.5*dat_table$coverage) #quantile at 1% with a negative binomial
  dat = vcf[which(vcf$`#CHROM`== dat_table$Chr & vcf$POS == dat_table$Start & vcf$REF == dat_table$Ref & vcf$ALT == dat_table$Alt ), c("FORMAT",dat_table$SM)]
  if(dim(dat)[1]!=0){
    qval = get_genotype(as.character(dat[2]), as.character(dat[1]),"QVAL")
    qval_inv = get_genotype(as.character(dat[2]), as.character(dat[1]),"QVAL_INV")
    if( (!is.na(qval) & qval >= min_qval_vcf) | (!is.na(qval_inv) & qval_inv <= min_qval_vcf) ) { return("TP") } else {
      if(is.na(dat_table$coverage) | (min_ao_est_q<min_ao_q)) { return(NA) } else {
        return("FP")
      }
    }
  } else { if(is.na(dat_table$coverage) | (min_ao_est_q<min_ao_q)) { return(NA) } else { return("FP") } }
}))

table = table[which(!is.na(table$status)),]

if(!is.null(variable_to_plot)){
  pdf("TP_FP_variables.pdf", 12.5, 5)
  par(mfrow=c(1,3))
  for(v in variable_to_plot){
    hist(as.numeric(table[,v]), br=20, main=v, ylab="counts", xlab=v, col=adjustcolor("darkblue",0.75), border="darkblue")
    hist(as.numeric(table[which(table$status=="TP"),v]), br=20, main=v, ylab="counts", xlab=v, col=adjustcolor("darkgreen",0.75), border="darkgreen")
    hist(as.numeric(table[which(table$status=="FP"),v]), br=20, main=v, ylab="counts", xlab=v, col=adjustcolor("darkred",0.75), border="darkred")
  }
  dev.off()
}

write.table(table, file=paste(paste(gsub(".txt","",args$table),"status",sep="_"),
                              ".txt",sep=""), quote=F, sep="\t", row.names = F)


REBOL [
    Title: "Hardball test server"
]

rsa-key: load %hardball-test-server-key.r
client-public-key: get in load %hardball-test-client-key.r 'n
change-dir %../../
do %mezz/module.r
load-module/from what-dir

module [
    Imports: [%schemes/hardball.r]
] [
    serve-modules [
        modules: [%mezz/text-encoding.r %mezz/imap.r]
        public-key: rsa-key/n
        private-key: rsa-key
        allowed-peers: reduce [client-public-key]
        logging: [all to %tests/data/test.log]
    ]
]

quit


# Compute region-to-region connectivity using pre-computed list of body_ids
# Turner, Mann, Clandinin.
# https://github.com/mhturner/SC-FC
# mhturner@stanford.edu

# For each body/neuron:
#   1) Find input/output synapse locations
#   2) convert locations from hemibrain raw space to desired comparison space (JRC2018 or JFRC2)
#   3) Find atlas regions of each synapse (for Ito atlas or Branson atlas), and compute connectivity stats
#
# Saves:
#   Connectivity matrices (region x region) for: each atlas; each connectivity metric
#   Synapse mask: T-Bar density image in comparison space
#
# # References:
#   http://natverse.org/neuprintr/
#   https://groups.google.com/forum/embed/?place=forum%2Fnat-user&pli=1#!topic/nat-user/zNaCyQnZeVg
#   http://natverse.org/nat.templatebrains/reference/xform_brain.html
# # NOTE: something is off about the Hemibrain -> JFRC2 conversion. Seems to be restricted to JRC2018<->JFRC2
# #       Do comparison in JRC2018 space

library(nat.flybrains)
library(nat.jrcbrains)
library(nat.h5reg)
library(neuprintr)
library(dplyr)
library(bioimagetools)

options(warn=1)

# Input arg Brain template comparison space: JFRC2, JRC2018
comparison_space <- commandArgs(trailingOnly = TRUE)

data_dir = '/oak/stanford/groups/trc/data/Max/flynet/data'

t0 = Sys.time()

# Load atlases
if (comparison_space == 'JFRC2'){
  res = 0.68 # um/voxel of atlas
  ito_atlas <- bioimagetools::readTIF(file.path(data_dir, 'template_brains', 'JFRCtempate2010.mask130819_Original.tif'), as.is=TRUE)
  branson_atlas <- bioimagetools::readTIF(file.path(data_dir, 'template_brains', 'AnatomySubCompartments20150108_ms999centers.tif'), as.is=TRUE)

} else if (comparison_space == 'JRC2018'){
  res = 0.38 # um/voxel of atlas
  ito_atlas <- bioimagetools::readTIF(file.path(data_dir, 'template_brains', 'ito_2018.tif'), as.is=TRUE)
  branson_atlas <- bioimagetools::readTIF(file.path(data_dir, 'template_brains', '2018_999_atlas.tif'), as.is=TRUE)

} else {
  print('Unrecognized comparison space argument')
}

# Init results matrices
branson_count_matrix <- matrix(0, max(branson_atlas), max(branson_atlas))
branson_tbar_matrix <- matrix(0, max(branson_atlas), max(branson_atlas))
branson_weighted_tbar_matrix <- matrix(0, max(branson_atlas), max(branson_atlas))

ito_count_matrix <- matrix(0, max(ito_atlas), max(ito_atlas))
ito_tbar_matrix <- matrix(0, max(ito_atlas), max(ito_atlas))
ito_weighted_tbar_matrix <- matrix(0, max(ito_atlas), max(ito_atlas))

syn_mask <- array(0, dim=dim(ito_atlas))

# Load neuron / body IDs
all_body_ids =  read.csv(file.path(data_dir, 'body_ids.csv'), header = FALSE)
# all_body_ids = sample_n(all_body_ids, 350) # testing

# split into chunks for less gigantic neuprint calls
# chunks = split(all_body_ids[,1], ceiling(seq_along(all_body_ids[,1])/100)) # testing
chunks = split(all_body_ids[,1], ceiling(seq_along(all_body_ids[,1])/1000))

for (c_ind in 1:length(chunks)){
  body_ids = neuprint_ids(chunks[[c_ind]])

  # get synapses associated with bodies
  syn_data = neuprint_get_synapses(body_ids)
  syn_data = syn_data[!duplicated(syn_data[2:5]),] # remove duplicate T-bar locations (single t-bar -> multiple postsynapses)

  print(sprintf('Loaded chunk %s: syn_data size = %s x %s', c_ind, dim(syn_data)[1],  dim(syn_data)[2]))

  # convert hemibrain raw locations to microns
  syn_data[,c("x", "y", "z")] = syn_data[,c("x", "y", "z")] * 8/1000 # vox -> um

  # Go from hemibrain space to comparison space
  if (comparison_space == 'JFRC2'){
    syn_data[,c("x", "y", "z")] = xform_brain(syn_data[,c("x", "y", "z")], sample = JRCFIB2018F, reference = JFRC2) / res # x,y,z um -> atlas voxels
  } else if (comparison_space == 'JRC2018') {
    syn_data[,c("x", "y", "z")] = xform_brain(syn_data[,c("x", "y", "z")], sample = JRCFIB2018F, reference = JRC2018F) / res # x,y,z um -> atlas voxels
  }

  # split into input / output
  input_synapses = as.data.frame(syn_data[syn_data$prepost==1, c("x", "y", "z", "bodyid")])
  output_synapses = as.data.frame(syn_data[syn_data$prepost==0, c("x", "y", "z", "bodyid")])

  # For each cell in synapse list
  ct = 0
  for (body_id in body_ids){
    # Swap x and y for indexing
    input_yxz = data.matrix(input_synapses[input_synapses$bodyid==body_id, c("y", "x", "z")])
    output_yxz = data.matrix(output_synapses[output_synapses$bodyid==body_id, c("y", "x", "z")])

    mode(input_yxz) = 'integer' # floor to int to index
    mode(output_yxz) = 'integer' # floor to int to index

    # # # # # # BRANSON ATLAS # # # # # # # # # # # #
    # Get regions + counts for cell inputs
    input_regions = branson_atlas[input_yxz] # index atlas matrix with integer array
    input_regions = input_regions[input_regions!=0] # remove 0 regions (non-brain)
    input_tab = table(input_regions) # https://www.rdocumentation.org/packages/base/versions/3.6.2/topics/table
    input_regions = as.numeric(names(input_tab)) # now unique regions
    input_counts = as.vector(input_tab)
    # Same for cell outputs
    output_regions = branson_atlas[output_yxz]
    output_regions = output_regions[output_regions!=0]
    output_tab = table(output_regions)
    output_regions = as.numeric(names(output_tab))
    output_counts = as.vector(output_tab)

    if (length(input_regions) > 0 && length(output_regions) > 0){
      # Cell count
      branson_count_matrix[input_regions, output_regions] =
        branson_count_matrix[input_regions, output_regions] + 1

      # Total T-bar count
      branson_tbar_matrix[input_regions, output_regions] =
        branson_tbar_matrix[input_regions, output_regions] +
        t(replicate(length(input_regions), output_counts))

      # Weighted T-bar count: output tbars mult. by fraction of total input synapses in source region
      branson_weighted_tbar_matrix[input_regions, output_regions] =
        branson_weighted_tbar_matrix[input_regions, output_regions] +
        as.matrix(input_counts / sum(input_counts)) %*% t(as.matrix(output_counts))
    }

    # # # # # # ITO ATLAS # # # # # # # # # # # #
    # Get regions + counts for cell inputs
    input_regions = ito_atlas[input_yxz] # index atlas matrix with integer array
    input_regions = input_regions[input_regions!=0] # remove 0 regions (non-brain)
    input_tab = table(input_regions) # https://www.rdocumentation.org/packages/base/versions/3.6.2/topics/table
    input_regions = as.numeric(names(input_tab)) # now unique regions
    input_counts = as.vector(input_tab)
    # Same for cell outputs
    output_regions = ito_atlas[output_yxz]
    output_regions = output_regions[output_regions!=0]
    output_tab = table(output_regions)
    output_regions = as.numeric(names(output_tab))  # now unique regions
    output_counts = as.vector(output_tab)

    if (length(input_regions) > 0 && length(output_regions) > 0){
      # Cell count
      ito_count_matrix[input_regions, output_regions] =
        ito_count_matrix[input_regions, output_regions] + 1

      # Total T-bar count
      ito_tbar_matrix[input_regions, output_regions] =
        ito_tbar_matrix[input_regions, output_regions] +
        t(replicate(length(input_regions), output_counts))

      # Weighted T-bar count: output tbars mult. by fraction of total input synapses in source region
      ito_weighted_tbar_matrix[input_regions, output_regions] =
        ito_weighted_tbar_matrix[input_regions, output_regions] +
        as.matrix(input_counts / sum(input_counts)) %*% t(as.matrix(output_counts))
    }

    if (length(output_yxz) > 0){
      # Append output synapse counts to synapse mask
      ct_by_vox = aggregate(data.frame(output_yxz)$x, by=data.frame(output_yxz), length)
      syn_mask[data.matrix(ct_by_vox)[,1:3]] = syn_mask[data.matrix(ct_by_vox)[,1:3]] + data.matrix(ct_by_vox)[,4]
    }
    ct = ct + 1
  } # end body_ids

  print(sprintf('Completed chunk %s: total cells = %s', c_ind, ct))

} # end chunks

# Save conn matrices and syn mask
write.csv(branson_count_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'branson_cellcount_matrix.csv', sep='_')))
write.csv(branson_tbar_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'branson_tbar_matrix.csv', sep='_')))
write.csv(branson_weighted_tbar_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'branson_weighted_tbar_matrix.csv', sep='_')))

write.csv(ito_count_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'ito_cellcount_matrix.csv', sep='_')))
write.csv(ito_tbar_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'ito_tbar_matrix.csv', sep='_')))
write.csv(ito_weighted_tbar_matrix, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'ito_weighted_tbar_matrix.csv', sep='_')))

print(sprintf('Syn_mask max. = %s', max(syn_mask))) # Print max Tbar count in synmask. writeTIF auto scales it to 16bit range. Annoying.
writeTIF(syn_mask, file.path(data_dir, 'hemi_2_atlas', paste(comparison_space, 'synmask.tif', sep='_')))

Sys.time() - t0


DataDir <- "/gpfs/data/stranger-lab/askol/TCGA2/Data/Expression/"
ResultDir <- "/gpfs/data/stranger-lab/askol/TCGA2/DiffExpression/Results/"

library(limma)
library(edgeR)

run_limma <- function(project){

    data <- get.data(project, DataDir)

    count <- data[[3]]
    logCPM <- data[[2]]
    design <- data[[1]]
    design.nosvs <- data[[4]]

    ## LIMMA WITHOUT VOOM (INCLUDE SVS AND BIRTHYEAR) ##
    fit <- lmFit(logCPM, design)
    fit <- eBayes(fit, trend=TRUE)
    limma.rslt <- topTable(fit,coef=2, n=Inf, sort.by="none")

    limma.rslt <- data.frame(gene = count$genes[,1], count$genes[,-1], limma.rslt)
    coef <- as.data.frame(fit$coefficient)
    names(coef) <- paste("coef", gsub("\\(|\\)", "", names(coef)), sep=".")
    se <- as.data.frame(fit$s2.post*fit$stdev.unscaled)
    names(se) <- paste("se", gsub("\\(|\\)", "", names(se)), sep=".")
    df.resid <- as.data.frame(fit$df.resid)
    limma.rslt <- data.frame(limma.rslt, coef, se, df.resid)

    out.file <- paste0(ResultDir, project,"_DE_limma.rslts")
    write.table(file = out.file, limma.rslt[order(limma.rslt$P.Value),], quote=F,
                row.names=F, col.names=T, sep="\t")
    print(paste0("Wrote ", out.file))

    ## LIMMA WITH VOOM (INCLUDES SVS AND BIRTHYEAR)
    v <- voom(count, design, plot=F)
    vfit <- lmFit(v, design)
    efit <- eBayes(vfit)
    voom.rslt <- topTable(efit, coef=2, n=Inf, sort.by="none")

    voom.rslt <- data.frame(gene = count$genes[,1], voom.rslt)
    coef <- as.data.frame(efit$coefficient)
    names(coef) <- paste("coef", gsub("\\(|\\)", "", names(coef)), sep=".")
    se <- as.data.frame(efit$s2.post * efit$stdev.unscaled)
    names(se) <- paste("se", gsub("\\(|\\)", "", names(se)), sep=".")
    df.resid <- as.data.frame(efit$df.resid)
    voom.rslt <- data.frame(voom.rslt, coef, se, df.resid)

    out.file <- paste0(ResultDir, project,"_DE_voom.rslts")
    write.table(file = out.file, voom.rslt[order(voom.rslt$P.Value),], quote=F,
                row.names=F, col.names=T, sep="\t")
    print(paste0("Wrote ", out.file))

    ## LIMMA WITH VOOM (INCLUDES BIRTHYEAR ONLY)
    v <- voom(count, design.nosvs, plot=F)
    vfit <- lmFit(v, design.nosvs)
    efit <- eBayes(vfit)
    voom.rslt <- topTable(efit, coef=2, n=Inf, sort.by="none")

    voom.rslt <- data.frame(gene = count$genes[,1], voom.rslt)
    coef <- as.data.frame(efit$coefficient)
    names(coef) <- paste("coef", gsub("\\(|\\)", "", names(coef)), sep=".")
    se <- as.data.frame(efit$s2.post * efit$stdev.unscaled)
    names(se) <- paste("se", gsub("\\(|\\)", "", names(se)), sep=".")
    df.resid <- as.data.frame(efit$df.resid)
    voom.rslt <- data.frame(voom.rslt, coef, se, df.resid)

    out.file <- paste0(ResultDir, project,"_DE_voom_nosvs.rslts")
    write.table(file = out.file, voom.rslt[order(voom.rslt$P.Value),], quote=F,
                row.names=F, col.names=T, sep="\t")
    print(paste0("Wrote ", out.file))

    ## ANALYSIZE AFTER INVERSE NORMALIZATION ##
    cpm.invnorm <- inverse_quantile_normalization(v$E)
    txt <-  paste0("summary(lm(t(cpm.invnorm) ~ group + ", paste(
        names(count$sample)[grep("SV", names(count$sample))], collapse="+"),
        " ,data=count$samples))")
    out <- eval(parse(text = txt))
    out2 <- lapply(out, function(x) coefficients(x)[2,])
    lm.rslt <- as.data.frame(do.call(rbind, out2))
    names(lm.rslt) <- c("Est", "SE", "t.val","P.Value")
    lm.rslt <- data.frame(v$genes, lm.rslt)
    names(lm.rslt)[1] <- "ENSMBL"

    out.file <- paste0(ResultDir, project,"_LM_invnorm.rslts")
    write.table(file = out.file, lm.rslt[order(lm.rslt$P.Value),], quote=F,
                row.names=F, col.names=T, sep="\t")

    print(paste0("Wrote ", out.file))

}

get.data <- function(project, DataDir){

    file <- paste0(DataDir, project, ".RDS")
    data <- readRDS(file)

    ## ADD BIRTHYEAR IF LESS THAN 10% IS MISSING VALUES ##
    add.cov = ""
    if (grep("BirthYear", names(data$samples))){

        if (mean(is.na(data$samples$BirthYear)) < 0.10){
            add.cov <- " BirthYear + "
        }
    }
    txt <- paste0("model.matrix(~group + ",add.cov,
                  paste(names(data$samples)[grep("SV", names(data$samples))], collapse="+"),
                  ", data$samples)")
    design <- eval(parse(text = txt))
    design.nosvs <- model.matrix(~group + BirthYear, data$samples)

    logCPM <- cpm(data, log=TRUE, prior.count=3)

    return(list(design = design, logCPM = logCPM, count = data, design.nosvs = design.nosvs))
}

inverse_quantile_normalization <- function(gct) {
        gct = t(apply(gct, 1, rank, ties.method = "average"));
        gct = qnorm(gct / (ncol(gct)+1));
        return(gct)
}

args <- commandArgs(TRUE)
project = args[1]
run_limma(project)
print(date())

finish.file = paste0(project,".finished")
system(paste0("touch ",finish.file))


# Code for tracking hummingbird migration
# Modified from code for La Sorte et al. 2013. (Population-level scaling of
# avian migration speed with body size and migration distance for powered fliers, Ecology)
# Sarah R. Supp (c) 2014

library(spaa)
library(fields)
library(colorRamps)
library(maptools)
library(fossil)
library(PBSmodelling)
library(aspace)
library(pastecs)
library(raster)
library(mgcv)
library(adehabitat)
library(SDMTools)
library(xlsx)
library(gamm4)
library(insol)

# TODO: Code for migration
#   1. place all daily sightings into hexes
#   2. count which hex has the most
#   3. record central lon-lat for that hex - or record a weighted mean based on the centroid centers
#   4. Calculate great-circle distance between centroids for daily distance
#   5. Calculate 95% confidence bands (longitude) for occurence centroids
#   6. Define beginning of spring migration and end of fall migration
#   7. Link occurrence centroids with environmental data (NDVI, temp, precip, daylength)

## import global equal area hex grid (shared by FAL)
setwd("/Volumes/Elements/eBird/")

# read in the north ameica equal area hex grid map (F.A.L.)
#hexgrid = readShapePoly("/Volumes/Elements/eBird/terr_4h6/nw_vector_grid.shp") #quad map
hexgrid = readShapePoly("/Volumes/Elements/eBird/terr_4h6/terr_4h6.shp") #hex map
# crop to just North America, where the migratory species occur
hexgrid = hexgrid[which(hexgrid$LATITUDE > 10 & hexgrid$LATITUDE <80 &
                          hexgrid$LONGITUDE > -178 & hexgrid$LONGITUDE < -50),]

#hex grid map
plot(hexgrid, xlim=c(-170,-50), ylim=c(10,80), col="lightblue", lwd=0.25, border="gray10")
axis(side=1)
axis(side=2, las=1)
box()
mtext("Longitude", side=1, cex=1.4, line=2.5)
mtext("Latitude", side=2, cex=1.4, line=2.5)

#To find the POLYFID for the hexes for each observation
coords = yrdat[,c(10,9)]

# Matches observations with the polygon hexes in the map
ID <- over(SpatialPoints(coords), hexgrid)

#paste original lat-long with the cell info after matching
coords <- cbind(coords, ID)

#find the number of obs in each cell, doesn't fill with zeroes
t= table(as.factor(coords$POLYFID))

#Merge the count data for the hexes with all the hexes in the map
df = data.frame(POLYFID = names(t), count=as.numeric(t))
df2 = data.frame(POLYFID = unique(hexgrid$POLYFID))
df3 = merge(df2, df, all.x=TRUE)

cols = data.frame(id=c(NA,sort(unique(df3$count))), cols=tim.colors(length(unique(df3$count))), stringsAsFactors=FALSE)
df4 = merge(df3, cols, by.x="count", by.y="id")
df5 = merge(hexgrid, df4, by.x="POLYFID", by.y="POLYFID", all.x=TRUE)

#hexes with no counts are white
df5$cols <- ifelse(is.na(df5$count), "white", df5$cols)
df5 <- df5[order(df5$POLYFID),]

#make a map with hexes colored by the number of times the species was observed in a given hex
jpeg('ChecklistMap.jpg')
plot(hexgrid, col=df5$cols, border="gray10", lwd=0.25, xlim=c(-170,-50), ylim=c(10,80), las=1)
axis(side=1)
axis(side=2, las=1)
box()
mtext("Longitude", side=1, cex=1.4, line=2.5)
mtext("Latitude", side=2, cex=1.4, line=2.5)

## legend
vls = sort(unique(round(cols$id/100)*100))
vls[1] = 1
cols2 = tim.colors(length(vls))
legend("bottomleft", legend=vls, pch=22, pt.bg=cols2, pt.cex=1, cex=0.75, bty="n",
       col="black", title="Number of checklists", x.intersp=1, y.intersp=0.5, hjust=-1)

dev.off()

#Use this info to calculate a weighted mean for daily location?
#POLYFID is the ID for each polygon, or hex cell.

#-------------------------- NOTES below, non-functional so far

#Here are the dates for the weeks - the temporal design for SRD predictions.
# -----------------------
n.intervals.per.year = 365
# ------------
begin.jdate = 1
end.jdate = 365
year.list = c(2009)

n.intervals = n.intervals.per.year  + 1
jdate.ttt.seq = seq(from = begin.jdate, to = end.jdate, length = (n.intervals))

if (n.intervals > 1) {
  jdate.ttt.seq = round((jdate.ttt.seq[2:n.intervals] +
                            jdate.ttt.seq[1:(n.intervals-1)]) / 2)
}

year.seq = NULL
jdate.seq = NULL
for (iii.year in year.list){
  year.seq = c(year.seq,rep(iii.year, length(jdate.ttt.seq)))
  jdate.seq = c(jdate.seq, jdate.ttt.seq)
}

#change julian date into "YYYY-MM-DD" and "Mon-dd" strings
posix.dates = strptime( x=paste(2009,"-",jdate.ttt.seq, sep=""),"%Y-%j")
date.string = paste(months(posix.dates, abbreviate=T), posix.dates$mday,sep="_")

## Nature Serve centroids - a datafile with centroids already calculated? Is it just mean Lat and Long?
setwd("pathname/analysis")
ns.cntr = read.table("NatureServe_centroids2.txt", sep="\t", header=TRUE, as.is=TRUE)

## migration distance
sp2 = sort(unique(ns.cntr$scientific2))
dst = NULL

#use geodist to calculate Great Circle distance between points
for(i in 1:length(sp2)){
  ns.cntr2 <- ns.cntr[ns.cntr$scientific2 %in% sp2[i],]
  dst = c(dst, geodist(ns.cntr2[1,"lon"], ns.cntr2[1,"lat"], ns.cntr2[2,"lon"], ns.cntr2[2,"lat"]))
}

#TODO: should we include all jdates, e.g., jdate with no obs are simply NA?
mig.dst.all = data.frame(scientific2 = sp2, distance = dst, stringsAsFactors = FALSE)
mig.dst.all = na.omit(mig.dst.all)
mig.dst.all = mig.dst.all[mig.dst.all$distance > 0, ]    ## migration distance >0
sp = sort(unique(mig.dst.all$scientific2))

#

png(paste(dirpath, "analysis_pca_plots9", species, ".png", sep=""))
par(mai=c(1.02,1,0.82,0.22), xpd=FALSE)
# Plot the relationship between julian date and the number of hex cells containing observations
occ = ggplot(altmeandat, aes(jday, numcells)) + geom_point() + xlab("julian day") + ylab("number of cells") +
  geom_smooth(se=T, method='gam', formula=y~s(x, k=40), gamma=1.5, col='indianred', fill='orange') + theme_bw()
plot(altmeandat$jday, altmeandat$numcells, pch=19, type="p", cex=0.5, xlab="Day", cex.axis=1.2, cex.lab=1.4, las=1, xaxt="n",
     ylab="Cell count")

#GAM model on number of cells with observations by julian date
gam1 = gam(numcells ~ s(jday, k = 40), data = altmeandat, gamma = 1.5)
xpred = data.frame(jday = c(1:max(altmeandat$jday)))
dpred = predict(gam1, newdata=xpred, type="response", se.fit=T)

#Add the gam fit lines + se to the plot
lines(xpred$jday, dpred$fit, col="red", lwd=2)
lines(xpred$jday, dpred$fit + (2.56 * dpred$se.fit), lty=2, col="red", lwd=0.5) #99%
lines(xpred$jday, dpred$fit - (2.56 * dpred$se.fit), lty=2, col="red", lwd=0.5) #99%

## cutoff based on 2 SE for spring and fall combined, following La Sorte et al. 2013 methods
# Spring migration should be between 11 Jan and 9 July
# Fall migration should be between 8 August and 21 Dec
spring_threshold = min(dpred$se.fit[c(1:120)]*2.56 + dpred$fit[c(1:120)])
fall_threshold = min(dpred$se.fit[c(280:365)]*2.56 + dpred$fit[c(280:365)])
spring_index = 11:190
fall_index = 220:355
spring_max = spring_index[which.max(dpred$fit[spring_index])]
fall_max = fall_index[which.max(dpred$fit[fall_index])]

#identify beginning of spring migration
tst = 1000
spring_index2 = spring_max
while(tst > spring_threshold){
  tst = dpred$fit[spring_index2]
  if(spring_index2 == 1) break
  spring_index2 = spring_index2 - 1
}
spring = spring_index2+1

#identify end of fall migration
tst <- 1000
fall_index2 = fall_max
while(tst > fall_threshold){
  tst = dpred$fit[fall_index2]
  if(fall_index2==365) break
  fall_index2 <- fall_index2 + 1
}
fall <- fall_index2-1

#add vertical lines to plot to show when main migratory period is (i.e., NOT at winter grounds)
lines( rep(spring,2),c(0, 100000),col="blue")
lines( rep(fall,2),c(0, 100000),col="blue")

occ + geom_vline(xintercept = c(spring, fall), col = "indianred")

#----- trying out code for long and lat gams - can I do this within year?
# also check specifications for k and gamma

# plot the lat and long data with gam smoothing line
long = ggplot(altmeandat, aes(jday, centerlon)) + geom_point() + xlab("julian day") + ylab("longitude") +
  geom_smooth(se=T, method='gam', formula=y~s(x,k=10), gamma=1.5, col="mediumpurple") + theme_bw() +
  geom_vline(xintercept = c(spring, fall), col = "cadetblue", type = "dashed", size = 1)

lati = ggplot(altmeandat, aes(jday, centerlat)) + geom_point() + xlab("julian day") + ylab("latitude") +
  geom_smooth(se=T, method='gam', formula=y~s(x,k=10), gamma=1.5, col="mediumpurple") + theme_bw() +
  geom_vline(xintercept = c(spring, fall), col = "cadetblue", type = "dashed", size = 1)

#find the best fit line for the data
lon_gam <- gam(centerlon ~ s(jday, k=10), data = altmeandat, gamma = 1.5)
lat_gam <- gam(centerlat ~ s(jday, k=10), data = altmeandat, gamma = 1.5)

xpred <- data.frame(jday=sort(unique(altmeandat$jday)))
lonpred <- predict(lon_gam, newdata = xpred, type="response", se.fit=T)
latpred <- predict(lat_gam, newdata = xpred, type="response", se.fit=T)

preds =  data.frame(common = species, jday = xpred$jday, month = altmeandat$month, lon= lonpred$fit,
                    lat=latpred$fit, lon_se = lonpred$se.fit, lat_se = latpred$se.fit)


# A test of the zbuffer

Display "Z buffer test" "Screen" "rgbsingle"

Format 500 500

CameraFOV 40.0

CameraEye 0 0 -20
CameraAt 0 0 0
CameraUp 0 1 0

Clipping 1 100

ObjectBegin "Blade"
XformPush
Translate 0 3 0
Rotate "Y" 60
Scale 0.02  1  5

Cube
XformPop
ObjectEnd # Blade

WorldBegin

Color 1.0 0.0 0.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.0 0.5 1.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 1.0 1.0 0.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.5 0.0 1.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.0 1.0 0.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 1.0 0.0 0.5
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.0 1.0 1.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 1.0 0.5 0.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.0 0.0 1.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.5 1.0 0.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 1.0 0.0 1.0
ObjectInstance "Blade"

Rotate "Z" 30
Color 0.0 1.0 0.5
ObjectInstance "Blade"

WorldEnd