#!/usr/bin/env Rscript
# Tune, evaluate, and train one or more machine learning models
# to predict carbon emissions (kg) per nautical mile. Output
# includes performance metrics and the final predictive model(s).
#
# Only implemented for EU-based training data with specific expected column names
# (see help printout).
#
# usage:
#
# Default is to tune, evaluate, and train random forests, extreme gradient boosting,
# groupwise linear model by ship type, and ridge regression,
# using 10-fold cross-validation (or out-of-bag prediction for random forests)
# to estimate generalization error.
# Default uses 10 repeats of the entire training process.
#
# Rscript train_and_evaluate_models.r -i training_data.csv -m ship_metadata.csv -o output_directory
#
# Other examples:
#
# Tune, eval, and train only RF and linear using 3 repeats
# Rscript train_and_evaluate_models.r -i training_data.csv -m ship_metadata.csv -o output_directory --models "rf,linear" --repeats 3
#
# No evaluation/tuning, just train a final model on whole data set
# using default params
# Rscript train_and_evaluate_models.r -i training_data.csv -m ship_metadata.csv -o output_directory --models rf --skip-tuning
library('optparse', warn.conflicts = F, quietly = T)

if(Sys.getenv('R_CLIMATE_TRACE_SHIPPING_HOME') == ''){
  stop('R_CLIMATE_TRACE_SHIPPING_HOME not in environment variables. Please add "R_CLIMATE_TRACE_SHIPPING_HOME=/path/to/r/climate/trace/shipping/repo" to the file .Renviron in your home directory. Read more about the .Renviron file here: https://support.rstudio.com/hc/en-us/articles/360047157094-Managing-R-with-Rprofile-Renviron-Rprofile-site-Renviron-site-rsession-conf-and-repos-conf')
}
CTHOME=Sys.getenv('R_CLIMATE_TRACE_SHIPPING_HOME')

set.seed(123456)

# Define and get commandline options
option_list <- list(
  make_option(c("-i", "--input"),
              help="Input training data CSV. Must have a column containing IMO Numbers. Currently assumes this is EU reporting data with additional columns Ship.type, distance.traveled.nm, average.speed.nm.hr, Annual.Total.time.spent.at.sea.hours, and Annual.average.CO.emissions.per.distance.kg.CO.n.mile [required]"),
  make_option(c("-I", "--IMO_columm"), default='IMO.Number',
              help="Name of column containing IMO Numbers [default \"%default\"]"),
  make_option(c("-m", "--metadata"),
              help = "Ship metadata file, e.g. \"IHS complete Ship Data.csv,\" with columns IMO Numbers in column 1. [required]"),
  make_option(c("-R", "--raw_metadata"), action="store_true", default=FALSE,
              help = "Ship metadata file is raw, meaning requires imputing missing data, binning flagnames, etc. [default %default]"),
  make_option(c("-o", "--outdir"),
              help = "Output directory [required]"),
  make_option(c("-M", "--models"), default='rf',
              help="Comma-separated list of models. Options are rf, ridge, linear, xgb. [default %default]"),
  make_option(c("r", "--repeats"), default=1,
              help="Number of repeats of evaluation procedure [default %default]"),
  make_option(c("--skip_tuning"), action="store_true", default=FALSE,
              help="Skip model tuning and use hard-coded params, only estimate error (and optionally train final model) [default %default]"),
  make_option(c("--skip_eval"), action="store_true", default=FALSE,
              help="Use hard-coded hyperparams and skip model tuning and eval entirely, only train final model. Implies skip_tuning. [default %default]"),
  make_option(c("--skip_final_model"), action="store_true", default=FALSE,
              help="Skip training final model. Otherwise, final model will be saved to <outdir>/final_model.rdata. Required when evaluating multiple models. [default %default]"),
  make_option(c("--imputation_method"), default='rf',
              help="Imputation method: quick (median/mode) or rf (much more accurate but very slow) [default \"%default\"]"),
  make_option(c("-v", "--verbose"), action="store_true", default=FALSE,
              help="Verbose output [default %default]")
)
opt <- parse_args(OptionParser(option_list=option_list))

# check that all required options are provided
required.opts <- c('input','metadata','outdir')
if(any(!(required.opts %in% names(opt)))){
  stop(sprintf('One or more of these required parameters is missing: %s.\n\n', paste(required.opts,collapse=', ')))
}

# check models list for validity
models <- strsplit(opt$models,',')[[1]]
for(model in models){
  valid.models <- c('rf','ridge','linear','xgb')
  valid.model.string <- paste(valid.models,collapse=',')
  if(!(model %in% valid.models)){
    stop(sprintf('Error: requested model \"%s\" not found in valid models: %s \n', valid.model.string))
  }
}

# check for conflict between --models and --skip_eval
if(opt$skip_eval && length(models) > 1){
  stop('\nCannot skip eval when evaluating multiple models.\n')
}

# check for conflict between --models and --skip_eval
if(opt$skip_eval && opt$skip_final_model){
  stop('\nCannot skip eval and skip final model.\n')
}

# check for conflict between --models and --skip_final_model
if(!opt$skip_final_model && length(models) > 1){
  cat('\nWarning: Cannot produce final model when evaluating multiple models. Setting "skip_final_model" to TRUE.\n')
  opt$skip_final_model <- TRUE
}

# for convenience, store final_model as opposite of skip_final_model
opt$final_model <- !opt$skip_final_model

# ensure that only one model is requested
# if final model also requested
if(opt$final_model && length(models) > 1){
  stop('Error: final model can only be output for one model at a time ')
}

# Now load other code; waited till here to perform
# input validations first
source(paste(CTHOME,'/lib/training-general.r',sep=''))
source(paste(CTHOME,'/lib/load.r',sep=''))

# Create output directory
dir.create(opt$outdir,showWarnings = FALSE)

# load data (can comment this out if loaded to save time)
if(opt$verbose) cat('Loading ship data and metadata...\n')
x <- load.EU.MRV.ship.data.and.metadata(ship.filepath=opt$input,
                                        metadata.filepath=opt$metadata,
                                        raw.metadata=opt$raw_metadata,
                                        outdir=opt$outdir,
                                        verbose=opt$verbose)

predictor.names <- c('Deadweight','FlagNameBin','FlagNameContinent','GrossTonnage','Length','Breadth','Draught','ShiptypeEU','ShiptypeLevel2','Powerkwmax','Powerkwaux','Speed','YearOfBuild')

if(opt$skip_tuning || opt$skip_eval){
  params <- list(rf=list(mtry=15, nodesize=8,ntree=2000),
                 xgb=list(nrounds=2000, eta=.01, subsample=0.75, max_depth=5))
} else {
  params <- NULL
}

if(opt$verbose) cat('Running tuning and evaluation...\n')
res <- tune.and.evaluate.models(x[,predictor.names],
                                x$kg.CO2.per.nm,
                                nreps=opt$repeats,
                                outdir=opt$outdir,
                                models=models,
                                params=params,
                                individual.ids=x$IMO.Number,
                                linear.predictor="Powerkwmax",
                                linear.categories="ShiptypeEU",
                                verbose=c(0,1)[as.numeric(opt$verbose) + 1],
                                skip.eval = opt$skip_eval,
                                get.final.model = opt$final_model
)

# save eval results
if(!opt$skip_eval){
  if(opt$verbose) cat('Saving eval results...\n')
  # create outdir in case does not exist
  dir.create(opt$outdir,showWarnings = FALSE)
  # write results to .csv file
  write.csv(res$rmses, paste(opt$outdir,'/rmse.csv',sep=''), row.names = TRUE, quote=F)
  write.csv(res$maes, paste(opt$outdir,'/mae.csv',sep=''), row.names = TRUE, quote=F)

  pdf(paste(opt$outdir,'/boxplot-model-comparison-NRMSE.pdf',sep=''),width=5,height=5)
  boxplot(t(res$rmses),main='Normalized RMSE',cex.main=1,las=2)
  dev.off()

  pdf(paste(opt$outdir,'/boxplot-model-comparison-MAE.pdf',sep=''),width=5,height=5)
  boxplot(t(res$maes),main='Mean absolute percent error',cex.main=1,las=2)
  dev.off()

  # write summary of execution parameters and performance
  sink(paste(opt$outdir,'/summary.txt',sep=''))
  cat('Overall performance\n')
  cat('Model     MAE (mean +/- sd)   NRMSE (mean +/- sd)\n')
  for(i in 1:nrow(res$mae)){
    cat(sprintf('%-10s',rownames(res$mae)[i]))
    cat(sprintf('%0.4f +/- %0.4f  ',mean(res$mae[i,]), sd(res$mae[i,])))
    cat(sprintf('%0.4f +/- %0.4f',mean(res$rmse[i,]), sd(res$rmse[i,])))
    cat('\n')
  }
  cat('\n')
  cat('Best model hyperparameters\n')
  # print hyperparams in a table for each model
  for(model.name in names(res$best.params)){
    if(length(res$best.params[[model.name]]) > 0){
      cat(model.name,'\n',sep='')
      param.mat <- sapply(res$best.params[[model.name]], function(xx) unlist(xx))
      colnames(param.mat) <- sprintf('rep%03d',1:ncol(param.mat))
      print(param.mat)
      cat('\n')
    }
  }
  cat('\n')
  cat('Command parameters\n')
  print(opt)
  sink(NULL)
}

# save final model
if(opt$final_model){
  if(opt$verbose > 0) cat('Saving final model...\n')
  final.model.filepath <- paste(opt$outdir,'/final_model.rdata',sep='')
  final.model.container <- list(model.type=models[1],
                                train.x=x[,predictor.names],
                                final.model=res$final.model)
  save(final.model.container, file=final.model.filepath)
}


# Run from the R console using:
# source( paste( Sys.getenv("INDUS_IX_PATH"), 'basin_msggdx.r', sep = '/' ) )

##### INITIALIZE #####

options( java.parameters = "-Xmx16g" )

print( 'Initializing functions and data' )

#rm( list = ls( ) )
graphics.off( )
require( raster )
require( dplyr )
require( tidyr )
require( rgdal )
require( tictoc )
require( maptools )
require( rgeos )
require( gdxrrw )

#### Initialization / Model setup #####

tic()

# Use ixmp? Takes time to upload - can choose option to debug w/o ixmp
use_ixmp = FALSE

# Location of GAMS - need to add to system environemtn variables but can't change from remote desktop :(
gams_path = 'C:/GAMS/win64/24.9'

# Basin analyzed
basin = 'Indus'
#
# # SSP being analyzed
# SSP = 'SSP2'
#
# # Climate model analyzed
# climate_model = 'ensemble'
# climate_scenario = 'rcp60'

# Time steps
year = c( seq( 1990, 2010, by = 10  ), 2015, seq( 2020, 2060, by = 10 ) )
time =  as.character( ( seq(1, 12, by = 1 ) ) ) # monthly time steps
year_all = year
baseyear = 2015 # last historical year
lastyear = last(year_all)

# load data inputs
if( default_data )
{ load(paste0(indus_ix_path,"/NEST_Indus_SSP2_RPC6.RData") )
} else {
  # Location of input data
  setwd( 'P:/is-wel/indus/message_indus' )
  source( paste( indus_ix_path, 'basin_msggdx_load_inputs.r', sep = '/' ), verbose = FALSE )
}

# load technology parameters using 'basin_msggdx_technologies.r' and add to formatted list
source( paste( indus_ix_path, 'basin_msggdx_technologies.r', sep = '/' ) )

# Set the technologies to add to the GDX - ! needs to match what's defined in 'basin_msggdx_technologies.r' !
technology.set = c( 'gas_cc_ot',
					'gas_cc_cl',
					'gas_cc_ac',
					'gas_cc_sw',
					'gas_st_ot',
					'gas_st_cl',
					'gas_st_ac',
					'gas_st_sw',
					'gas_gt',
					'oil_cc_ot',
					'oil_cc_cl',
					'oil_cc_ac',
					'oil_cc_sw',
					'oil_st_ot',
					'oil_st_cl',
					'oil_st_ac',
					'oil_st_sw',
					'oil_gt',
					'coal_st_ot',
					'coal_st_cl',
					'coal_st_ac',
					'coal_st_sw',
					'igcc_ot',
					'igcc_cl',
					'igcc_ac',
					'igcc_sw',
					'nuclear_sw',
					'nuclear_ot',
					'nuclear_cl',
					'geothermal_sw',
					'geothermal_ot',
					'geothermal_cl',
					#'biomass_st_ot',
					#'biomass_st_ac',
					#'biomass_st_cl',
					#'biomass_st_sw',
					'solar_pv_1',
					'solar_pv_2',
					'solar_pv_3',
					'wind_1',
					'wind_2',
					'wind_3',
					'hydro_old',
					'hydro_river',
					'hydro_canal',
					'electricity_distribution_urban',
					'electricity_distribution_rural',
					'electricity_distribution_industry',
					'electricity_distribution_irrigation',
					'electricity_short_strg',
					routes_names,
					exp_routes_names,
					'sw_extract',
					'gw_extract',
					'renew_gw_extract',
					'urban_sw_diversion',
					'urban_gw_diversion',
					'urban_piped_distribution',
					'urban_unimproved_distribution',
					'urban_wastewater_collection',
					'urban_wastewater_release',
					'urban_wastewater_treatment',
					'urban_wastewater_recycling',
					'urban_wastewater_irrigation',
					'urban_desal_seawater',
					'industry_sw_diversion',
					'industry_gw_diversion',
					'industry_distribution',
					'industry_wastewater_collection',
					'industry_wastewater_release',
					'industry_wastewater_treatment',
					'industry_wastewater_recycling',
					'industry_desal_seawater',
					'rural_sw_diversion',
					'rural_gw_diversion',
					'rural_piped_distribution',
					'rural_unimproved_distribution',
					'rural_wastewater_release',
					'rural_wastewater_treatment',
					'rural_wastewater_recycling',
					'rural_wastewater_collection',
					'irrigation_sw_diversion',
					'irrigation_gw_diversion',
					'smart_irrigation_sw_diversion',
					# 'smart_irrigation_gw_diversion',
					'irrigation_desal_seawater',
					'energy_sw_diversion',
					'energy_gw_diversion',
					'environmental_flow',
					'internal_runoff',
					# 'surface2ground',
					# 'ground2surface',
					'interbasin_canal',
					river_names,
					canal_names,
					crop_tech_names,
					rainfed_crop_names,
					irr_tech_names[!grepl('flood_fruit',irr_tech_names)],
					'fallow_crop',
					'solid_biom',
					'ethanol_prod',
					'ethanol_genset',
					'ethanol_agri_genset',
					'irri_diesel_genset',
					'agri_diesel_genset',
					'agri_pv'
					)

# Generate data frames for the parameters and sets to pass to ixmp
source( paste( indus_ix_path, 'basin_msggdx_setpardef.r', sep = '/' ) )

# Additional policies
source( paste( indus_ix_path, 'basin_msggdx_policies.r', sep = '/' ) )

toc() # finished loading data

#### SOLVE  ######

# name of scenario
#scname = 'test'

# if using ixmp, upload data and solve
if( use_ixmp )
	{

	print( 'Uploading to DB using ixmp' )

	tic()
	source( paste( indus_ix_path, 'basin_msggdx_ixmp.r', sep = '/' ) )
	toc()

	tic()
	source( paste( indus_ix_path, 'basin_msggdx_solve.r', sep = '/' ) )
	toc()

	}

	# Solve locally

	print( 'Output to GDX with gdxrrw' )

tic()
source( paste( indus_ix_path, 'basin_msggdx_gdxrrw.r', sep = '/' ) )
toc()

tic()
source( paste( indus_ix_path, 'basin_msggdx_solve.r', sep = '/' ) )
toc()

	print( paste0( sc, ' ---> scenario finished' ) )
#### RUN DIAGNOSTICS
tic()
print( 'Running diagnostics' )
source( paste( indus_ix_path, 'basin_msggdx_diagnostics.r', sep = '/' ) )
toc()
#### FIN #####

print( 'Scenario finished' )


setwd(data.path)
last.y<-2012        # last year in simulation
years.in.assess<-20

# please note: you should allready have made a SMS run to produce input for forcast!

#read options from SMS.dat file
SMS.dat<-read.FLSMS.control(file='SMS.dat')
first.y.assess<-SMS.dat@first.year
first.y<-SMS.dat@last.year.model+1  #First year of prediction
recq<-SMS.dat@rec.season            # recruitment season
years.in.assess<-min(years.in.assess,first.y-first.y.assess)

all.TACs<-NULL
all.SMS.yields<-NULL

# read output from SMS (parameter estimation mode) into a FLStocks object
SMS.stocks<-SMS2FLStocks(sumfile='summary.out',bio.interact=TRUE,
                         read.input=TRUE, read.output=TRUE,control=SMS.dat)
SMS.nsp<-length(SMS.stocks)

#assessAllStocks(SMS.stocks)

# read prediction options
HCR<-read.FLSMS.predict.control(control=SMS.dat,file='HCR_options_source.dat')

for (y in (first.y:last.y)) {

    # use the stock object for assessment to estimate TACs
    assess.stocks<-SMS.stocks
    first.y.assess<-y-years.in.assess
    for (i in (1:SMS.nsp)) {
       assess.stocks[[i]]<-window(SMS.stocks[[i]],first.y.assess,y-1)
       assess.stocks[[i]]@m<- assess.stocks[[i]]@m1+ assess.stocks[[i]]@m2
    }

    # make an assessment using SMS.stocks as input
    TACs<- assessAllStocks(assess.stocks)  # from Bruce

    #Prepare for one year step of operating model=SMS
    in.TACs<-TACs
    all.TACs<-rbind(all.TACs,TACs)
    in.TACs[is.na(TACs)]<--1
    HCR@constant.TAC<-in.TACs     # constant.TAC (really not used)

    HCR@TAC.first<-in.TACs      # TAC in the (first) prediction year
    #if (y>first.y) HCR@TAC.first<-c(1,-1,-1)   #TEST

    in.TACs[is.na(TACs)]<-1
    in.TACs[!is.na(TACs)]<--1
    HCR@F.first<-in.TACs      # F in the (first) prediction year
    HCR@constant.F<--in.TACs  # F in the next years

    in.HCRs<-in.TACs
    in.HCRs[in.TACs==0]<-1       # Use fixed F HCR for species without TAC
    in.HCRs[in.HCRs!=1]<-2       #   and used fixed TAC for the rest

    HCR@last.prediction.year<-y

    if (y==first.y) {
      HCR@read.F.first.y<-0
      HCR@read.F.last.y<-0
      HCR@read.stock.N.first.y<-0
      HCR@read.stock.N.last.y<-0
    } else {
      HCR@read.F.first.y<-first.y
      HCR@read.F.last.y<-y-1
      HCR@read.stock.N.first.y<-first.y
      HCR@read.stock.N.last.y<-y-1
    }

    write.FLSMS.control(HCR,file='HCR_options.dat')

    # execute sms.exe
    command<-'"..\\program\\sms" -mceval'
    system(command, show.output.on.console =TRUE)

    #read results of prediction into FLStocks object
    SMS.stocks<-SMS2FLStocks(sumfile="FLR_CNF.out",control=SMS.dat)

    # just for checking, extract yields
    SMS.yield<-rep(NA,SMS.nsp)
    for (s in (1:SMS.nsp)) {
      SMS.yield[s]<-sum(SMS.stocks[[s]]@catch[,as.character(y),,,])
    }
    all.SMS.yields<-rbind(all.SMS.yields,SMS.yield)

print(round(all.TACs))
print(round(all.SMS.yields))

 # write sms input files for recruitment and F
 if (y<last.y) {
    # write predict_stock_N.in
    n.file<-"predict_stock_N.in"
    cat(paste("# Stock number 1. Jan (or at recruitment time for recruits) at age",
            "\n# Negative value are not used",sep=""),file=n.file)

    #write exploitation_pattern.in
    f.file<-"exploitation_pattern.in"
    cat(paste("# Exploitation pattern or F at age\n",sep=""),file=f.file)

    for (s in SMS.stocks) {
        N<-aperm(s@stock.n[,as.character(first.y:y),,,],c(2,1,4,5,3))
        FF<-aperm(s@harvest[,as.character(first.y:y),,,],c(2,4,1,5,3))
        for (yy in (first.y:y)) {
            # stock numbers
            cat(paste("\n# ",s@name,yy,"\n"),file=n.file,append=TRUE)
            cy<-as.character(yy)
            N[cy,1,1,1,1]<-N[cy,1,recq,1,1] # copy recruit from recruitment season to first quarter
            N[cy,-1,1,1,1]<--9  # set all age (except the recruits) N to -9
            cat(file=n.file,N[cy,,1,1,1],append=TRUE)
            # Fishing mortalities
            cat(paste("\n# ",s@name,yy,"\n"),file=f.file,append=TRUE)
            write.table(FF[cy,,,1,1],quote=FALSE,row.names=FALSE,col.names=FALSE, file=f.file,append=TRUE)
        }
    }
   }

   #print(SMS.stocks[[1]]@stock.n[,as.character(y),1,3,])
}

check<-matrix(NA,ncol=SMS.nsp,nrow=last.y-first.y+1)
for (s in (1:SMS.nsp)) {
   for (y in (first.y:last.y)) {
      check[y-first.y+1,s]<-sum(SMS.stocks[[s]]@catch[,as.character(y),,,])
    }
}
cat("\nCheck: output from last SMS run\n")
print(round(check))
source(file.path(prog.path,"HCR_output_multi.R"))


p_file <- function(filename, hours, w, pings) {
library("ggplot2")
 p<-qplot(Timestamp,sent/sent*100,data=pings) + xlab("") + ylab("Pings Returned %") +
   geom_line(aes(Timestamp,received/sent*100), color="blue") +
   geom_line(aes(Timestamp,(sent-received)/sent*100), color="red") +
   scale_y_continuous(limits = c(0, 100)) +
   scale_x_datetime(limits =  c(Sys.time()-3600*hours,Sys.time()))
 png(filename, height = 900, width = w)
 print(p)
 dev.off()
}
pingdata <- read.csv(file=paste(Sys.getenv("DATADIR"),"pingdata.csv",sep=""),head=TRUE,sep=",")
pingdata$Timestamp <- as.POSIXct(pingdata$Timestamp,format="%Y-%m-%dT%H:%M")

p_file(paste(Sys.getenv("WEBDIR"),"archive/plot",as.Date(Sys.time(),tz="America/New_York")-1,".png", sep=""),24,1600,pingdata)


REBOL [
	title: "REBOL 3 TLS protocol scheme"
	name: 'tls
	type: 'module
	author: rights: "Richard 'Cyphre' Smolak"
	version: 0.1.0
	todo: {
		-cached sessions
		-automagic cert data lookup
		-add more cipher suites
		-server role support
		-SSL3.0, TLS1.1 compatibility
		-cert validation
	}
]

;support functions

debug:
;:print
none

emit: func [
	ctx [object!]
	code [block! binary!]
][
	repend ctx/msg code
]

to-bin: func [
	val [integer!]
	width [integer!]
][
	skip tail to-binary val negate width
]

make-tls-error: func [
	"Make an error for the TLS protocol"
	message [string! block!]
] [
	if block? message [message: ajoin message]
	make error! [
		type: 'Access
		id: 'Protocol
		arg1: message
	]
]

tls-error: func [
	"Throw an error for the TLS protocol"
	message [string! block!]
] [
	do make-tls-error message
]

;ASN.1 format parser code

universal-tags: [
	eoc
	boolean
	integer
	bit-string
	octet-string
	null
	object-identifier
	object-descriptor
	external
	real
	enumerated
	embedded-pdv
	utf8string
	relative-oid
	undefined
	undefined
	sequence
	set
	numeric-string
	printable-string
	t61-string
	videotex-string
	ia5-string
	utc-time
	generalized-time
	graphic-string
	visible-string
	general-string
	universal-string
	character-string
	bmp-string
]

class-types: [universal application context-specific private]

parse-asn: func [
	data [binary!]
	/local
		mode d constructed? class tag ln length result val
][
	result: copy []
	mode: 'type

	while [d: data/1][
		switch mode [
			type [
				constructed?: to logic! (d and 32)
				class: pick class-types 1 + shift d -6

				switch class [
					universal [
						tag: pick universal-tags 1 + (d and 31)
					]
					context-specific [
						tag: class
						val: d and 31
					]
				]
				mode: 'length
			]

			length [
				length: d and 127
				unless zero? (d and 128) [
					;long form
					ln: length
					length: to integer! copy/part next data length
					data: skip data ln
				]
				either zero? length [
					append/only result compose/deep [(tag) [(either constructed? ["constructed"]["primitive"]) (index? data) (length) #[none]]]
					mode: 'type
				][
					mode: 'value
				]
			]

			value [
				switch class [
					universal [
						val: copy/part data length
						append/only result compose/deep [(tag) [(either constructed? ["constructed"]["primitive"]) (index? data) (length) (either constructed? [none][val])]]
						if constructed? [
							poke second last result 4	parse-asn val
						]
					]

					context-specific [
						append/only result compose/deep [(tag) [(val) (length)]]
						parse-asn copy/part data length
					]
				]

				data: skip data length - 1
				mode: 'type
			]
		]

		data: next data
	]
	result
]

;protocol state handling

read-proto-states: [
	client-hello [server-hello]
	server-hello [certificate]
	certificate [server-hello-done]
	server-hello-done []
	finished [change-cipher-spec alert]
	change-cipher-spec [encrypted-handshake]
	application [application alert]
	alert []
]

write-proto-states: [
	server-hello-done [client-key-exchange]
	client-key-exchange [change-cipher-spec]
	change-cipher-spec [finished]
	encrypted-handshake [application]
]

get-next-proto-state: func [
	ctx [object!]
	/write-state "default is read state"
	/local
		next-state
][
	all [
		next-state: select/only/skip either write-state [write-proto-states][read-proto-states] ctx/protocol-state 2
		not empty? next-state
		next-state
	]
]

update-proto-state: func [
	ctx [object!]
	new-state [word!]
	/write-state
	/local
		next-state
][
	debug [ctx/protocol-state "->" new-state write-state]
	either any [
		none? ctx/protocol-state
		all [
			next-state: apply :get-next-proto-state [ctx write-state]
			find next-state new-state
		]
	][
		debug ["new-state ->" new-state]
		ctx/protocol-state: new-state
	][
		do make error! "invalid protocol state"
	]
]

;TLS protocol code

client-hello: func [
	ctx [object!]
	/local
		beg len
][
	;generate client random struct
	ctx/client-random: to-bin to-integer difference now/precise 1-Jan-1970 4
	random/seed now/time/precise
	loop 28 [append ctx/client-random (random/secure 256) - 1]

	beg: length? ctx/msg
	emit ctx [
		#{16}			; protocol type (22=Handshake)
		ctx/version			; protocol version (3|1 = TLS1.0)
		#{00 00}		; length of SSL record data
		#{01}			; protocol message type	(1=ClientHello)
		#{00 00 00} 	; protocol message length
		ctx/version			; max supported version by client (TLS1.0)
		ctx/client-random	; random struct (4 bytes gmt unix time + 28 random bytes)
		#{00}			; session ID length
		#{00 02}		; cipher suites length (only one suit for testing at the moment)
		ctx/cipher-suite	; cipher suites list (0005 = TLS_RSA_WITH_RC4_128_SHA) (0004 = TLS_RSA_WITH_RC4_128_MD5) etc.
		#{01}			; compression method length
		#{00}			; no compression
	]

	; set the correct msg lengths
	change at ctx/msg beg + 7 to-bin len: length? at ctx/msg beg + 10 3
	change at ctx/msg beg + 4 to-bin len + 4 2

	append clear ctx/handshake-messages copy at ctx/msg beg + 6

	return ctx/msg
]

client-key-exchange: func [
	ctx [object!]
	/local
	rsa-key pms-enc beg len
][
	;generate pre-master-secret
	ctx/pre-master-secret: copy ctx/version
	random/seed now/time/precise
	loop 46 [append ctx/pre-master-secret (random/secure 256) - 1]

	;encrypt pre-master-secret
	rsa-key: rsa-make-key
	rsa-key/e: ctx/pub-exp
	rsa-key/n: ctx/pub-key

	pms-enc: rsa ctx/pre-master-secret rsa-key

	beg: length? ctx/msg
	emit ctx [
		#{16}			; protocol type (22=Handshake)
		ctx/version			; protocol version (3|1 = TLS1.0)
		#{00 00}		; length of SSL record data
		#{10}			; protocol message type	(16=ClientKeyExchange)
		#{00 00 00} 	; protocol message length
		to-bin length? pms-enc 2	;length of the key (2 bytes)
		pms-enc
	]

	; set the correct msg lengths
	change at ctx/msg beg + 7 to-bin len: length? at ctx/msg beg + 10 3
	change at ctx/msg beg + 4 to-bin len + 4 2

	append ctx/handshake-messages copy at ctx/msg beg + 6

	;make all secrue data
	make-master-secret ctx ctx/pre-master-secret
	make-key-block ctx

	;update keys
	ctx/client-mac-key: copy/part ctx/key-block ctx/hash-size
	ctx/server-mac-key: copy/part skip ctx/key-block ctx/hash-size ctx/hash-size
	ctx/client-crypt-key: copy/part skip ctx/key-block 2 * ctx/hash-size ctx/crypt-size
	ctx/server-crypt-key: copy/part skip ctx/key-block 2 * ctx/hash-size + ctx/crypt-size ctx/crypt-size

	return ctx/msg
]

change-cipher-spec: func [
	ctx [object!]
][
	emit ctx [
		#{14} ; protocol type (20=ChangeCipherSpec)
		ctx/version			; protocol version (3|1 = TLS1.0)
		#{00 01}		; length of SSL record data
		#{01}			; CCS protocol type
	]
	return ctx/msg
]

encrypted-handshake-msg: func [
	ctx [object!]
	message [binary!]
	/local
		plain-msg
][
	plain-msg: message
	message: encrypt-data/type ctx message #{16}
	emit ctx [
		#{16}			; protocol type (22=Handshake)
		ctx/version			; protocol version (3|1 = TLS1.0)
		to-bin length? message 2	; length of SSL record data
		message
	]
	append ctx/handshake-messages plain-msg
	return ctx/msg
]

application-data: func [
	ctx [object!]
	message [binary! string!]
][
	message: encrypt-data ctx to-binary message
	emit ctx [
		#{17}			; protocol type (23=Application)
		ctx/version			; protocol version (3|1 = TLS1.0)
		to-bin length? message 2	; length of SSL record data
		message
	]
	return ctx/msg
]

finished: func [
	ctx [object!]
][
	ctx/seq-num: 0
	return rejoin [
		#{14}		; protocol message type	(20=Finished)
		#{00 00 0c} ; protocol message length (12 bytes)
		prf ctx/master-secret either ctx/server? ["server finished"]["client finished"] rejoin [
			checksum/method ctx/handshake-messages 'md5 checksum/method ctx/handshake-messages 'sha1
		] 12
	]
]

encrypt-data: func [
	ctx [object!]
	data [binary!]
	/type
		msg-type [binary!] "application data is default"
	/local
		crypt-data
][
	data: rejoin [
		data
		;MAC code
		checksum/method/key rejoin [
			#{00000000} to-bin ctx/seq-num 4		;sequence number (limited to 32-bits here)
			any [msg-type #{17}]				;msg type
			ctx/version								;version
			to-bin length? data 2				;msg content length
			data								;msg content
		] ctx/hash-method decode 'text ctx/client-mac-key
	]

	switch ctx/crypt-method [
		rc4 [
			either ctx/encrypt-stream [
				rc4/stream data ctx/encrypt-stream
			][
				ctx/encrypt-stream: rc4/key data ctx/client-crypt-key
			]
		]
	]

	return data
]

decrypt-data: func [
	ctx [object!]
	data [binary!]
	/local
		crypt-data
][
	switch ctx/crypt-method [
		rc4 [
			either ctx/decrypt-stream [
				rc4/stream data ctx/decrypt-stream
			][
				ctx/decrypt-stream: rc4/key data ctx/server-crypt-key
			]
		]
	]

	return data
]

protocol-types: [
	20 change-cipher-spec
	21 alert
	22 handshake
	23 application
]

message-types: [
	0 hello-request
	1 client-hello
	2 server-hello
	11 certificate
	12 server-key-exchange
	13 certificate-request
	14 server-hello-done
	15 certificate-verify
	16 client-key-exchange
	20 finished
]

alert-descriptions: [
	0 "Close notify"
	10 "Unexpected message"
	20 "Bad record MAC"
	21 "Decryption failed"
	22 "Record overflow"
	30 "Decompression failure"
	40 "Handshake failure"
	41 "No certificate"
	42 "Bad certificate"
	43 "Unsupported certificate"
	44 "Certificate revoked"
	45 "Certificate expired"
	46 "Certificate unknown"
	47 "Illegal parameter"
	48 "Unknown CA"
	49 "Access denied"
	50 "Decode error"
	51 "Decrypt error"
	60 "Export restriction"
	70 "Protocol version"
	71 "Insufficient security"
	80 "Internal error"
	90 "User cancelled"
   100 "No renegotiation"
   110 "Unsupported extension"
]

parse-protocol: func [
	data [binary!]
	/local proto
][
	unless proto: select protocol-types data/1 [
		do make error! "unknown/invalid protocol type"
	]
	return context [
		type: proto
		version: pick [ssl-v3 tls-v1.0 tls-v1.1] data/3 + 1
		length: to-integer copy/part at data 4 2
		messages: copy/part at data 6 length
	]
]

parse-messages: func [
	ctx [object!]
	proto [object!]
	/local
		result data msg-type len clen msg-content mac msg-obj
][
	result: copy []
	data: proto/messages

	if ctx/encrypted? [
		change data decrypt-data ctx data
		debug ["decrypted:" data]
	]
	debug [ctx/seq-num "-->" proto/type]
	switch proto/type [
		alert [
			append result reduce [
				context [
					level: any [pick [warning fatal] data/1 'unknown]
					description: any [select alert-descriptions data/2 "unknown"]
				]
			]
		]
		handshake [
			while [data/1][
				len: to-integer copy/part at data 2 3
				append result switch msg-type: select message-types data/1 [
					server-hello [
						msg-content: copy/part at data 7 len

						msg-obj: context [
							type: msg-type
							version: pick [ssl-v3 tls-v1.0 tls-v1.1] data/6 + 1
							length: len
							server-random: copy/part msg-content 32
							session-id: copy/part at msg-content 34 msg-content/33
							cipher-suite: copy/part at msg-content 34 + msg-content/33 2
							compression-method-length: first at msg-content 36 + msg-content/33
							compression-method: either compression-method-length = 0 [none][copy/part at msg-content 37 + msg-content/33 compression-method-length]
						]
						ctx/server-random: msg-obj/server-random
						msg-obj
					]
					certificate [
						msg-content: copy/part at data 5 len
						msg-obj: context [
							type: msg-type
							length: len
							certificates-length: to-integer copy/part msg-content 3
							certificate-list: copy []
							while [msg-content/1][
								if 0 < clen: to-integer copy/part skip msg-content 3 3 [
									append certificate-list copy/part at msg-content 7 clen
								]
								msg-content: skip msg-content 3 + clen
							]
						]
						;no cert validation - just set it to be used
						ctx/certificate: parse-asn msg-obj/certificate-list/1

						;get the public key and exponent (hardcoded for now)
						ctx/pub-key: parse-asn next
;									ctx/certificate/1/sequence/4/1/sequence/4/6/sequence/4/2/bit-string/4
								ctx/certificate/1/sequence/4/1/sequence/4/7/sequence/4/2/bit-string/4
						ctx/pub-exp: ctx/pub-key/1/sequence/4/2/integer/4
						ctx/pub-key: next ctx/pub-key/1/sequence/4/1/integer/4

						msg-obj
					]
					server-hello-done [
						context [
							type: msg-type
							length: len
						]
					]
					client-hello [
						msg-content: copy/part at data 7 len
						context [
							type: msg-type
							version: pick [ssl-v3 tls-v1.0 tls-v1.1] data/6 + 1
							length: len
							content: msg-content
						]
					]
					finished [
						msg-content: copy/part at data 5 len
						either msg-content <> prf ctx/master-secret either ctx/server? ["client finished"]["server finished"] rejoin [checksum/method ctx/handshake-messages 'md5 checksum/method ctx/handshake-messages 'sha1] 12 [
							do make error! "Bad 'finished' MAC"
						][
							debug "FINISHED MAC verify: OK"
						]
						context [
							type: msg-type
							length: len
							content: msg-content
						]
					]
				]

				append ctx/handshake-messages copy/part data len + 4

				data: skip data len + either ctx/encrypted? [
					;check the MAC
					mac: copy/part skip data len + 4 ctx/hash-size
					if mac <> checksum/method/key rejoin [
							#{00000000} to-bin ctx/seq-num 4			;sequence number (limited to 32-bits here)
							#{16}										;msg type
							ctx/version										;version
							to-bin len + 4 2							;msg content length
							copy/part data len + 4
						] ctx/hash-method decode 'text ctx/server-mac-key
					[
						do make error! "Bad record MAC"
					]
					4 + ctx/hash-size
				][
					4
				]
			]
		]
		change-cipher-spec [
			ctx/seq-num: -1
			ctx/encrypted?: true
			append result context [
				type: 'ccs-message-type
			]
		]
		application [
			append result context [
				type: 'app-data
				content: copy/part data (length? data) - ctx/hash-size
			]
		]
	]
	ctx/seq-num: ctx/seq-num + 1
	return result
]

parse-response: func [
	ctx [object!]
	msg [binary!]
	/local
		result proto messages len
][
	result: copy []
	len: 0
	until [
		append result proto: parse-protocol msg
		either empty? messages: parse-messages ctx proto [
			do make error! "unknown/invalid protocol message"
		][
			proto/messages: messages
		]
		tail? msg: skip msg proto/length + 5
	]
	return result
]

prf: func [
	secret [binary!]
	label [string! binary!]
	seed [binary!]
	output-length [integer!]
	/local
		len mid s-1 s-2 a p-sha1 p-md5
][
	len: length? secret
	mid: to-integer .5 * (len + either odd? len [1][0])

	s-1: copy/part secret mid
	s-2: copy at secret mid + either odd? len [0][1]

	seed: rejoin [#{} label seed]

	p-md5: copy #{}
	a: seed ;A(0)
	while [output-length > length? p-md5][
		a: checksum/method/key a 'md5 decode 'text s-1 ;A(n)
		append p-md5 checksum/method/key rejoin [a seed] 'md5 decode 'text s-1

	]

	p-sha1: copy #{}
	a: seed ;A(0)
	while [output-length > length? p-sha1][
		a: checksum/method/key a 'sha1 decode 'text s-2 ;A(n)
		append p-sha1 checksum/method/key rejoin [a seed] 'sha1 decode 'text s-2
	]

	return ((copy/part p-md5 output-length) xor copy/part p-sha1 output-length)
]

make-key-block: func [
	ctx [object!]
][
	ctx/key-block: prf ctx/master-secret "key expansion" rejoin [ctx/server-random ctx/client-random] 2 * ctx/hash-size + (2 * ctx/crypt-size)
]

make-master-secret: func [
	ctx [object!]
	pre-master-secret [binary!]
][
	ctx/master-secret: prf pre-master-secret "master secret" rejoin [ctx/client-random ctx/server-random] 48
]

do-commands: func [
	ctx [object!]
	commands [block!]
	/no-wait
	/local arg cmd
][
	clear ctx/msg
	parse commands [
		some [
			set cmd [
				'client-hello (client-hello ctx)
				| 'client-key-exchange (client-key-exchange ctx)
				| 'change-cipher-spec (change-cipher-spec ctx)
				| 'finished (encrypted-handshake-msg ctx finished ctx)
				| 'application  set arg [string! | binary!] (application-data ctx arg)
			] (
				debug [ctx/seq-num "<--" cmd]
				ctx/seq-num: ctx/seq-num + 1
				update-proto-state/write-state ctx cmd
			)
		]
	]
	debug ["writing bytes:" length? ctx/msg]
	ctx/resp: clear []
	write ctx/connection ctx/msg

	unless no-wait [
		unless port? wait [ctx/connection 30][do make error! "port timeout"]
	]
	ctx/resp
]

;TLS scheme

tls-init: func [
	ctx [object!]
][
	ctx/seq-num: 0
	ctx/protocol-state: none
	ctx/encrypted?: false
;	if port [close port]

	switch ctx/crypt-method [
		rc4 [
			if ctx/encrypt-stream [
				ctx/encrypt-stream: rc4 none ctx/encrypt-stream
			]
			if ctx/decrypt-stream [
				ctx/decrypt-stream: rc4 none ctx/decrypt-stream
			]
		]
	]
]

tls-read-data: func [
	ctx [object!]
	port-data [binary!]
	/local
		result data len proto new-state next-state record enc? pp
][
	result: copy #{}
	record: copy #{}

	port-data: append ctx/data-buffer port-data
	clear ctx/connection/data

	while [
		5 = length? data: copy/part port-data 5
	][
		unless proto: select protocol-types data/1 [
			do make error! "unknown/invalid protocol type"
		]

		append clear record data

		len: to-integer copy/part at data 4 2

		port-data: skip port-data 5

		debug ["reading bytes:" len]

		if len > length? port-data [
			ctx/data-buffer: copy skip port-data -5
			debug ["not enough data: read " length? port-data " of " len " bytes needed"]
			debug ["CONTINUE READING..." length? head ctx/data-buffer length? result length? record]
			unless empty? result [append ctx/resp parse-response ctx result]

			return false
			do make error! rejoin ["invalid length data: read " length? port-data "/" len " bytes"]
		]

		data: copy/part port-data len
		port-data: skip port-data len

		debug ["received bytes:" length? data]

		append record data

		new-state: either proto = 'handshake [
			either enc? [
				'encrypted-handshake
			][
				select message-types record/6
			]
		][
			proto
		]

		update-proto-state ctx new-state

		if ctx/protocol-state = 'change-cipher-spec [enc?: true]

		append result record

		next-state: get-next-proto-state ctx

		debug ["State:" ctx/protocol-state "-->" next-state]
		ctx/data-buffer: copy port-data

		unless next-state [
			debug ["READING FINISHED" length? head ctx/data-buffer length? result]
			append ctx/resp parse-response ctx result
			return true
		]
	]

	debug ["READ NEXT STATE" length? head ctx/data-buffer length? result]

	append ctx/resp parse-response ctx result

	return false
]

tls-awake: funct [event [event!]] [
	debug ["TLS Awake-event:" event/type]
	port: event/port
	tls-port: port/locals
	tls-awake: :tls-port/awake
	switch/default event/type [
		lookup [
			open port
			tls-init tls-port/state
;			return tls-awake make event! [type: 'lookup port: tls-port]
			insert system/ports/system make event! [type: 'lookup port: tls-port]
			return false
		]
		connect [
			do-commands tls-port/state [client-hello]

			if tls-port/state/resp/1/type = 'handshake [
				do-commands tls-port/state [
					client-key-exchange
					change-cipher-spec
					finished
				]
			]
			insert system/ports/system make event! [type: 'connect port: tls-port]
			return false
		]
		wrote [
			if tls-port/state/protocol-state = 'application [
				insert system/ports/system make event! [type: 'wrote port: tls-port]
				return false
			]
			read port
			return false
		]
		read  [
			debug ["Read" length? port/data "bytes" tls-port/state/protocol-state]

			complete?: tls-read-data tls-port/state port/data
			application?: false

			foreach proto tls-port/state/resp [
				if proto/type = 'application [
					foreach msg proto/messages [
						if msg/type = 'app-data [
							append tls-port/data msg/content
							application?: true
							msg/type: none
						]
					]
				]
			]

			either application? [
				insert system/ports/system make event! [type: 'read port: tls-port]
			][
				read port
			]
			return complete?
		]
		close [
			insert system/ports/system make event! [type: 'close port: tls-port]
			return true
		]
	] [
		print ["Unexpected TLS event:" event/type]
		close port
		return true
	]
	false
]

sys/make-scheme [
	name: 'tls
	title: "TLS protocol"
	spec: make system/standard/port-spec-net []
	actor: [
		read: func [
			port [port!]
			/local
				resp data msg
		][
			debug ["READ" open? port/state/connection]
			read port/state/connection
			return port
		]

		write: func [port [port!] value [any-type!]][
			foreach proto port/state/resp [
				if proto/type = 'handshake [
					foreach msg proto/messages [
						if msg/type = 'finished [
							;server sent "finished" msg so we can finally start sending app data
							do-commands/no-wait port/state compose [
								application (value)
							]
							return port
						]
					]
				]
			]
		]
		open: func [port [port!] /local conn][
			if port/state [return port]

			if none? port/spec/host [tls-error "Missing host address"]

			port/state: context [
				data-buffer: copy #{}
				resp: none

				version: #{03 01} ;protocol version used

				server?: false

				protocol-state: none
				hash-method: 'sha1
				hash-size: 20
				crypt-method: 'rc4
				crypt-size: 16	; 128bits
				cipher-suite: #{00 05} ;TLS_RSA_WITH_RC4_128_SHA

				client-crypt-key:
				client-mac-key:
				server-crypt-key:
				server-mac-key: none

				seq-num: 0

				msg: make binary! 4096
				handshake-messages: make binary! 4096 ;all messages from Handshake records except 'HelloRequest's
				encrypted?: false
				client-random: server-random: pre-master-secret: master-secret: key-block: certificate: pub-key: pub-exp: none

				encrypt-stream: decrypt-stream: none

				connection: none
			]

			port/state/connection: conn: make port! [
				scheme: 'tcp
				host: port/spec/host
				port-id: port/spec/port-id
				ref: rejoin [tcp:// host ":" port-id]
			]

			port/data: clear #{}

			conn/awake: :tls-awake
			conn/locals: port
			open conn
			port
		]
		open?: func [port [port!]][
			found? all [port/state open? port/state/connection]
		]
		close: func [port [port!]][
			if port/state [
				close port/state/connection
				debug "TLS/TCP port closed"
				port/state/connection/awake: none
				port/state: none
			]
			port
		]
		copy: func [port [port!]][
			if port/data [copy port/data]
		]
		query: func [port [port!]][
			all [port/state query port/state/connection]
		]
		length?: func [port [port!]][
			either port/data [length? port/data] [0]
		]
	]
]


# For each state, iterate through all the zipcodes. For each zipcode, create and save a list of 8 dataframes to AWS.
# Each dataframe in this list will contain the geographic coordinates for a given travel time from the given zipcode
# in a given state.

# the zipcode coordinates are population weighted

# Load required libraries and helper functions
source(here::here("R/manifest.R"))
source(here::here("R/shared-objects.R"))
source("~/Dropbox/setup-mapbox.r")

# Using population weighted zip centroids
load("public-data/weighted_zip_centroids.rda")

zip_centroid_2 <-
  zip_centroid %>%
  filter(!is.na(wtd_long)) %>%
  rename(x =wtd_long, y = wtd_lat)

#   Given the limitation that we cannot go over 60 minutes isochrones
#  These are all the possible travel times that we can use:

required_travel_times <- list(c("30"), c("60"))

# Parallelize future map code
plan(multiprocess,workers = availableCores()-1)

states_to_run <- c("AK") %>% unique()

# Create objects by state for the first 10 states
for (st in states_to_run) {
  if (!(st %in% c("XXXN","XXXXIA"))) {
  # Create an iterable object by state, with longitude and latitudes
  st_zip_centroids_coords <-
    zip_centroid_2 %>%
    filter(state == st)

  print(st)

  # For a given zip in a given state, obtain isochrones for 10,15, 20, and 30 minutes driving times
  travel_time_15_30 <-
    st_zip_centroids_coords %>%
    mutate(test = future_map2(x, y, ~ (c(.x, .y)))) %>%
    pull(test) %>%
    future_map(~ (get_mapbox_isochrone(long = .x[1], lat = .x[2], contours_minutes = c("30"),
                                       mapbox_token = my_mapbox_token)), .progress = TRUE) %>%
    set_names(st_zip_centroids_coords$zip)

  #Sys.sleep(10)

  # For a given zip in a given state, obtain isochrones for 40, 45, 50, and 60 minutes driving times
  travel_time_40_60 <-
    st_zip_centroids_coords %>%
    mutate(test = future_map2(x, y, ~ (c(.x, .y)))) %>%
    pull(test) %>%
    future_map(~ (get_mapbox_isochrone(long = .x[1], lat = .x[2], contours_minutes = c("60"),
                                       mapbox_token = my_mapbox_token)), .progress = TRUE) %>%
    set_names(st_zip_centroids_coords$zip)
  #
  # # # Merge the travel times isochrones into one list object

  all_travel_times <- mapply(c, travel_time_15_30,travel_time_40_60,SIMPLIFY = TRUE)

  present <-
    all_travel_times %>% map_lgl(~(
      !is.null(.x)
    ))

  minutes_ran <- all_travel_times[present] %>% transpose() %>% names()
  l_minutes_ran <- all_travel_times[present] %>% transpose() %>% map_int(~(.x %>% length()))
  cat("Minutes Ran:\n ",minutes_ran[1]," ",l_minutes_ran[1],"\n ",minutes_ran[2]," ",l_minutes_ran[2],"\n")
  #
  file_name_st <- paste0(st, "-zip-isochrones.Rdata")
  print(file_name_st)
  s3save(all_travel_times, bucket = "health-care-markets", object = paste0("isochrones-data/state/weighted-zip-centroids/", file_name_st))
  #

  Sys.sleep(15)
  }
}

xy_geography_tmp <-
  all_travel_times %>%
  purrr::transpose() %>%
  future_map(~(.x %>% future_map(~ (.x[[1]])) %>% future_map(~ (as.vector(.x)))))

# Debugging
for (minutes in c("40", "30")) {
  # cat(minutes)

  if (!is.null(xy_geography_tmp[minutes] %>% purrr::pluck(1))) {
    print(minutes)
    foo <- xy_geography_tmp[minutes] %>% purrr::pluck(1)

    foo2 <-
      #foo %>%
      Filter(Negate(is.null), foo) %>%
      future_map(~ (do.call("rbind", .x) %>% data.frame() %>% set_names(c("longitude", "latitude")) %>% tbl_df())) %>%
      bind_rows(.id = "zip_code") %>%
      group_by(zip_code) %>%
      nest() %>%
      set_names(c("zip_code", paste0("iso_xy_", minutes)))

    assign(paste0("df_iso_", minutes), foo2)
    cat("\n ...\n")
  }
}

rm(list = ls(pattern = "df_iso_"))
gc()

get_providers_in_geography <- function(xy_provider, xy_geography) {
  tmp <-
    xy_geography %>%
    #purrr::pluck(1) %>%
    st_as_sf(coords = c("longitude", "latitude"), crs = 4326) %>%
    summarise(geometry = st_combine(geometry)) %>%
    st_cast("POLYGON")

  xy_provider %>%
    filter(st_within(., tmp, sparse = FALSE)) %>%
    data.frame() %>%
    select(-geometry)
}

df_iso <-
  df_iso_30 %>%
  left_join(df_iso_40, "zip_code")

xy_provider <-
  sf::read_sf(
    paste0("../health-care-markets/provider_location_shp/contig_states/vericred19_aug_npi_",
           st, ".shp")) %>%
  st_transform(crs = 4326)

npi_ri <-
  df_iso %>%
  #sample_n(10) %>%
  #filter(zip_code == "46711") %>%
# 30 Minutes
  mutate(isochrone_30 = future_map(iso_xy_30, ~ (
    .x %>%
      st_as_sf(coords = c("longitude", "latitude"), crs = 4326) %>%
      summarise(geometry = st_combine(geometry)) %>%
      st_cast("POLYGON")
  ))) %>%
  mutate(providers_30 = map(iso_xy_30, ~ (get_providers_in_geography(xy_provider = xy_provider, xy_geography = .x)))) %>%
  mutate(providers_30_xy = future_map(providers_30, ~ (
    .x %>% st_as_sf(coords = c("longitude", "latitude"), crs = 4326)
  ))) %>%
  # 40 Minutes
  mutate(isochrone_40 = future_map(iso_xy_40, ~ (
    .x %>%
      st_as_sf(coords = c("longitude", "latitude"), crs = 4326) %>%
      summarise(geometry = st_combine(geometry)) %>%
      st_cast("POLYGON")
  ))) %>%
  mutate(providers_40 = future_map(iso_xy_40, ~ (get_providers_in_geography(xy_provider = xy_provider, xy_geography = .x)))) %>%
  mutate(providers_40_xy = future_map(providers_40, ~ (
    .x %>% st_as_sf(coords = c("longitude", "latitude"), crs = 4326)
  )))

leaflet(sf_zip %>% filter(state_01 == "IN")) %>%
  addTiles() %>%
  addProviderTiles("CartoDB.Positron", group = "Greyscale") %>%
  addPolygons(fill = T, stroke = T, color = "red",
              data = npi_ri %>% filter(zip_code == "46711") %>% pull(isochrone_30) %>% purrr::pluck(1),
              weight = 0.5, fillOpacity = 0.3) %>%
  addPolygons(fill = T, stroke = T, color = "blue",
              data = npi_ri %>% filter(zip_code == "46711") %>% pull(isochrone_40) %>% purrr::pluck(1),
              weight = 0.5, fillOpacity = 0.3)

tmp <-
  npi_ri$iso_xy_30 %>%
  purrr::pluck(1) %>%
  st_as_sf(coords = c("longitude", "latitude"), crs = 4326) %>%
  summarise(geometry = st_combine(geometry)) %>%
  st_cast("POLYGON")

xy_provider %>%
  filter(st_within(., tmp, sparse = FALSE)) %>%
  data.frame() %>%
  select(-geometry)


# evaluate protected areas and networks against shifts in species distribution
# calculate species gains, losses, turnover, etc.
# also output table of species p(occur) by MPA in the current time-period (2007-2020)

############
## Flags
############

# choose the rcp(s)
RCPS <- c(26, 85)

# select initial and final timeperiod for these grids
PERIODS <- c('2007-2020', '2081-2100')

# climate models in the projections
#bcc-csm1-1-m, bcc-csm1-1, CanESM2, CCSM4, CESM1-CAM5, CNRM-CM5, GFDL-CM3, GFDL-ESM2M, GFDL-ESM2G, GISS-E2-R, GISS-E2-H, HadGEM2-ES, IPSL-CM5A-LR, IPSL-CM5A-MR, MIROC-ESM, MIROC5, MPI-ESM-LR, NorESM1-ME
NMODS <- 18 # for the pres/abs models. Models 12 (HadGEM2-ES) and 16 (MIROC5) are extraneous since not in the biomass projections used in rest of project
MODSPRESTODROP <- c(12,16)

# path to the pres-abs projection results from Morley et al. 2018. At 0.05 grid size.
PRESABSPATH <- '/local/shared/pinsky_lab/projections_PlosOne2018/CEmodels_proj_PresAbs_May2018'

####################
## helper functions
####################
require(data.table)
# set default rounding (2 bytes) so that data.table will merge numeric values appropriately
# see https://rdrr.io/rforge/data.table/man/setNumericRounding.html
setNumericRounding(2)

#require(lme4) # for mixed-effects models
#require(car) # for testing ME models
#require(Hmisc)

###########################
## Load and set up WDPA data
###########################

wdpagrid <- fread('gunzip -c output/wdpa_cov_by_grid0.05.csv.gz', drop = 1) # shows which MPAs are in which grid cells. each line is a unique grid cell-MPA combination.

	# convert lon to -360 to 0 (instead of -180 to 180) to match the pres/abs projections and to plot more nicely
	wdpagrid[lon>0, lon := lon-360]

	# set up MPA networks
	wdpagrid[SUB_LOC == 'US-CA' & MANG_AUTH == 'State Fish and Wildlife',network := 'mlpa']
	wdpagrid[grepl('US-DE|US-FL|US-GA|US-MA|US-MD|US-ME|US-NC|US-NJ|US-NY|US-RI|US-SC|US-VA', SUB_LOC) & !grepl('US-N/A', SUB_LOC) & (lon > -100), network := 'eastcoast'] # by exluding US-N/A, this won't include federal water closures
	wdpagrid[(SUB_LOC %in% c('US-AK')), network := 'ak'] # by choosing by state, this won't include federal water closures

	# calculate mpa extent
	wdpagrid[, ':='(lat_min = min(lat), lat_max = max(lat), lon_min = min(lon), lon_max = max(lon)), by = WDPA_PID]

#	wdpagrid[network=='mlpa',plot(lon,lat)]
#	wdpagrid[network=='eastcoast',plot(lon,lat)]
#	wdpagrid[network=='ak',plot(lon,lat)]
#	require(maps); map(database='world2',add=TRUE)

##############################################################
# Load in pres/abs results for each RCP and each species
# and calculate summary statistics on species turnover by MPA
##############################################################
# the list of MPAs. Turnover data will be added as columns to this
wdpa <- wdpagrid[!duplicated(WDPA_PID), ]
wdpa[,c('gridpolyID', 'lat', 'lon', 'area_wdpa', 'area_grid', 'prop_grid', 'prop_wdpa') := NULL] # remove gridcell-specific columns

# step through each species' projections
projcols <- c('lat', 'lon', paste0('mean', 1:NMODS)) # names of columns in pred.agg to use (the projections)
for (i in 1:length(RCPS)) {
    print(paste0(Sys.time(), ' On RCP ', RCPS[i], '. Species: '))
    files <- list.files(path = PRESABSPATH, pattern = paste('*rcp', RCPS[i], '*', sep = ''), full.names = TRUE)

    # load presmap for each model run and process the results
    # then calculate change in p(occur)
    for (j in 1:length(files)) {
        cat(paste0(' ', j))
        load(files[j]) # loads pred.agg data.frame
        pred.agg <- as.data.table(pred.agg)

        # round lat lon to nearest 0.05 so that merging is successful with WDPA
        pred.agg[, lat := floor(latitude*20)/20 + 0.025] # assumes 0.05 grid size
        pred.agg[, lon := floor(longitude*20)/20 + 0.025] # assumes 0.05 grid size
        setkey(pred.agg, lat, lon)

        # reorganize so that time 2 and time 1 are separate columns, rows are locations
        presbyloc <- merge(pred.agg[year_range == PERIODS[1], ..projcols], pred.agg[year_range == PERIODS[2], ..projcols], by = c('lat', 'lon'), suffixes = c('.t1', '.t2'))

        # merge pres/abs data with WDPA grid data and calculate summary stats about species change through time
        # summary stat column names are of form [sumstatname].[RCP].[modnumber]
        wdpagridspp <- merge(wdpagrid, presbyloc, all.x = TRUE, by = c('lat', 'lon'))
        for (m in 1:NMODS) { # for each climate model
            if(!(m %in% MODSPRESTODROP)){ # drop two of the pres-abs models
                if (m < 12) thismodnum <- m
                if (m > 12 & m < 16) thismodnum <- m - 1 # adjust model numbers to match biomass models
                if (m > 16) thismodnum <- m - 2

                wdpagridspp[is.na(wdpagridspp[[paste0('mean', m, '.t1')]]), (paste0('mean', m, '.t1')) := 0] # set NAs to 0 (species not present)
                wdpagridspp[is.na(wdpagridspp[[paste0('mean', m, '.t2')]]), (paste0('mean', m, '.t2')) := 0]

                # aggregate p(occur) across grid cells into full MPAs
                sppbyMPA <- wdpagridspp[, .(pinit = 1 - prod(1 - get(paste0('mean', m, '.t1'))*prop_wdpa), # p(occur whole MPA) at initial timepoint as 1 - prod(1-p(occur per grid))
                                     pfinal = 1 - prod(1 - get(paste0('mean', m, '.t2'))*prop_wdpa)
                                     ), by = WDPA_PID]
                #print(dim(sppbyMPA))

                # merge wpda with sppbyMPA (latter has results from the current species)
                wdpa <- merge(wdpa, sppbyMPA, by = 'WDPA_PID')

                # calculate summary stats by MPA and add this species onto results from previous species
                if (!(paste0('ninit.', RCPS[i], '.', thismodnum) %in% colnames(wdpa))) { # if output column in wdpa doesn't yet exist, create it
                    wdpa[, (paste0('ninit.', RCPS[i], '.', thismodnum)) := pinit]
                    wdpa[, (paste0('nfinal.', RCPS[i], '.', thismodnum)) := pfinal]
                    wdpa[, (paste0('nshared.', RCPS[i], '.', thismodnum)) := pinit*pfinal]
                    wdpa[pinit > pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := pinit - pfinal]
                    wdpa[pinit <= pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := 0]
                    wdpa[pinit < pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := pfinal - pinit]
                    wdpa[pinit >= pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := 0]
                } else {# if columns already exist, add the new species' values onto the existing values
                    wdpa[, (paste0('ninit.', RCPS[i], '.', thismodnum)) := get(paste0('ninit.', RCPS[i], '.', thismodnum)) + pinit]
                    wdpa[, (paste0('nfinal.', RCPS[i], '.', thismodnum)) := get(paste0('nfinal.', RCPS[i], '.', thismodnum)) + pfinal]
                    wdpa[, (paste0('nshared.', RCPS[i], '.', thismodnum)) := get(paste0('nshared.', RCPS[i], '.', thismodnum)) + pinit*pfinal]
                    wdpa[pinit > pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := get(paste0('nlost.', RCPS[i], '.', thismodnum)) + pinit - pfinal]
                    wdpa[pinit < pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := get(paste0('ngained.', RCPS[i], '.', thismodnum)) + pfinal - pinit]
                }
                wdpa[, c('pinit', 'pfinal') := NULL] # delete the species-specific columns now that we have the summaries we need
            }
        }
        # wdpa[,print(max(get(paste0('ninit.', RCPS[i], '.1'))))] # a test that cumulative sums are being calculated. Should increase through the loop
    }
}
print(Sys.time())

dim(wdpa) # 923 x 127

# how many rows are zero?
wdpa[, .(sum(ninit.26.1 == 0), sum(ninit.85.1 == 0))]
wdpa[, .(sum(ninit.26.1 > 0), sum(ninit.85.1 > 0))]
    # wdpa[ninit.26.1 > 0, plot(lon_max, lat_max, cex = 0.1, xlim=c(-190, 0))]
    # wdpa[ninit.26.1 == 0, points(lon_max, lat_max, cex = 0.5, col = 'red')]

# write out species data
write.csv(wdpa, file = gzfile('temp/wdpaturnbyMPAbymod.csv.gz'))

# wdpa <- fread('gunzip -c temp/wdpaturnbyMPAbymod.csv.gz', drop = 1) # don't read the row numbers

################################################################################
# Load in pres/abs results for each RCP and each species
# and aggregate p(occur) for each species in each MPA for current time-period
# for comparison against observations
################################################################################

projcols <- c('lat', 'lon', paste0('mean', 1:NMODS)) # names of columns in pred.agg to use (the projections)
for (i in 1:length(RCPS)) {
    print(paste0(Sys.time(), ' On RCP ', RCPS[i], '. Species: '))
    files <- list.files(path = PRESABSPATH, pattern = paste('*rcp', RCPS[i], '*', sep = ''), full.names = TRUE)

    # load presmap for each model run and process the results
    for (j in 1:length(files)) {
        cat(paste0(' ', j))
        load(files[j]) # loads pred.agg data.frame
        thisspp <- gsub(paste0(PRESABSPATH, '/|_Atl|_Pac|_rcp26|_rcp85|_jas_PresAbs_projection_AGG.RData'), '', files[j])
        pred.agg <- as.data.table(pred.agg)

        # round lat lon to nearest 0.05 so that merging is successful with WDPA
        pred.agg[, lat := floor(latitude*20)/20 + 0.025] # assumes 0.05 grid size
        pred.agg[, lon := floor(longitude*20)/20 + 0.025] # assumes 0.05 grid size
        setkey(pred.agg, lat, lon)

        # trim to 2007-2020
        pred.agg <- pred.agg[year_range == '2007-2020',]

        # merge pres/abs data with WDPA grid data
        wdpagridspp <- merge(wdpagrid, pred.agg, by = c('lat', 'lon')) # don't include all MPAs, to drop MPAs for which this species wasn't projected (e.g., Atl vs Pac)

        # calculate summary stats about species p(occur) by MPA for each climate model
        for (m in 1:NMODS) { # for each climate model
            if(!(m %in% MODSPRESTODROP)){ # drop two of the pres-abs models
                if (m < 12) thismodnum <- m
                if (m > 12 & m < 16) thismodnum <- m - 1 # adjust model numbers to match biomass models
                if (m > 16) thismodnum <- m - 2

                # aggregate p(occur) across grid cells into full MPAs
                sppbyMPA <- wdpagridspp[, .(spp = thisspp, rcp = RCPS[i], model = thismodnum, poccur = 1 - prod(1 - get(paste0('mean', m))*prop_wdpa)), by = WDPA_PID] # p(occur whole MPA) at initial timepoint as 1 - prod(1-p(occur per grid))
                    #print(dim(sppbyMPA))

                # add this species/model/rcp onto the output data.table
                if(!exists('wdpa_by_spp_projnow')) { # create the output table if it doesn't exist
                    wdpa_by_spp_projnow <- sppbyMPA
                } else {
                    wdpa_by_spp_projnow <- rbind(wdpa_by_spp_projnow, sppbyMPA)
                }
            }
        }
    }
}
print(Sys.time())

dim(wdpa_by_spp_projnow) #

# write out species data
write.csv(wdpa_by_spp_projnow, file = gzfile('temp/wdpa_by_spp_projnow.csv.gz'))

##############################################
# Calculate turnover within select MPA networks
# For each model in the ensemble
##############################################
wdpanet <- wdpagrid[!is.na(network), .(lat = mean(lat), lon = mean(lon), area = sum(area_fullwdpa)), by = network ] # the list of MPA networks. Turnover data will be added as columns to this

projcols <- c('lat', 'lon', paste0('mean', 1:NMODS)) # names of columns in pred.agg to use (the projections)
for (i in 1:length(RCPS)) {
    print(paste0(Sys.time(), ' On RCP ', RCPS[i], '. Species: '))
    files <- list.files(path = PRESABSPATH, pattern = paste('*rcp', RCPS[i], '*', sep = ''), full.names = TRUE)

    # load presmap for each model run and process the results
    # then calculate change in p(occur)
    for (j in 1:length(files)) {
        cat(paste0(' ', j))
        load(files[j]) # loads pred.agg data.frame
        pred.agg <- as.data.table(pred.agg)

        # round lat lon to nearest 0.05 so that merging is successful with WDPA
        pred.agg[, lat := floor(latitude*20)/20 + 0.025] # assumes 0.05 grid size
        pred.agg[, lon := floor(longitude*20)/20 + 0.025] # assumes 0.05 grid size
        setkey(pred.agg, lat, lon)

        # reorganize so that time 2 and time 1 are separate columns, rows are locations
        presbyloc <- merge(pred.agg[year_range == PERIODS[1], ..projcols], pred.agg[year_range == PERIODS[2], ..projcols], by = c('lat', 'lon'), suffixes = c('.t1', '.t2'))

        # merge pres/abs data with WDPA grid data and calculate summary stats about species change through time
        # summary stat column names are of form [sumstatname].[RCP].[modnumber]
        wdpagridspp <- merge(wdpagrid, presbyloc, all.x = TRUE, by = c('lat', 'lon'))
        for (m in 1:NMODS) { # for each climate model
             if (!(m %in% MODSPRESTODROP)) { # drop two of the pres-abs models
                if (m < 12) thismodnum <- m
                if (m > 12 & m < 16) thismodnum <- m - 1 # adjust model numbers to match biomass models
                if (m > 16) thismodnum <- m - 2

                wdpagridspp[is.na(wdpagridspp[[paste0('mean', m, '.t1')]]), (paste0('mean', m, '.t1')) := 0] # set NAs to 0 (species not present)
                wdpagridspp[is.na(wdpagridspp[[paste0('mean', m, '.t2')]]), (paste0('mean', m, '.t2')) := 0]

                # aggregate p(occur) across grid cells into full MPA networks
                sppbynet <- wdpagridspp[!is.na(network), .(pinit = 1 - prod(1 - get(paste0('mean', m, '.t1'))*prop_wdpa), # p(occur whole MPA) at initial timepoint as 1 - prod(1-p(occur per grid))
                                     pfinal = 1 - prod(1 - get(paste0('mean', m, '.t2'))*prop_wdpa)
                                     ), by = network]
                #print(dim(sppbynet))

                # merge wpda with sppbynet (latter has results from the current species)
                wdpanet <- merge(wdpanet, sppbynet, by = 'network')

                # calculate summary stats and add this species onto results from previous species
                if (!(paste0('ninit.', RCPS[i], '.', thismodnum) %in% colnames(wdpanet))) { # if output column in wdpanet doesn't yet exist, create it
                    wdpanet[, (paste0('ninit.', RCPS[i], '.', thismodnum)) := pinit]
                    wdpanet[, (paste0('nfinal.', RCPS[i], '.', thismodnum)) := pfinal]
                    wdpanet[, (paste0('nshared.', RCPS[i], '.', thismodnum)) := pinit*pfinal]
                    wdpanet[pinit > pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := pinit - pfinal]
                    wdpanet[pinit <= pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := 0]
                    wdpanet[pinit < pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := pfinal - pinit]
                    wdpanet[pinit >= pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := 0]
                } else {# if columns already exist, add the new species' values onto the existing values
                    wdpanet[, (paste0('ninit.', RCPS[i], '.', thismodnum)) := get(paste0('ninit.', RCPS[i], '.', thismodnum)) + pinit]
                    wdpanet[, (paste0('nfinal.', RCPS[i], '.', thismodnum)) := get(paste0('nfinal.', RCPS[i], '.', thismodnum)) + pfinal]
                    wdpanet[, (paste0('nshared.', RCPS[i], '.', thismodnum)) := get(paste0('nshared.', RCPS[i], '.', thismodnum)) + pinit*pfinal]
                    wdpanet[pinit > pfinal, (paste0('nlost.', RCPS[i], '.', thismodnum)) := get(paste0('nlost.', RCPS[i], '.', thismodnum)) + pinit - pfinal]
                    wdpanet[pinit < pfinal, (paste0('ngained.', RCPS[i], '.', thismodnum)) := get(paste0('ngained.', RCPS[i], '.', thismodnum)) + pfinal - pinit]
                }
                wdpanet[, c('pinit', 'pfinal') := NULL] # delete the species-specific columns now that we have the summaries we need
             }
        }
        # wdpanet[,print(max(get(paste0('ninit.', RCPS[i], '.1'))))] # a test that cumulative sums are being calculated. Should increase through the loop
    }
    cat('\n')
}
print(Sys.time())

dim(wdpanet) # 923 x 127

# how many rows are zero?
wdpanet[, .(sum(ninit.26.1 == 0), sum(ninit.85.1 == 0))]
wdpanet[, .(sum(ninit.26.1 > 0), sum(ninit.85.1 > 0))]
    # wdpanet[ninit.26.1 > 0, plot(lon_max, lat_max, cex = 0.1, xlim=c(-190, 0))]
    # wdpanet[ninit.26.1 == 0, points(lon_max, lat_max, cex = 0.5, col = 'red')]

# write out species data
write.csv(wdpanet, file = gzfile('temp/wdpaturnbynetbymod.csv.gz'), row.names = FALSE)

# wdpanet <- fread('gunzip -c temp/wdpaturnbynetbymod.csv.gz') # don't read the row numbers


#' Produce a model of irradiance for an entire study area or selected control points
#'
#' @param dem A [sp::SpatialGridDataFrame] or [raster::RasterLayer] object giving the digital
#' 		elevation model of the study area.
#' @param output_points A set out output points; either a [sp::SpatialPoints] object or a raster mask.
#' @param times A vector of [POSIXct] objects giving the dates and times at which to compute irradiance. These should be given in local (to the DEM) time
#' @param timezone An integer giving the offset in hours from UTC that applies to the DEM; see the manual for r.sun for details
#' @param use_existing logical, if TRUE then existing slope, aspect, longitute, and horizon
#' rasters will be used, if FALSE then they will be recomputed
#' @param dem_name character; this parameter (and similar name parameters) tell GRASS what names to
#' use for the rasters needed for the analysis; they must exist in the GRASS location/mapset if
#' `use_existing == TRUE`.
#' @param horizon_pars List of arguments for GRASS74's r.horizon; see the GRASS GIS help files ]
#' 		if you wish to change the defaults.
#' @param newSession Boolean, if TRUE a new grass session will be started even if one already
#'  	exists
#' @param gisBase character; the location of the GRASS installation
#' 		(see WatershedTools::GrassSession)

#' @details Requires an existing installation of GRASS7, as well as the rgrass7 package. It is
#' 		first necessary to run [rgrass7::initGRASS]. Recommended settings for initGRASS include
#' 		`home = tempdir()` and `SG = SpatialGrid(dem_gridded)`. To produce the gridded DEM
#' 		from a raster, use:
#' 			`dem_gridded <- SpatialPoints(dem)`
#' 			`gridded(dem_gridded) <- TRUE`
#'
#' Note that running the light model can be extremely slow for large study areas and/or high-resolution DEMs and/or long time series.
#'
#' It is strongly recommended to use the `output_points` argument to set a list of locations at which to compute the output, otherwise memory usage can be extreme. For rasters, output will be returned for all non-NA cells.
#' @return A matrix, one row per output point, one column per date/time for computation. Column names are the integer values of the date/time, rownames are the coordinates of the point
#' @export
irradiance <- function(dem, output_points, times, timezone, use_existing = FALSE, dem_name = "dem",
	slope_name = "slope", aspect_name = "aspect", lon_name = "longitude",
	horizon_pars = list(step=30, bufferzone=200, maxdistance=5000, horBaseName = "horizonAngle"),
	newSession = FALSE, gisBase)
{
	if(!requireNamespace('rgrass7'))
		stop("The rgrass7 package must be installed to use this function")

	if(!requireNamespace('WatershedTools'))
		stop("The WatershedTools package must be installed to use this function")

	if(is(output_points, "sf"))
		output_points = as(output_points, "Spatial")

	if(newSession || nchar(Sys.getenv("GISRC")) == 0) {
		gs <- WatershedTools::GrassSession(dem, gisBase, dem_name, override = TRUE)
	}

	if(newSession || !use_existing) {
		setup_irradiance(dem_name, slope_name, aspect_name, lon_name, horizon_pars)
	}

	## preallocate a large matrix to store results
	irrad_mat <- matrix(NA, ncol=length(times), nrow=length(output_points))
	colnames(irrad_mat) <- as.integer(times)
	rownames(irrad_mat) <- apply(coordinates(output_points), 1, paste, collapse=',')
	## for each time/date combo, run the light model
	for(i in 1:length(times))
	{
		dt <- times[i]
		dy <- lubridate::yday(dt)
		tm <- lubridate::hour(dt) + lubridate::minute(dt)/60
		err <- rgrass7::execGRASS("r.sun", flags=c("overwrite", "quiet"), elevation=dem_name,
			horizon_basename = horizon_pars$horBaseName, horizon_step = horizon_pars$step,
			day=dy, time=tm, glob_rad="irradiance_out", aspect=aspect_name, slope=slope_name,
			long=lon_name,  civil_time=timezone)

		# bring the raster back into R
		irr <- raster::raster(rgrass7::readRAST("irradiance_out"))
		irrad_mat[,i] <- extract(irr, output_points)
	}
	irrad_mat
}

#' Create rasters needed for irradiance analysis
#' @param dem_name character; this parameter (and similar name parameters) tell GRASS what names to
#' use for the rasters needed for the analysis; they must exist in the GRASS location/mapset if
#' `use_existing == TRUE`.
#' @param horizon_pars List of arguments for GRASS74's r.horizon; see the GRASS GIS help files if you wish to change the defaults.
#' @keywords internal
setup_irradiance <- function(dem_name, slope_name, aspect_name, lon_name, horizon_pars)
{
	## build slope and aspect maps
	err <- rgrass7::execGRASS("r.slope.aspect", flags=c("overwrite"), elevation=dem_name,
		aspect=aspect_name, slope=slope_name)

	## produce a longitute raster
	err <- rgrass7::execGRASS("r.latlong", flags=c('overwrite', 'l'), input=dem_name,
		output=lon_name)

	## pre-compute horizon angles, slow but saves significant time
	err <- rgrass7::execGRASS("r.horizon", flags=c("overwrite"), elevation=dem_name,
		step=horizon_pars$step, bufferzone=horizon_pars$bufferzone,
		output = horizon_pars$horBaseName, maxdistance=horizon_pars$maxdistance)
}


pannzer2gaf <- function(in_file,out_gaf){
    print("Reading the input file")
    in_file="PANNZER/results/pannzer_go.txt"
    out_file="PANNZER/gaf/pannzer-0.0.gaf"
    gaf_date = format(Sys.time(),"%m%d%Y")

    pannzer_data = fread(in_file)
    tmp = gsub("_P[0-9]+","",pannzer_data$QueryId)
    tmp = gsub("FGP","FG",tmp,fixed = T)
    tmp

    gaf_cols=fread("../gaf_cols.txt",header = F)$V1
    gaf_cols
    pannzer_data
    print("Converting to GAF 2.0")
    gaf_data = pannzer_data[,.(QueryId,GO_class,Score)]
    colnames(gaf_data) = c("db_object_id","term_accession","with")

    min_score=min(gaf_data$with)
    max_score=max(gaf_data$with)
    gaf_data$with = (gaf_data$with - min_score)/(max_score - min_score)

    obo_data = check_obo_data("go.obo")

    tmp_aspect = get_aspect(obo_data,gaf_data$term_accession)
    gaf_data[,aspect:=tmp_aspect]

    gaf_data[,db_object_id:=tmp]
    gaf_data[,db_object_symbol:=tmp]
    gaf_data[,db:="maize-GAMER"]
    gaf_data[,qualifier:=0]
    gaf_data[,db_reference:="MG:0000"]
    gaf_data[,evidence_code:="IEA"]
    gaf_data[,db_object_name:=""]
    gaf_data[,db_object_synonym:=""]
    gaf_data[,db_object_type:="protein"]
    gaf_data[,taxon:="taxon:4577"]
    gaf_data[,date:=gaf_date]
    gaf_data[,assigned_by:="PANNZER"]
    gaf_data[,annotation_extension:=""]
    gaf_data[,gene_product_form_id:=""]
    setcolorder(gaf_data,gaf_cols)

    print("Writing the outfile")
    write_gaf(gaf_data,out_gaf)
}


a <-2
a*a


###############################################################################
#
#   R script to generate a heatmap
#
#   AUTHOR: Krish Agarwal
#   AFFILIATION: University_of_Basel
#   CONTACT: akrish136@gmail.com
#   CREATED: 23-07-2020
#   LICENSE: Apache_2.0
#
###############################################################################

# by default: suppress warnings
options(warn = -1)

# load libraries
library("optparse")
library(ggplot2)
library(ggtext)

# list the command-line arguments
option_list <- list(
  make_option("--input_tsv",
    action = "store",
    dest = "input_tsv",
    type = "character",
    help = "location and name of the tsv file"
  ),
  make_option("--input_sequence",
    action = "store",
    dest = "input_sequence",
    type = "character",
    help = "full input_sequence"
  ),
  make_option("--outfile",
    action = "store",
    dest = "output_tsv",
    type = "character",
    help = "location and name of output heatmap"
  ),
  make_option("--sequence_logos_directory",
    action = "store",
    dest = "sequence_logos_directory",
    type = "character",
    default=FALSE,
    help = "location of directory of sequence logos"
  )
)
# parse command-line arguments
opt_parser <- OptionParser(
  usage = "Usage: %prog [OPTIONS] --message [STRING]",
  option_list = option_list,
  add_help_option = FALSE,
  description = ""
)
opt <- parse_args(opt_parser)

# Storing command line arguments in variables
input_sequence <- opt$input_sequence
input_tsv <- opt$input_tsv
output_tsv <- opt$output_tsv
sequence_logos_directory <- opt$sequence_logos_directory

input_sequence <- gsub("T", "U", input_sequence) # Replace all T with U in input sequence

# This will be the hidden column names for the graph
x_axis_numbers = 1:nchar(input_sequence)

file = file(input_tsv, "r")

y_axis_labels = c()

while (length(line <- readLines(file, n = 1)) > 0) # Read the file line by line
{
    words = strsplit(line, '\t')
    pwm_id = words[[1]][1]
    if(is.element(pwm_id, y_axis_labels) == FALSE && pwm_id != "pwm_id")
    {
      y_axis_labels <- c(y_axis_labels, pwm_id)
    }
}
uniform_data = matrix(as.double("0.00"), length(y_axis_labels), length(x_axis_numbers))

close(file)

file = file(input_tsv, "r")

while (length(line <- readLines(file, n = 1)) > 0)
{
    words = strsplit(line, '\t')
    pwm_id = words[[1]][1]
    bind_pos = words[[1]][2]
    bind_prob = words[[1]][4]
    if(bind_pos != 'binding_position')
    {
      bind_combined = strsplit(bind_pos, '-') # splitting to get the starting and the last position of binding
      bind_start = bind_combined[[1]][1]
      bind_end = bind_combined[[1]][2]

      for(i in as.integer(bind_start):as.integer(bind_end))
      {
        gg = grep(pwm_id, y_axis_labels)
        uniform_data[gg, i] <- as.double(bind_prob) ## adding the probability to each position
      }
    }
}
uniform_data[uniform_data == 0] <- NA

colnames(uniform_data) <- x_axis_numbers
rownames(uniform_data) <- y_axis_labels

# Converting matrix to data frame
dff <-data.frame(col = rep(colnames(uniform_data), each = nrow(uniform_data)),
           row = rep(rownames(uniform_data), ncol(uniform_data)),
           Binding_Probability = as.vector(uniform_data))

input_seq = strsplit(input_sequence,"")

labels = c()

#### Add the sequence logo pngs to the dictionary ####
if(sequence_logos_directory != FALSE)
{
	for (label in y_axis_labels)
	{
		labels[label] = paste("<b>", label, "<b><img src='", sequence_logos_directory, "/motif_", label, ".png'
    	width='100' height='18'>", sep = "")
	}
}

if(sequence_logos_directory != FALSE)
{
	a <- ggplot(dff, aes(x = reorder(col, sort(as.numeric(col))), y = row, fill= Binding_Probability)) +
  geom_tile(color = "gray") +
  scale_x_discrete(breaks=1:nchar(input_sequence),labels=input_seq) +
  scale_y_discrete(name = NULL, labels=labels) +
  scale_fill_gradientn(colours=c("white","orange","red","dark red"), limits=c(0,1), na.value="white") + # Sets default NA colour and scale
  labs(x ="Sequence", y = "") + # Name of the x and y axis
  theme_classic()+
  theme(
    axis.text.y = element_markdown(color = "black", size = 11)
  )+
  coord_fixed(3)
  #coord_equal() #make the grid squares and independent of number of motifs analyzed
} else
{
    a <- ggplot(dff, aes(x = reorder(col, sort(as.numeric(col))), y = row, fill= Binding_Probability)) +
  geom_tile(color = "gray") +
  scale_x_discrete(breaks=1:nchar(input_sequence),labels=input_seq) +
  scale_fill_gradientn(colours=c("white","orange","red","dark red"), limits=c(0,1), na.value="white") + # Sets default NA colour and scale
  labs(x ="Sequence", y = "") + # Name of the x and y axis
  theme_classic()+
  coord_fixed(3)
  #coord_equal() #make the grid squares and independent of number of motifs analyzed
}

ggsave(output_tsv, width=ceiling(nchar(input_sequence)/4)+10, height = ceiling(length(y_axis_labels))+10, limitsize = FALSE)


library(scoringutils)
library(covidHubUtils)
library(dplyr)
library(data.table)
library(tidyr)
library(lubridate)
library(here)
library(readr)
source(here("code", "config_utils", "get_hub_config.R"))
data_types <- get_hub_config("target_variables")

## only evaluate if the last 4 weeks hae been submitted
restrict_weeks <- 4

suppressWarnings(dir.create(here::here("evaluation")))

score_models <- function(file, data, report_date, restrict_weeks) {
    last_forecast_date <- report_date - 7

    score_data <- data[forecast_date <= last_forecast_date &
        target_end_date <= report_date]

    ## for overall, if more than 1 location exists, filter to have at least half
    ## of them
    overall_df <- score_data %>%
        group_by(model, target_variable) %>%
        mutate(n = length(unique(location))) %>%
        ungroup() %>%
        mutate(nall = length(unique(location))) %>%
        filter(n >= nall / 2) %>%
        select(-n, -nall) %>%
        mutate(location = "Overall")

    df <- data %>%
        bind_rows(overall_df)

    coverage <- eval_forecasts(
        df %>% filter(type != "point"),
      summarise_by = c("model", "target_variable", "range", "horizon",
                       "location"),
        compute_relative_skill = FALSE,
    ) %>%
        dplyr::filter(range %in% c(50, 95)) %>%
      dplyr::select(model, target_variable, horizon, location, coverage,
                    range) %>%
        tidyr::pivot_wider(
            names_from = range, values_from = coverage,
            names_prefix = "cov_"
        )

    ## number of forecasts
    num_fc <- df %>%
        dplyr::filter(type == "point", !is.na(true_value)) %>%
        dplyr::group_by(model, target_variable, horizon, location) %>%
        dplyr::summarise(n = n(), .groups = "drop")

    ## mean absolute error of point forecast
    mae <- df %>%
        dplyr::filter(type == "point", !is.na(true_value)) %>%
        mutate(ae = abs(prediction - true_value)) %>%
        group_by(model, target_variable, location, horizon) %>%
        summarise(mae = mean(ae), .groups = "drop")

    ## continuous weeks of submission
    cont_weeks <- df %>%
        filter(!is.na(model)) %>%
        group_by(forecast_date, model, location, target_variable, horizon) %>%
        summarise(present = 1, .groups = "drop") %>%
        complete(model, location, target_variable, horizon, forecast_date) %>%
        group_by(model, location, target_variable, horizon) %>%
        mutate(continuous_weeks = cumsum(rev(present))) %>%
        filter(!is.na(continuous_weeks)) %>%
        summarise(continuous_weeks = max(continuous_weeks), .groups = "drop")

    table <-
        eval_forecasts(df %>% dplyr::filter(type != "point"),
            summarise_by = c(
                "model", "target_variable",
                "horizon", "location"
            ),
            compute_relative_skill = TRUE
        ) %>%
        dplyr::left_join(coverage, by = c(
            "model", "target_variable", "horizon",
            "location"
        )) %>%
        dplyr::right_join(mae, by = c(
            "model", "target_variable", "horizon",
            "location"
        )) %>%
        dplyr::left_join(num_fc, by = c(
            "model", "target_variable", "horizon",
            "location"
        )) %>%
        dplyr::left_join(cont_weeks, by = c(
            "model", "target_variable", "horizon",
            "location"
        )) %>%
      replace_na(list(continuous_weeks = 0))

    write_csv(table, file)
}

## load forecasts --------------------------------------------------------------
forecasts <- load_forecasts(source = "local_hub_repo",
                            hub_repo_path = here(),
                            hub = "ECDC")
setDT(forecasts)
## set forecast date to corresponding submision date
forecasts[, forecast_date :=
              ceiling_date(forecast_date, "week", week_start = 2) - 1]
forecasts <- forecasts[forecast_date >= "2021-03-08"]
setnames(forecasts, old = c("value"), new = c("prediction"))

## load truth data -------------------------------------------------------------
raw_truth <- load_truth(truth_source = "JHU",
                        target_variable = data_types,
                        hub = "ECDC")
# get anomalies
anomalies <- read_csv(here("data-truth", "anomalies", "anomalies.csv"))
truth <- anti_join(raw_truth, anomalies)

setDT(truth)
truth[, model := NULL]
setnames(truth, old = c("value"),
         new = c("true_value"))

data <- scoringutils::merge_pred_and_obs(forecasts, truth,
                                         join = "full")

latest_date <- today()
wday(latest_date) <- get_hub_config("forecast_week_day")

## can modify manually if wanting to re-run past evaluation
re_run <- FALSE
if (re_run) {
  start_date <- as.Date("2021-03-08") + 4 * 7
} else {
  start_date <- latest_date
}
report_dates <- seq(start_date, latest_date, by = "week")

for (chr_report_date in as.character(report_dates)) {
  report_date <- as.Date(chr_report_date)
  filename <-
    here::here("evaluation", paste0("evaluation-", report_date, ".csv"))
  score_models(filename, data, report_date, restrict_weeks)
}


# Code for eBird migration project, to prepare eBird species data for analysis
# developed by S. Supp and L. Graham for new analysis combining eBird data with remotely sensed environment

# DISCLAIMER: Code is under development
# 17 July 2019

# Inputs: Downloaded eBird dataset for each species 2006-2018

# Outputs: Species dataset with columns for SCIENTIFIC NAME, COMMON NAME, LATITUDE, LONGITUDE,
#      OBSERVATION DATE (change to Year and Julian Day of Year columns), TIME OBSERVATIONS STARTED,
#      OBSERVER ID, PROTOCOL TYPE, PROJECT CODE, DURATION MINUTES (previously was hours),
#      EFFORT DISTANCE KM, EFFORT AREA HA, NUMBER OBSERVERS

# Import libraries

library(auk)
library(tidyverse)
library(lubridate)

# CALLIOPE HUMMINGBIRD
dat <- auk_ebd("data/ebd_calhum_200601_201812_relFeb-2019.txt") %>%
  auk_protocol(c("Stationary", "Traveling", "Incidental")) %>%
  auk_date(c("2008-01-01", "2018-12-31")) %>%
  auk_filter(file = "data/calhum.txt", overwrite=TRUE) %>%
  # unique=FALSE ensures that all records are brought in, not just one from each group identifier
  read_ebd(unique=FALSE) %>%
  # select the columns that will be used
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
  # Reassigns Group records to Sampling Event records, so we may next account for discrepancies in recording location among group members.
  mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>%
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  # check for discrepancies in lat and lon recording, and calculate the mean value
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE) %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
           day = yday(observation_date)) #TODO: Are times in eBird relative to the location, or converted already into UTC?
write_csv(dat, path = "data/calhum.csv")

day_summary <- dat %>% group_by(observation_date) %>%
  summarise(count = n())

ggplot(day_summary, aes(x = observation_date, y = count)) +
  geom_line() + ggtitle("Calliope Hummingbird")

# BROAD TAILED HUMMINGBIRD
dat <- auk_ebd("data/ebd_brthum_200601_201812_relFeb-2019.txt") %>%
  auk_protocol(c("Stationary", "Traveling", "Incidental")) %>%
  auk_date(c("2008-01-01", "2018-12-31")) %>%
  auk_filter(file = "data/brthum.txt", overwrite=TRUE) %>%
  read_ebd(unique=FALSE) %>%
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
  mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>%
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE) %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
         day = yday(observation_date))
write_csv(dat, path = "data/brthum.csv")

day_summary <- dat %>% group_by(observation_date) %>%
  summarise(count = n())

ggplot(day_summary, aes(x = observation_date, y = count)) +
  geom_line() + ggtitle("Broad-tailed Hummingbird")

# RUFOUS HUMMINGBIRD
dat <- auk_ebd("data/ebd_rufhum_200601_201812_relFeb-2019.txt") %>%
  auk_protocol(c("Stationary", "Traveling", "Incidental")) %>%
  auk_date(c("2008-01-01", "2018-12-31")) %>%
  auk_filter(file = "data/rufhum.txt", overwrite=TRUE) %>%
  read_ebd(unique=FALSE) %>%
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>% #TODO: Check that this accomplishes what I want? For all records which are part of a groupID, the groupID is assigned to the sampling event ID #FIXME: I tested this on a smaller version of the dataframe and it seems to work fine. Is there a data issue?
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE) %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
         day = yday(observation_date))
write_csv(dat, path = "data/rufhum.csv")

day_summary <- dat %>% group_by(observation_date) %>%
  summarise(count = n())

ggplot(day_summary, aes(x = observation_date, y = count)) +
  geom_line() + ggtitle("Rufous Hummingbird")

# BLACK CHINNED HUMMINGBIRD
dat <- auk_ebd("data/ebd_bkchum_200601_201812_relFeb-2019.txt") %>%
  auk_protocol(c("Stationary", "Traveling", "Incidental")) %>%
  auk_date(c("2008-01-01", "2018-12-31")) %>%
  auk_filter(file = "data/bkchum.txt", overwrite=TRUE) %>%
  read_ebd(unique=FALSE) %>%
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
  mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>%
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE) %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
         day = yday(observation_date))
write_csv(dat, path = "data/bkchum.csv")

day_summary <- dat %>% group_by(observation_date) %>%
  summarise(count = n())

ggplot(day_summary, aes(x = observation_date, y = count)) +
  geom_line() + ggtitle("Black-chinned Hummingbird")

# RUBY THROATED HUMMINGBIRD
dat <- auk_ebd("data/ebd_rthhum_200601_201812_relFeb-2019.txt") %>%
  auk_protocol(c("Stationary", "Traveling", "Incidental")) %>%
  auk_date(c("2008-01-01", "2018-12-31")) %>%
  auk_filter(file = "data/rthhum.txt", overwrite=TRUE) %>%
  read_ebd(unique=FALSE) %>%
  select(common_name, scientific_name, latitude, longitude, observation_date,
         time_observations_started, observer_id, protocol_type, project_code,
         duration_minutes, effort_distance_km, effort_area_ha, number_observers,
         sampling_event_identifier, group_identifier) %>%
  mutate(sampling_event_identifier =
           ifelse(is.na(group_identifier), sampling_event_identifier, group_identifier)) %>%
  group_by(common_name, observation_date, sampling_event_identifier) %>%
  mutate(latitude2 = mean(latitude), longitude2 = mean(longitude),
         latdiff = latitude-latitude2, londiff = longitude-longitude2) %>%
  distinct(sampling_event_identifier, .keep_all = TRUE)  %>%
  mutate(year = year(observation_date),
         month = month(observation_date),
         day = yday(observation_date))
write_csv(dat, path = "data/rthhum.csv")

day_summary <- dat %>% group_by(observation_date) %>%
  summarise(count = n())

ggplot(day_summary, aes(x = observation_date, y = count)) +
  geom_line() + ggtitle("Ruby-throated Hummingbird")

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

#hbird = read_tsv("data/ebd_calhum_200601_201812_relFeb-2019/ebd_calhum_200601_201812_relFeb-2019.txt")


#' Generate coloc dataset from vcf files
#'
#' @param vcf1 VCF object or path to vcf file
#' @param vcf2 VCF object or path to vcf file
#' @param chrompos Character of chr:pos1-pos2
#'
#' @export
#' @return List of datasets to feed into coloc
gwasvcf_to_coloc <- function(vcf1, vcf2, chrompos)
{
	## TODO: binary or quantitative traits
	## TODO: multiallelic variants

	o <- gwasvcf::vcflist_overlaps(list(vcf1, vcf2), chrompos)
	vcf1 <- o[[1]]
	vcf2 <- o[[2]]

	if(length(vcf1) == 0)
	{
		message("No overlaps in vcf1")
		return(NULL)
	}
	if(length(vcf2) == 0)
	{
		message("No overlaps in vcf2")
		return(NULL)
	}

	stopifnot(length(vcf1) == length(vcf2))
	tab1 <- vcf1 %>% gwasvcf::vcf_to_granges() %>% dplyr::as_tibble()
	tab2 <- vcf2 %>% gwasvcf::vcf_to_granges() %>% dplyr::as_tibble()
	index <- as.character(tab1$REF) == as.character(tab2$REF) &
			as.character(tab1$ALT) == as.character(tab2$ALT) &
			as.character(tab1$seqnames) == as.character(tab2$seqnames) &
			tab1$start == tab2$start
	stopifnot(sum(index) > 0)

	type1 <- ifelse(VariantAnnotation::header(vcf1) %>%
		VariantAnnotation::meta() %>%
		{.[["SAMPLE"]][["StudyType"]]} == "Continuous", "quant", "cc")

	type2 <- ifelse(VariantAnnotation::header(vcf2) %>%
		VariantAnnotation::meta() %>%
		{.[["SAMPLE"]][["StudyType"]]} == "Continuous", "quant", "cc")

	out1 <- tab1[index,] %>% {list(pvalues = 10^-.$LP, N = .$SS, MAF = .$AF, beta = .$ES, varbeta = .$SE^2, type = type1, snp = names(vcf2)[index], z = .$ES / .$SE, chr = .$seqnames, pos = .$start, id = VariantAnnotation::samples(VariantAnnotation::header(vcf1))[1])}
	out2 <- tab2[index,] %>% {list(pvalues = 10^-.$LP, N = .$SS, MAF = .$AF, beta = .$ES, varbeta = .$SE^2, type = type2, snp = names(vcf2)[index], z = .$ES / .$SE, chr = .$seqnames, pos = .$start, id = VariantAnnotation::samples(VariantAnnotation::header(vcf2))[1])}

	if(type1 == "cc")
	{
		out1$s <- mean(tab1$NC / tab1$SS, na.rm=TRUE)
	} else

	if(type2 == "cc")
	{
		out2$s <- mean(tab1$NC / tab1$SS, na.rm=TRUE)
	}

	return(list(dataset1=out1, dataset2=out2))
}

#' Generate coloc dataset from the IEU GWAS database
#'
#' @param id1 ID for trait 1
#' @param id2 ID for trait 2
#' @param chrompos Character of chr:pos1-pos2
#' @param type1 Provide "cc" or "quant" to override automatic lookup of trait type for trait 1
#' @param type2 Provide "cc" or "quant" to override automatic lookup of trait type for trait 2
#'
#' @export
#' @return List of datasets to feed into coloc
ieugwasr_to_coloc <- function(id1, id2, chrompos, type1=NULL, type2=NULL)
{
	tab1 <- ieugwasr::associations(id=id1, variants=chrompos) %>% subset(., !duplicated(rsid))
	tab2 <- ieugwasr::associations(id=id2, variants=chrompos) %>% subset(., !duplicated(rsid))
	commonsnps <- tab1$rsid[tab1$rsid %in% tab2$rsid]
	tab1 <- tab1[tab1$rsid %in% commonsnps, ] %>% dplyr::arrange(rsid)
	tab2 <- tab2[tab2$rsid %in% commonsnps, ] %>% dplyr::arrange(rsid)
	stopifnot(all(tab1$rsid == tab2$rsid))

	index <- as.character(tab1$ea) == as.character(tab2$ea) &
			as.character(tab1$nea) == as.character(tab2$nea) &
			as.character(tab1$rsid) == as.character(tab2$rsid) &
			tab1$position == tab2$position
	stopifnot(sum(index) > 0)
	tab1$eaf <- as.numeric(tab1$eaf)
	tab2$eaf <- as.numeric(tab2$eaf)
	tab1$eaf[which(tab1$eaf > 0.5)] <- 1 - tab1$eaf[which(tab1$eaf > 0.5)]
	tab2$eaf[which(tab2$eaf > 0.5)] <- 1 - tab2$eaf[which(tab2$eaf > 0.5)]

	info1 <- ieugwasr::gwasinfo(id1)
	type1 <- get_type(info1, type1)
	info2 <- ieugwasr::gwasinfo(id2)
	type2 <- get_type(info2, type2)

	tab1 <- tab1[index,] %>% {list(pvalues = .$p, N = .$n, MAF = .$eaf, beta = .$beta, varbeta = .$se^2, type = type1, snp = .$rsid, z = .$beta / .$se, chr = .$chr, pos = .$position, id = id1)}
	tab2 <- tab2[index,] %>% {list(pvalues = .$p, N = .$n, MAF = .$eaf, beta = .$beta, varbeta = .$se^2, type = type2, snp = .$rsid, z = .$beta / .$se, chr = .$chr, pos = .$position, id = id2)}

	if(type1 == "cc")
	{
		tab1$s <- info1$ncase / info1$sample_size
	} else

	if(type2 == "cc")
	{
		tab2$s <- info2$ncase / info2$sample_size
	}

	return(list(dataset1=tab1, dataset2=tab2))
}

get_type <- function(info, typex)
{
	if(!is.null(typex))
	{
		stopifnot(! typex %in% c("cc", "quant"))
		return(typex)
	} else if(is.na(info$unit)) {
		message("Type information not available for ", info$id, ". Assuming 'quant' but override using 'type' arguments.")
		return("quant")
	} else {
		return(ifelse(info$unit %in% c("logOR", "log odds"), "cc", "quant"))
	}
}


############
# convert_wfgrids2binary.r
#
# the water footprint data are in arc binary grid format
# using the gdal library in my LDS c code does not recognize the file type for some reason
#
# so this script converts the arc grids to simple, single band binary files, with an easy to read header file
# then the LDS code reads in the simple binary files
#
# the input water footprint data are 5 arcmin resolution, 4320 columns X 1668 rows
# WGS84 lat-lon projection
# with nodata values of -3.40282e+38
# there are 4 variables: blue, green, gray, and total water footprint
#	in average annual mm across each entire grid cell area (1996-2005 average)
# BUT:
# the water footprint data are also off in their defined extent:
#	0.5 arcmin in east-west
#	0.3 armin in north-south
#
# the output rasters are 5 arcmin resolution, extended to the full globe (4320 columns X 2160 rows)
#	with the data shifted using nearest neighbor resampling to align with 5 arcmin boundaries
#	same WGS84 projection
#	the nodata values have been set to -9999
#
# outputs are r raster format:
#	###.gri is the binary file
#	###.grd is the text header file
#
# this script takes ~43 minutes on my workstation

cat("\nStarted convert_wfgrids2binary.r",date(), "\n")

library(raster)

PROJ4_STRING = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"
WF_EXTENT = extent(-180.0, 180.0, -55.916666666667, 83.083333333333)
FULLGLOBE = extent(-180.0,180.0,-90.0,90.0)
NODATA = -9999

# change basedir to point to your instance of Report47-App-IV-RasterMaps/
basedir = "/Users/ladmin/repos/stash/lds/indata/WaterFootprint/Report47-App-IV-RasterMaps/"
hdrtag = "/hdr.adf"
outtag = ".grd"

NUM_VARS = 4
var_names = c("wfbl_mmyr", "wfgn_mmyr", "wfgy_mmyr", "wftot_mmyr")

NUM_CROPS = 18
crop_names = c("Barley", "Cassava", "Coconuts", "Coffee", "Cotton", "Groundnut", "Maize", "Millet", "Oilpalm", "Olives", "Potatoes", "Rapeseed", "Rice", "Sorghum", "Soybean", "Sugarcane", "Sunflower", "Wheat")

for(crop_index in 1:NUM_CROPS) {
	cropdir = paste(basedir, crop_names[crop_index], "/", sep="")

	for(var_index in 1:NUM_VARS) {
		fname = paste(cropdir, var_names[var_index], hdrtag, sep="")
		ofn = paste(cropdir, var_names[var_index], outtag, sep="")

		# create the template for resampling in order to shift the input boundaries
		template = raster(WF_EXTENT, nrows = 1668, ncols = 4320)
		projection(template) <- PROJ4_STRING

		# read in the data, resample it, extend it to the globe, reset the nodata value in the output data
		wf_in = raster(fname)
		wf_rs = resample(wf_in, template, method = "ngb")
		wf_full = extend(wf_rs, FULLGLOBE)
		nainds = Which(is.na(wf_full), cells=TRUE)
		wf_out = wf_full
		wf_out[nainds] = NODATA

		# write the binary raster file
		writeRaster(wf_out, filename=ofn, datatype = "FLT4S", overwrite=TRUE, NAflag = NODATA)
	} # end loop over the variables
} # end loop over the crops

cat("\nFinished convert_wfgrids2binary.r",date(), "\n")