  figure.landings.timeseries = function( yearmax, outdir=NULL, outfile=NULL, outfile2=NULL, type="line" ) {
    #browser()
    #variables = c("effort", "landings", "cpue")
    #for (v in variables) {
      #Extract data for the raster creation
      #M = K[, c("yr", "lon", "lat", v)]
      #M = M[is.finite(M[,v] *M[,"lon"] *M[,"lat"]),]

    regions = c("cfanorth", "cfasouth", "cfa4x")
    l = NULL
    for (r in regions) {
      res = get.fishery.stats.by.region( Reg=r)
      print(r)
      print(res)
      l = cbind( l, res$landings  )
    }
    l = l / 1000

    l = as.data.frame( l )
    colnames(l) = regions
    rownames(l) = res$yr

    l = l[ which( as.numeric(rownames(l)) <= yearmax ), ]
    uyrs = as.numeric(rownames(l) )

    dir.create( outdir, recursive=T, showWarnings=F  )
    fn = file.path( outdir, paste(outfile,"pdf",sep="." ) )
    fn2 = file.path( outdir, paste(outfile2,"pdf",sep="." ) )

    pdf(file=fn, width=7, height=7, bg='white')
  # png( file=fn,units='in', width=7,height=7,pointsize=10, res=350,type='cairo')

    if (type=="bar") {
      cols = c("grey10", "grey40",  "grey80")
      reverse = c(3,2,1)
      formed.data = t( l[,c(3,2,1)] ) # re-order for plot
      formed.data[ is.na(formed.data) ] = 0
      barplot( formed.data, space=0, xlab="Year", ylab="Landings (t)", col=cols)
      legend(x=1, y=10000, c("N-ENS", "S-ENS", "4X"), fill=cols[reverse], bty="n")
    }
    if (type=="line") {
      pts = c(19, 22, 24)
      lns = c(1, 1, 1)
      cols = c("grey10", "grey10",  "grey20")
      yrange = range (l, na.rm=T)
      yrange[1] = 0
      xrange = range(uyrs)
      xrange[1] = xrange[1]
      xrange[2] = xrange[2]
      xlabels = seq(xrange[1] +1, xrange[2], 2)

      m=1; plot( uyrs, l[,m],  type="b", ylab="Landings (t)", xlab="Year", col=cols[m], lwd=4, lty=lns[m], pch=pts[m], xaxt="n", xlim=xrange, ylim=yrange)
      m=2; points(uyrs, l[,m], type="b", col=cols[m], lwd=3, lty=lns[m], pch=pts[m])
      m=3; points(uyrs, l[,m], type="b", col=cols[m], lwd=3, lty=lns[m], pch=pts[m])
      axis(1, at=xlabels, labels=FALSE)
      text(x=xlabels+1, y=par('usr')[3], labels=xlabels, srt=45, adj=c(1.5,1), xpd=TRUE)
      axis( 2 )
      legend(x=1980, y=8500, c("N-ENS", "S-ENS", "4X"), bty="n", lty=lns, lwd=2, pch=pts, col=cols, cex=1.2)

      dev.off()
      pdf(file=fn2, width=7, height=7, bg='white')

      #png(file=fn2 ,units='in', width=7,height=7,pointsize=10, res=350,type='cairo')
      sm = l[, c(1, 3)]
      pts = c(19, 24)
      lns = c(1, 1)
      cols = c("grey10", "grey20")
      yrange = range (sm, na.rm=T)
      yrange[1] = 0
      xrange = range(uyrs)
      xrange[1] = xrange[1]
      xrange[2] = xrange[2]
      xlabels = seq(xrange[1]+1, xrange[2], 2)

      m=1; plot( uyrs, sm[,m],  type="b", ylab="Landings (t)", xlab="Year", col=cols[m], lwd=4, lty=lns[m], pch=pts[m], xaxt="n", xlim=xrange, ylim=yrange)
      m=2; points(uyrs, sm[,m], type="b", col=cols[m], lwd=3, lty=lns[m], pch=pts[m])
      axis( 1, at=xlabels, labels=FALSE )
      text(x=xlabels+1, y=par('usr')[3], labels=xlabels, srt=45, adj=c(1.5,1), xpd=TRUE)
      axis( 2 )
      legend(x=1985, y=1200, c("N-ENS", "4X"), bty="n", lty=lns, lwd=2, pch=pts, col=cols, cex=1.2 )
    }

   dev.off()
    #table.view( l )
   return( fn )
  }


## prog ini 1
# read data from ASCII file and do some graphical initialisations
# you have to do this after every new SMS run
#################################################################

stom<-Read.stomach.data()

a<-droplevels(subset(stom,Predator %in% c('Grey seal','H. porpoise')))

b<-tapply(a$stom.input,list(Predator=a$Predator,Year=a$Year,PredatorSize=a$Predator.length,Prey=a$Prey,
   PreySize=a$Prey.length.class,Quarter=a$Quarter.no),sum)
ftable(round(b*100,0.01))


write_dat<-function(data=test,data_file="test.dat"){
 options(list(scipen=6))
 T1<-noquote("# General Parameters")
  write(data$T1,paste(data_file))
  ##Start YEAR
  write(data$SY,paste(data_file),append = T)
  ##END YEAR
  write(data$EY,paste(data_file),append = T)
  ## First Age class
  write(data$FAC,paste(data_file),append = T)
  ##Last Age Class
  write(data$LAC,paste(data_file),append = T)
  ## numbers of length intervals
   write("41",paste(data_file),append = T)
  ##Length bin
   write(c(10:50),paste(data_file),append = T)
  ## 10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47  48  49  50
 #	=======================================

  ## Number of Fisheries
  write(data$NF,paste(data_file),append = T)

 T2<-noquote("#Fshry name")
   write(T2,paste(data_file),append = T)
   write(data$F_NAME,paste(data_file),append = T)

 T3<-noquote("# Catch Biomass:")
  write(T3,paste(data_file),append = T)
  write.table(t(data$CATCH$TONS/1000),paste(data_file),col.names=F,row.names=F,append = T)

 T4<-noquote("#Yr specific cv on catch:")
  write(T4,paste(data_file),append = T)
  write.table(t(data$Catch_CV),paste(data_file),col.names=F,row.names=F,append = T)

 T5<- noquote("# Number Years With Fishery Age Data:")
  write(T5,paste(data_file),append = T)
  write.table(length(data$F_NAGE$YEAR),paste(data_file),col.names=F,row.names=F,append = T)

 T25<- noquote("# Number Years With Fishery Length Data:")
  write(T25,paste(data_file),append = T)
  write.table(0,paste(data_file),col.names=F,row.names=F,append = T)

 T6<-noquote("# Fishery 1 years")
  write(T6,paste(data_file),append = T)
  write.table(t(data$F_NAGE$YEAR),paste(data_file),col.names=F,row.names=F,append = T)

 T7<-noquote("# Fishery 1 multinomial sample size")
  write(T7,paste(data_file),append = T)
  write.table(t(data$F_MN_SIZE),paste(data_file),col.names=F,row.names=F,append = T)

 T8<- noquote("# Fishery 1 numbers at age proportion")
  write(T8,paste(data_file),append = T)
  write.table(round(data$F_NAGE[,2:15],3),paste(data_file),,col.names=F,row.names=F,append = T)

 T9<- noquote("# Fishery 1 Weight at age 1978-2011")
  write(T9,paste(data_file),append = T)
  write.table(round(data$F_WEIGHT$AGE_WEIGHT[,2:15]),paste(data_file),col.names=F,row.names=F,append = T)

 T10<- noquote("#  Number of Surveys")
  write(T10,paste(data_file),append = T)
  write(data$NS,paste(data_file),append = T)

 T11<- noquote("#	Name of Surveys")
  write(T11,paste(data_file),append = T)
   write(data$S_name,paste(data_file),append = T)
   write(length(data$S_BIO$YEAR),paste(data_file),append = T)

 T12<- noquote("# Survey 1 Years of survey biomass")
  write(T12,paste(data_file),append = T)
  write.table(t(matrix(data$S_BIO$YEAR)),paste(data_file),col.names=F,row.names=F,append = T)

 T13<- noquote("# Survey 1 Number of years")
  write(T13,paste(data_file),append = T)
  write(length(data$S_BIO$YEAR),paste(data_file),append = T)

 T14<- noquote("# Survey 1 Biomass values")
  write(T14,paste(data_file),append = T)
  write.table(t(matrix(round(data$S_BIO$BIO/1000,3))),paste(data_file),col.names=F,row.names=F,append = T)

 T15<- noquote("# Survey 1 Biomass stdev")
  write(T15,paste(data_file),append = T)
  write.table(t(matrix(round(data$S_BIO$B_STDEV/1000,3))),paste(data_file),col.names=F,row.names=F,append = T)

 T16<- noquote("# Number of Surveys with ages")
  write(T16,paste(data_file),append = T)
   write(length(data$S_NAGE$YEAR),paste(data_file),append = T)

  T161<- noquote("# Number of Surveys with lengths")
  write(T161,paste(data_file),append = T)
   write(0,paste(data_file),append = T)

 T17<- noquote("# Survey 1 Years")
  write(T17,paste(data_file),append = T)
  write.table(t(matrix(data$S_NAGE$YEAR)),paste(data_file),col.names=F,row.names=F,append = T)

 T18<- noquote("# Survey 1 Multinomial sample size")
  write(T18,paste(data_file),append = T)
  write.table(t(matrix(data$S_MN_SIZE)),paste(data_file),col.names=F,row.names=F,append = T)

 T19<-noquote("# Survey 1 numbers at age proportions")
  write(T19,paste(data_file),append = T)
  write.table(round(data$S_NAGE[,2:15],3),paste(data_file),col.names=F,row.names=F,append = T)

 T20<- noquote("# Survey 1 weight at age")
  write(T20,paste(data_file),append = T)
  write.table(round(data$S_WEIGHT$AGE_WEIGHT[,2:15]),paste(data_file),col.names=F,row.names=F,append = T)

 T21<-noquote("# Population weight at Age")
  write(T21,paste(data_file),append = T)
  write.table(t(matrix(round(data$PP_WEIGHT_AGE,3))),paste(data_file),col.names=F,row.names=F,append = T)

 T22<-noquote("# Maturity at Age ")
  write(T22,paste(data_file),append = T)
  write.table(data$GMat*0.5,paste(data_file),col.names=F,row.names=F,append = T)

 T23<-noquote("# Month of Spawning")
  write(T23,paste(data_file),append = T)
  write(data$MSPWN,paste(data_file),append = T)

  T24<-noquote("# Ageing error")
  write(T24,paste(data_file),append = T)
  write.table(data$AERR,paste(data_file),col.names=F,row.names=F,append = T)
  write(" ",paste(data_file),append = T)
  write(" ",paste(data_file),append = T)
 }


#' Arithmetic Operators
#'
#' Some binary arithmetic operations for shaqs.  All operations are
#' vector-shaq or shaq-vector, but not shaq-shaq.  See details section for more
#' information.
#'
#' @details
#' For binary operations involving two shaqs, they must be distributed
#' \emph{identically}.
#'
#' @section Communication:
#' Each operation is completely local.
#'
#' @param e1,e2
#' A shaq or a numeric vector.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' y = ranshaq(runif, 10, 3)
#'
#' x + y
#' x / 2
#' y + 1
#'
#' finalize()
#' }
#'
#' @name arithmetic
#' @rdname arithmetic
NULL

bounds.check = function(shaq, vec)
{
  if (length(vec) != 1)
    comm.stop("invalid shaq-vector operation: vector must be length 1")
}

shaqshaq.check = function(s1, s2)
{
  if (nrow(s1) != nrow(s1)  ||  ncol(s1) != ncol(s2))
    stop("non-conformable arrays")

  if (nrow(Data(s1)) != nrow(Data(s2))  ||  ncol(Data(s1)) != ncol(Data(s2)))
    stop("shaqs not distributed identically")
}

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) + Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) + e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    e2 + e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) - Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) - e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    bounds.check(e2, e1)

    DATA(e2) = e1 - Data(e2)
    e2
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) * Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) * e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    e2 * e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="shaq", e2="shaq"),
  function(e1, e2)
  {
    shaqshaq.check(e1, e2)

    DATA(e1) = Data(e1) / Data(e2)
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="shaq", e2="numeric"),
  function(e1, e2)
  {
    bounds.check(e1, e2)

    DATA(e1) = Data(e1) / e2
    e1
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="numeric", e2="shaq"),
  function(e1, e2)
  {
    bounds.check(e2, e1)

    DATA(e2) = e1 / Data(e2)
    e2
  }
)


#source('C:/Users/parkinso/indus_ix/input_data_scripts/water_resources_extreme.r')

require(rgeos)
require(rgdal)
require(raster)
require(dplyr)
require(rasterVis)
require(maptools)
require(ncdf4)
require(igraph)
require(RColorBrewer)
require(reshape)
require(ggmap)
memory.limit(size=1e9)

# ISWEL folder for data
setwd('P:/is-wel/indus/message_indus')

# basins to check
basin = c('Indus')

# Define continental tiles from hydroBASINS
cnt_list = c('af', 'as', 'au', 'ca', 'eu', 'na', 'sa')
wkd_dir1 = paste( getwd(), "input/hydrosheds/elevation/", sep = '/' )
wkd_dir2 = paste( getwd(), "input/hydrosheds/flow_accumulation/", sep = '/' )
wkd_dir3 = paste( getwd(), "input/hydrosheds/river_network/", sep = '/' )
wkd_dir4 = paste( getwd(), "input/hydrosheds/flow_direction/", sep = '/' )
cnt_ext = lapply( cnt_list, function(cnt){ extent( raster( paste ( paste( wkd_dir1, c(paste(cnt,'_dem_15s_grid/',paste(cnt,'_dem_15s/',sep=''),paste(cnt, '_dem_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) ) ) } )
names(cnt_ext) = cnt_list

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))

# Create buffered basin polygon for gridded data along the border
buff.sp = gBuffer( basin.sp, width=0.1 )
buff2.sp = gBuffer( basin.sp, width = 10 )
proj4string(basin.sp) = proj4string(basin.spdf)
proj4string(buff.sp) = proj4string(basin.spdf)
proj4string(buff2.sp) = proj4string(basin.spdf)

# Check which hydrobasins tiles to include for this basin
tiles_incl = sapply( names(cnt_ext), function(cnt){
	polyg = as( cnt_ext[[cnt]] , 'SpatialPolygons' )
	proj4string(polyg) = proj4string(basin.sp)
	if( unlist( gIntersects( polyg, basin.sp ) ) ){ return( cnt ) }
	} )
cnt = unlist( tiles_incl[!is.null(tiles_incl)] )

# river
#trv = readOGR('P:/ene.general/Water/global_basin_modeling/basin_delineation','indus_rivers',verbose=FALSE)

# Add river names
if( basin == 'Indus' ){ basin.spdf@data$river = basin.spdf@data$REGION }

# Get the climate model and scenario names
fls = list.files( 'input/hydroclimate_input')
climate_models = unique( unlist( strsplit( fls, '_' ) )[seq(3,4*length( fls ),by=4 ) ] )
climate_scenarios = unique( unlist( strsplit( fls, '_' ) )[seq(4,4*length( fls ),by=4 ) ] )
climate_scenarios = unique( unlist( strsplit( climate_scenarios, '[.]' ) )[ seq(1,2*length(climate_scenarios),by=2) ] )

# create stack of climate model -scenario combinations for runoff
ghm.list = lapply( climate_models, function( cc ){
	r1 = lapply( climate_scenarios, function( ss ){
		if( file.exists( paste0( 'input/hydroclimate_input/extremerunoff_metersperday_',cc,'_', ss, '.tif' ) ) ){
			r = stack( paste0( 'input/hydroclimate_input/extremerunoff_metersperday_',cc,'_', ss, '.tif' ) )
			names(r) = c( sapply( c(2010,2020,2030,2040,2050,2060), function(yy){ return( paste( yy, seq(1,12,by=1), sep='.') ) } ) )
			return(r)
			}
		} )
	names(r1) = climate_scenarios
	return(r1)
	} )
names(ghm.list) = climate_models

# create stack of climate model -scenario combinations - groundwater recharge
gwr.list = lapply( climate_models, function( cc ){
	r1 = lapply( climate_scenarios, function( ss ){
		if( file.exists( paste0( 'input/hydroclimate_input/recharge_metersperday_',cc,'_', ss, '.tif' ) ) ){
			r = stack( paste0( 'input/hydroclimate_input/recharge_metersperday_',cc,'_', ss, '.tif' ) )
			names(r) = c( sapply( c(2010,2020,2030,2040,2050,2060), function(yy){ return( paste( yy, seq(1,12,by=1), sep='.') ) } ) )
			return(r)
			}
		} )
	names(r1) = climate_scenarios
	return(r1)
	} )
names(gwr.list) = climate_models

# import the elevation raster and crop to the basin outline
elevation.raster = raster( paste( paste( wkd_dir1, c(paste(cnt,'_dem_15s_grid/',paste(cnt,'_dem_15s/',sep=''),paste(cnt, '_dem_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) )
elevation.raster = mask( x = crop( elevation.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( elevation.raster, extent( basin.sp ), snap="out") ) )

# Cells above max elevation
elevation_max.raster = elevation.raster
elevation_max.raster[ elevation_max.raster < 3500 ] = NA
elevation_max.raster[ !is.na(elevation_max.raster) ] = 1

# Flow accumulation raster
flow_accumulation.raster = raster( paste( paste( wkd_dir2, c(paste(cnt,'_acc_15s_grid/',paste(cnt,'_acc_15s/',sep=''),paste(cnt, '_acc_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) )
flow_accumulation.raster = mask( x = crop( flow_accumulation.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( flow_accumulation.raster, extent( basin.sp ), snap="out") ) )

# Flow direction raster
flow_direction.raster = raster( paste( paste( wkd_dir4, c(paste(cnt,'_dir_15s_grid/',paste(cnt,'_dir_15s/',sep=''),paste(cnt, '_dir_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) )
flow_direction.raster = mask( x = crop( flow_direction.raster, extent( basin.sp ), snap = "out" ), mask = rasterize(	basin.sp, crop( flow_direction.raster, extent( basin.sp ), snap="out") ) )

# Harmonize
w1 = flow_accumulation.raster
w1[] = flow_direction.raster[]
flow_direction.raster = w1
w1 = flow_accumulation.raster
w1[] = elevation.raster[]
elevation.raster = w1
rm(w1)

# Get PIDs for raster cells
tmp = basin.spdf[,'PID']
basin.raster = rasterize( tmp, flow_accumulation.raster, 'PID' )
basin.raster[ which( !( basin.raster[] > 0 ) ) ] = NA

# Compute elevation change and flow direction

# Get the sub-bcu land units and elevation at these unit -
ae = area( flow_accumulation.raster )
ae[ which( !( 1:length(ae[]) %in% which(!is.na(flow_accumulation.raster[])))) ]=NA

# limit land units to cells with at least 5 km2 of upstream area
lu = which( !is.na( flow_accumulation.raster[] ) &
			( flow_accumulation.raster[] > 0 ) &
			( flow_accumulation.raster[] >= round( 5 / mean(ae[],na.rm=TRUE) ) ) )

# harmonize other data to land units
fa = c( flow_accumulation.raster[ lu ] )
fd = c( flow_direction.raster[ lu ] )
hi = c( elevation.raster[ lu ] )
ar = c( ae[ lu ] )

# Get adjacent cells

# matrix for defining the adjacent cells to look at in the flow direction raster
around = matrix( c(	1, 1, 1,
					1, 0, 1,
					1, 1, 1 ), ncol = 3, byrow=TRUE )

# flow direction matrix
hmat = c( 32, 64, 128,
		  16, 0, 1,
		  8, 4, 2 )

# get the flow direction in the adjacent cells
adj = data.frame( adjacent( flow_direction.raster, cell = lu, directions=around, sorted=TRUE, include = TRUE ) )
adj = adj[ which( adj$from %in% lu ),  ]

# Use flow direction matrix to determine the direction of downstream
adj$hmat = unlist( lapply( 1:length(lu), function(iii){ return(hmat) } ) )
sd = match( lu, adj$from )
se = match( fd, adj$hmat )

# use the direction mapping to create a corresponding raster that contains the downstream cell id based on the flow direction map
tm = unlist(adj$to)
down = sapply( 1:length(lu), function( x ){ tm[ c( sd[x]+se[x] - 1 ) ] } )

# compute the elevation change
dh = hi - hi[ match( down, lu ) ]
dh[ dh < 0 ] = 0 # discard

# Get the spatial locations of the land units
xloc = xFromCell( flow_accumulation.raster, lu )
yloc = yFromCell( flow_accumulation.raster, lu )
locs = data.frame( x = xloc, y = yloc )

# Get the mapping to cells from the GHM at lower resolution
ghm_cell = ghm.list[[1]][[1]][[1]]
ghm_cell[] = 1:length(ghm_cell[])

# resample to match the land unit grid
ghm_cell = resample( ghm_cell, flow_accumulation.raster, method = 'ngb')
ghm_cell = ghm_cell[ lu ]

# Replace missing locations with nearest neighbour
if( length(which(is.na(ghm_cell))) > 0 )
	{

	pts = SpatialPoints( data.frame( xyFromCell( flow_accumulation.raster, lu[ which(is.na(ghm_cell)) ] ) ) )
	proj4string(pts) = proj4string(basin.sp)

	ghm_cell[ which(is.na(ghm_cell)) ] = unlist( lapply( 1:length(pts), function(ppp){

		basin.spdf@data$PID[ which.min(gDistance(pts[ppp],basin.spdf,byid=TRUE)) ]

		} ) )

	}

# Get the PID associated with each land unit - again use nearest neighbour when na encountered
basin.raster = resample( basin.raster, flow_accumulation.raster, method = 'ngb' )
basin_cell = basin.raster[ lu ]
if( length(which(is.na(basin_cell))) > 0 )
	{
	pts = SpatialPoints( data.frame( xyFromCell( flow_accumulation.raster, lu[ which(is.na(basin_cell)) ] ) ) )
	proj4string(pts) = proj4string(basin.sp)
	basin_cell[ which(is.na(basin_cell)) ] = unlist( lapply( 1:length(pts), function(ppp){ which.min(gDistance(pts[ppp],basin.spdf,byid=TRUE)) } ) )
	}
basin.raster[ lu ] = basin_cell

# use the downstream mapping to get the basin associated with the downstream cell
down_basin_cell = basin_cell[ match( down, lu ) ]

# re-collect the network data
nt.df = data.frame( xloc = xloc,
					yloc = yloc,
					cell = lu,
					downstream_cell = down,
					elevation = hi,
					elevation_change = dh,
					flow_accumulation = fa,
					ghm_cell = ghm_cell,
					pid = basin.spdf@data$PID[basin_cell],
					down_pid = basin.spdf@data$PID[down_basin_cell] )

# Estimate upstream area for converting runoff depth to discharge volume

# Check and calibration of the flow accumulation to reflect missing grid cell areas lost due to 5km2 upstream area simplification

# The estimated flow accumulation is calculated by routing the through the reduced netwok
# (i.e., cells in nt.df that are remaining after limiting upstream areas to 5km2)

act_acc = unlist( nt.df$flow_accumulation )
est_acc = rep( 1, length( nt.df$flow_accumulation ) ) # initilize
ntm.df = nt.df
while( nrow(ntm.df) > 0  )
	{

	# Get the most upstream cells and find immediate downstream cells
	cell_tot = nrow(ntm.df)
	cell_start = as.integer( unlist( ntm.df$cell[ which( !( ntm.df$cell %in% ntm.df$downstream_cell ) ) ] ) )
	ind_start = match( cell_start, nt.df$cell )
	cell_down = as.integer( unlist( nt.df$downstream_cell[ ind_start ] ) )
	ind_down = match( cell_down, nt.df$cell )

	# If there are downsteam cells
	if( length(ind_down) > 0 ){

		for( i in 1:length(cell_down) ){

			# if the downstream cell is not a sink
			if( !is.na(ind_down[i]) & ind_down[i] != ind_start[i] ){

				# add the accumulated cell area of the upstream cell to the accumulated downstream cell area
				est_acc[ ind_down[i] ] = est_acc[ ind_down[i] ] + act_acc[ ind_start[i] ]

				}

			}

		}

	# remove the most upstream cells
	ntm.df = ntm.df[ -1*which( ntm.df$cell %in% cell_start ), ]

	}

# the partial flow accumulation misses the area lost in 5km2 simplification
# use the actual flow ccumulation from hydrobasins to estimate the missing
nt.df$partial_flow_accumulation = act_acc - est_acc

# area of all land units
a = area(basin.raster)
a[which(!( 1:length(a[])%in% which(!is.na(basin.raster[]))))]=NA

# Scale the area of each cell to reflect the missng upstream area
nt.df$area = ( 1 + nt.df$partial_flow_accumulation ) * a[lu]
nt.df$area_og =  a[lu]

# exclusion zones from wind and solar analysis
ws_excl = raster('input/fraction_grid_cell_available_wind_solar.asc')

# Additionally - exlusion of areas where existing power plants are in use
# to avoid double counting hydropower potential already built and included in the model separately

# Asset-level data base compiled for input to MESSAGE in 'input_data_scripts/powerplants_historical_capacity.r'
ppl.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), paste( basin, 'power_plants', sep = '_' ), verbose = FALSE )
proj4string( ppl.spdf ) = proj4string( basin.raster )

# Distance to power plants of different sizes - currently breaking into group of less than and greater than 100 MW
basin_hydropower.raster = rasterize( ppl.spdf, field='MW', basin.raster, fun=sum )
basin_hydropower_lo.raster = basin_hydropower.raster
basin_hydropower_lo.raster[ basin_hydropower_lo.raster[] < 100 ] = 1
basin_hydropower_lo.raster[ basin_hydropower_lo.raster[] != 1 ] = NA
basin_hydropower_hi.raster = basin_hydropower.raster
basin_hydropower_hi.raster[ basin_hydropower_hi.raster[] >= 100 ] = 1
basin_hydropower_hi.raster[ basin_hydropower_hi.raster[] != 1 ] = NA
dist_hydro_lo.raster = basin_hydropower_lo.raster
dist_hydro_lo.raster[ dist_hydro_lo.raster > 0 ] = 1
dist_hydro_lo.raster=distance(dist_hydro_lo.raster)/1000
dist_hydro_hi.raster = basin_hydropower_hi.raster
dist_hydro_hi.raster[ dist_hydro_hi.raster > 0 ] = 1
dist_hydro_hi.raster=distance(dist_hydro_hi.raster)/1000

# Exclude grid cells within certain distance to the existing projects
temp1 = dist_hydro_lo.raster
temp1[ which( temp1[] <= 5 )  ] = 1 # don't install less than 5 km away for less than 100 MW
temp1[ temp1[] != 1 ] = 0
temp2 = dist_hydro_hi.raster
temp2[ which( temp2[] <= 5  ) ] = 1 # don't install less than 5 km away for greater than 100 MW
temp2[ temp2[] != 1 ] = 0
dist_hydro.raster = temp1 + temp2
dist_hydro.raster[ dist_hydro.raster[] %in% c(1,2) ] = 1
dist_hydro.raster[ dist_hydro.raster[] != 1 ] = NA

# resample to match flow accumulation
dist_hydro.raster = resample(dist_hydro.raster, flow_accumulation.raster, method="bilinear")

# Go through each GCM-scenario combination and route the runoff through the high resolution network

for( climate_scenario in climate_scenarios )
	{

	for( climate_model in climate_models )
		{

		print( paste0( 'Working on: ', climate_scenario, ' ', climate_model ) )

		# Get the runoff from low resolution hydrological model
		ghm_dynamic.stack = ghm.list[[ climate_model ]][[ climate_scenario ]]
		if( !is.null( ghm_dynamic.stack ) )
			{
			f.stack  = ghm_dynamic.stack / 1000 # convert to km per day
			proj4string(f.stack) = proj4string(flow_accumulation.raster)
			runoff.df = data.frame( do.call( cbind, lapply( 1:nlayers( f.stack ), function( nnn ){

				unlist( f.stack[[ nnn ]][ c(nt.df$ghm_cell) ] ) * unlist( nt.df$area )  # in km3 per day

				} ) ) )
			names(runoff.df) = names(f.stack)
			runoff.df[is.na(runoff.df)]=0

			# check annual inflow
			annual_inflow_km3 = sapply( 1:6, function(i){ sum( apply( runoff.df[,(12*(i-1)+1):(12*i)], 1, mean ), na.rm=TRUE ) * 365 } )

			# Get the groundwater recharge from the low resolution hydrological model
			gwr_dynamic.stack = gwr.list[[ climate_model ]][[ climate_scenario ]]
			f.stack  = gwr_dynamic.stack / 1000 # convert to km per day
			proj4string(f.stack) = proj4string(flow_accumulation.raster)
			recharge.df = data.frame( do.call( cbind, lapply( 1:nlayers( f.stack ), function( nnn ){

				unlist( f.stack[[ nnn ]][ c(nt.df$ghm_cell) ] ) * unlist( nt.df$area )   # in km3 per day

				} ) ) )
			names(recharge.df) = names(f.stack)
			recharge.df[is.na(recharge.df)]=0
			recharge.df[recharge.df<0]=0

			# Check annual recharge
			annual_recharge_km3 = sapply( 1:6, function(i){ sum( apply( recharge.df[,(12*(i-1)+1):(12*i)], 1, mean ), na.rm=TRUE ) * 365 } )

			# Transmission losses - based on LISFLOOD documentation
			# Limit the transmission losses to cells with a given downstream area (1e10)
			# Estimated that under the standard parameters, 3% loss for 0.5 degree grid cell - scaling to flow accumulation raster
			tmp = nt.df$flow_accumulation * nt.df$area_og * 1e6 / 1e10
			nt.df$trn_loss = nt.df$flow_accumulation * nt.df$area_og * 1e6 / 1e10
			nt.df$trn_loss[ which( nt.df$trn_loss > 1 ) ] = 0
			nt.df$trn_loss[ which( nt.df$trn_loss > 0 ) ] = 0.03 * res( basin.raster )[1] / 0.5

			# Downscale runoff and route through the network
			flow.df = runoff.df
			ntm.df = nt.df
			while( nrow(ntm.df) > 0 )
				{

				# Get the most upstream cells and immediate downstream neighbours
				cell_tot = nrow(ntm.df)
				cell_start = as.integer( unlist( ntm.df$cell[ which( !( ntm.df$cell %in% ntm.df$downstream_cell ) ) ] ) )
				ind_start = match( cell_start, nt.df$cell )

				# Upstream cells to look at are those not included in the downstream list
				cell_down = as.integer( unlist( nt.df$downstream_cell[ ind_start ] ) )
				ind_down = match( cell_down, nt.df$cell )

				# transmission loss parameter for estimating the losses GW and evaporation during transport.
				trn_loss = as.numeric( unlist( nt.df$trn_loss[ ind_start ] ) )

				# Set a threshold indicating the length of the upstream cell vector to start using direct indexing for
				# setting the flow values, which becomes faster as ntm.df gets smaller
				thr = 3
				if( length(ind_down) > thr )
					{

					# Route the flow from the upstream cells
					nm = names(flow.df)

					flow.df = data.frame( do.call( cbind, lapply( 1:ncol( flow.df ), function( ttt ){

						fl = as.vector( flow.df[ , ttt ] )

						for( i in which( !is.na( ind_down ) ) ){

							# if not a sink, include flow at upstream cell in downstream accounting and include transmission loss
							if( ind_down[i] != ind_start[i] ){

								fl[ ind_down[i] ] = fl[ ind_down[i] ] + fl[ ind_start[i] ] * ( 1 - trn_loss[ i ] )

								}

							}

						return(fl)

						} ) ) )

					names(flow.df) = nm

					}else{ # exclude transmission losses and compute all time steps simultaneuosuly - more efficient for few indices

					if( length(ind_down) > 0 ){

						for( i in which( !is.na( ind_down ) ) ){

							if( ind_down[i] != ind_start[i] ){

								flow.df[ ind_down[i], ] = as.vector( flow.df[ ind_down[i], ] ) + as.vector( flow.df[ ind_start[i], ] )

								}

							}

						}

					}

				# remove the most upstream cells to step through the network
				ntm.df = ntm.df[ -1*which( ntm.df$cell %in% cell_start ), ] # remove routed cells from list

				}

			# Output routed flow to netcdf
			# temp = cbind( nt.df[,c('xloc','yloc')], flow.df )
			# coordinates(temp) = ~xloc+yloc
			# gridded(temp) = TRUE
			# temp = do.call( stack, lapply( 1:12, function(iii){ return( raster( temp[ , iii ] ) ) } ) )
			# elev_out.raster = resample( elevation.raster, temp[[1]], method = 'bilinear' )
			# drv = 'I:/hunt/Indus Basin/'
			# vars = c('qnat')
			# vars_long = c('flow')
			# vars_units = c('km3 per day')
			# vars_prec = rep('double',length(vars))
			# dim_time = ncdim_def( 'time', "months since December 2009", unlist(lapply(1:length(c(2010)), function(y){ (120*(y-1) + 1) + seq(0,11,by=1) })), unlim=T )
			# dim_lon  = ncdim_def(	'lon',
									# 'degrees_east',
									# seq( bbox(rasterToPoints(temp[[1]], spatial = TRUE))[1,1], bbox(rasterToPoints(temp[[1]], spatial = TRUE))[1,2], by = res(temp[[1]])[1]) )
			# dim_lat  = ncdim_def(	'lat',
									# 'degrees_north',
									# seq( bbox(rasterToPoints(temp[[1]], spatial = TRUE))[2,1], bbox(rasterToPoints(temp[[1]], spatial = TRUE))[2,2], by = res(temp[[1]])[2]) )
			# nc = nc_create( 	paste( drv, 'naturalized_flow_indus.nc', sep = '' ),
								# ncvar_def( vars, vars_units, list(dim_lon,dim_lat,dim_time), -9999, longname = vars_long ),
								# force_v4 = TRUE,
								# verbose = FALSE )
			# ncvar_put( 	nc,
						# ncvar_def( 	vars,
									# vars_units,
									# list(dim_lon,dim_lat,dim_time),
									# -9999,
									# longname = vars_long ),
									# aperm(	as.array(temp), c(2,1,3) ) )
			# nc_close(nc)

			# # Output elevation
			# vars = c('elevation')
			# vars_long = c('elevation')
			# vars_units = c('meters')
			# vars_prec = rep('double',length(vars))
			# nc = nc_create( 	paste( drv, 'elevation_indus.nc', sep = '' ),
								# ncvar_def( vars, vars_units, list(dim_lon,dim_lat), -9999, longname = vars_long ),
								# force_v4 = TRUE,
								# verbose = FALSE )
			# ncvar_put( 	nc,
						# ncvar_def( 	vars,
									# vars_units,
									# list(dim_lon,dim_lat),
									# -9999,
									# longname = vars_long ),
									# aperm(	as.array(elev_out.raster), c(2,1,3) )[,,1] )
			# nc_close(nc)

			# Design flow for hydropower potential calculated based on 30 % exceedance
			design_flow.raster = flow_accumulation.raster
			design_flow.raster[] = NA
			design_hist_flow.raster = design_flow.raster
			design_flow.raster[lu] = apply( flow.df, 1, quantile, probs = 0.7 )
			design_hist_flow.raster[lu] = apply( flow.df[,1:12], 1, quantile, probs = 0.7 )

			# Design head and length assuming maximum of approx. 2 km penstock length and no transfers to different catchments
			# i.e., move down 3 grid cells and calculate the elevation drop - that's the max drop assumed for the penstock in this case.
			dni = match( nt.df$downstream_cell, nt.df$cell )
			dnii = match( nt.df$downstream_cell[ dni ], nt.df$cell )
			dniii = match( nt.df$downstream_cell[ dnii ], nt.df$cell )
			dh.df = nt.df$elevation_change[ dni ] + nt.df$elevation_change[ dnii ] + nt.df$elevation_change[ dniii ]

			# Gross hydropower potential -> in MW
			hydro.df = bind_cols( lapply( names(flow.df), function(iii){

				data.frame(  ( 0.925 * 0.1 * 1e9 * unlist( flow.df[,iii] ) / ( 60 * 60 * 24 ) ) * unlist( dh.df ) * 1000 * 9.81 * 0.85 / 1e6 )

				} ) )
			names(hydro.df) = names(flow.df)
			hydro.df = round( hydro.df, digits = 4 )
			hydro.df[is.na(hydro.df[])]=0

			# Design hydropower - inluding the design flow-rate
			hydro_design.df = data.frame(  hydro_design = ( 0.925 * 0.1 * 1e9 * unlist( design_flow.raster[lu] ) / ( 60 * 60 * 24 ) ) * unlist( dh.df ) * 1000 * 9.81 * 0.85 / 1e6 )
			hydro_design.df = round( hydro_design.df, digits = 4 )
			hydro_design.df[is.na(hydro_design.df[])]=0

			### Exclusion zones

			# Create exclusion zone mask from criteria
			exclusion_zones.list = list( dist_hydro.raster )
			exclusion_zone.raster = sum( do.call( stack, lapply( 1:length( exclusion_zones.list ), function(iii){
				exclusion_zones1.raster = exclusion_zones.list[[iii]]
				exclusion_zones1.raster[ !is.na( exclusion_zones1.raster ) ] = 1
				exclusion_zones1.raster[ is.na( exclusion_zones1.raster ) ] = 0
				return(exclusion_zones1.raster)
				} ) ) )
			exclusion_zone.raster[ exclusion_zone.raster[] > 0 ] = 1

			# Import exclusion zone map for renewables and add to additional hydropower criteria
			exclusion_zone.raster = ws_excl + exclusion_zone.raster
			exclusion_zone.raster[ exclusion_zone.raster[] > 0 ] = 1

			# Hydropower sites remaining
			ht.stack = do.call( stack, lapply( names(hydro.df), function(mm){
				tts = flow_accumulation.raster
				tts[] = NA
				tts[ lu ] = hydro.df[,mm]
				tts = tts * -1* ( exclusion_zone.raster - 1 )
				return(tts)
				} ) )
			names(ht.stack) = names(hydro.df)
			htm.raster = flow_accumulation.raster
			htm.raster[] = NA
			htm.raster[ lu ] = unlist( hydro_design.df )
			htm.raster = htm.raster * -1* ( exclusion_zone.raster - 1 )
			htm0.raster=htm.raster

			# Identify run-of-river sites along 5 km stretches of the rivers
			# move through each polgyon in the basin for computational efficiency
			sites = do.call( rbind, lapply( 1:length(basin.spdf), function(ii){

				# mask for the basin
				msk = rasterize( as(basin.spdf,'SpatialPolygons')[ii], htm.raster )
				are = area(basin.spdf[ii,])/1e6
				arec = mean( area( msk )[], na.rm = TRUE )
				hp = msk * htm.raster
				flc = msk * flow_accumulation.raster

				# matrices for gathering cells withing 5 km of the identified sire
				around2 = matrix( rep(1,144), ncol = 12, byrow=TRUE ) # set for an approximate 5 km buffer around projects
				around2[6,6] = 0
				around3 = matrix( rep(1,24*24), ncol = 24, byrow=TRUE ) # set for an approximate 5 km buffer around projects
				around3[12,12] = 0

				# get the cell ids
				cell = which( hp[] > 0 ) # all cells with flow data
				cell = cell[ -1*which( cell %in% c( which.max(flc[]), data.frame( adjacent( flow_accumulation.raster, cell = which.max(flc[]), directions=around2, sorted=TRUE, include = TRUE ) )$to ) ) ]

				# initialize tracking variables
				sts = NULL
				tts = NULL
				ppr = NULL
				xxs = NULL
				yys = NULL
				pid = NULL

				# Check each potential cell within the 5 km radius to find site with max potential
				if( length( cell ) > 0 ){

					while( length(cell) > 0 ){

						st = cell[which.max( hp[ cell ] )]

						fl = flow_accumulation.raster[ st ]

						pr = hp[ st ]

						xs = xFromCell( flow_accumulation.raster, st )
						ys = yFromCell( flow_accumulation.raster, st )

						# if the flow accumulation at the site is greater than the subasin area, than
						# the site is located on the main river branch i.e., river plant - otherwise it is likely
						# on one of the tributaries that run into the main branch i.e., canal plant
						if( ( fl * arec ) > 0.9 * are ){ tt = 'river' }else{ tt = 'canal' }

						# store the data
						sts = c( sts, st )
						tts  =c( tts, tt )
						ppr = c( ppr, pr )
						xxs = c( xxs, xs )
						yys = c( yys, ys )

						# remove all potential sites within 10 km of the current site
						ad = data.frame( adjacent( flow_direction.raster, cell = st, directions=around3, sorted=TRUE, include = TRUE ) )$to
						cell = cell[ -1*which( cell %in% c( st, ad ) ) ]

						}

					# save the polygon id
					pid = rep( basin.spdf@data$PID[ii], length( sts ) )

					}

				return( data.frame( cell = sts, x = xxs, y = yys, pid = pid, type = tts, power = ppr ) )

				} ) )

			# limit sites to more than 1 MW
			sites = sites[ -1*which( sites$power < 1 ), ]

			# check the distance between potential sites
			temp = sites
			coordinates(temp) = ~x+y
			dds = sapply( 1:nrow(temp), function(ttt){ return( min( gDistance( temp[ttt,],temp[-1*ttt,], byid=TRUE ) ) ) } )

			# create raster with the sites
			temp = htm.raster
			temp[ ] = NA
			temp[ sites$cell ] = round( htm.raster[ sites$cell ], digits=1 )
			htm.raster = temp
			rm(temp)
			nmd=names(ht.stack)
			ht.stack = do.call( stack, lapply( nmd, function(mm){
				temp = ht.stack[[ mm ]]
				temp[ ] = NA
				temp[ sites$cell ] = round( ht.stack[[ mm ]][ sites$cell ],digits=1 )
				return(temp)
				} ) )
			names(ht.stack) = nmd

			# Get power output in each month
			sites = cbind( sites, data.frame( do.call( rbind, lapply( 1:nrow(sites), function(iii){
				df = data.frame( t( sapply( 1:nlayers(ht.stack), function(mm){ round( ht.stack[[ mm ]][ sites$cell[iii] ],digits=1 ) } ) ) )
				df[df>sites$power[iii]]=round( sites$power[iii], digits = 1 )
				names(df) = names(ht.stack)
				return(df)
				} ) ), row.names = row.names( sites ) ) )

			# plot the sites
			hcol = c('blue','orange')
			pdf( paste0( 'input/check/indus_hydro_sites_',climate_scenario,'_',climate_model,'_extreme.pdf'), width=6, height=6 )
			plot( basin.spdf, col = NA, border = NA, xlab = 'Longitude', ylab = 'Latitude', main = paste0( climate_model, ' : ', climate_scenario ) )
			plot( 	do.call( rbind, lapply( c('IND','PAK','AFG','CHN','NPL','TJK','UZB','TKM','IRN'), function(cnt){ getData( 'GADM', country = cnt, level = 0 ) } ) ),
					col = alpha( c('khaki','lightgreen','lightblue','lightcoral','grey75','grey75','grey75','grey75','grey75'), alpha = 0.2 ),
					border = 'gray55', add = TRUE )
			plot( basin.sp, col = NA, border = 'grey25', lwd = 1.5, add=TRUE )
			text( 69, 30, 'PAK', col = 'forestgreen',cex=1.5)
			text( 76, 29, 'IND', col = 'brown',cex=1.5)
			text( 80, 36, 'CHN', col = 'darkred',cex=1.5)
			text( 67, 36, 'AFG', col = 'navy',cex=1.5)
			pt1 = sites %>% filter( type == 'river' ) %>% select( x, y, power ) %>%
				mutate( cex = ( sqrt( power ) - min( sqrt( power ) ) ) / ( max( sqrt( power ) ) - min( sqrt( power ) ) ) * 3.5 + 1 ) %>%
				'coordinates<-'(~x+y) %>% 'proj4string<-'(proj4string(basin.spdf))
			points( pt1, pch = 21, cex = pt1@data$cex, col = hcol[1], bg = alpha( 'white', alpha= 0.3 ) )
			pt2 = sites %>% filter( type == 'canal' ) %>% select( x, y, power ) %>%
				mutate( cex = ( sqrt( power ) - min( sqrt( power ) ) ) / ( max( sqrt( power ) ) - min( sqrt( power ) ) ) * 3.5 + 1 ) %>%
				'coordinates<-'(~x+y) %>% 'proj4string<-'(proj4string(basin.spdf))
			points( pt2, pch = 21, cex = pt1@data$cex, col = hcol[2], bg = alpha( 'white', alpha= 0.3 ) )
			sizes = c(1, 10, 50, 100 )
			sgap = c(-0.05,0.5,1.3,2.5)
			for( iii in 1:length( sizes ) ){
				points( 82.2, 24+sgap[iii], cex = pt1@data$cex[ which.min( ( pt1@data$power - sizes[iii] )^2 ) ], pch = 21, col = 'gray35', bg = 'gray35' )
				text( 82, 24+sgap[iii], paste0( sizes[ iii ], ' MW ' ), col = 'gray35', cex = 0.9, pos = 2 )
				}
			axis(side=1,at=c())
			axis(side=2,at=c())
			box()
			par(new=TRUE,oma=c(0.25,11,14.5,6))
			dat = sites %>%
					select( pid, type, power ) %>%
					mutate( country = unlist( strsplit( as.character(pid), '_' ) )[seq(1,2*length(pid),by=2)]) %>%
					group_by( country, type ) %>% summarise( power = sum( power ) ) %>% as.data.frame()	%>%
					reshape( . , direction='wide', idvar = 'type', timevar = 'country' )
			row.names(dat) = dat$type
			names(dat) = unlist( strsplit( names(dat), '[.]' ) )[seq(1,2*length(names(dat)),by=2)]
			dat = dat %>% select(-type)
			mp = barplot( 	as.matrix( dat ),
							ylim = c(-0.12*round(1.5*max(colSums(dat,na.rm=TRUE)),digits=-2),round(1.5*max(colSums(dat,na.rm=TRUE)),digits=-2)), col = hcol[c(2,1)], ylab = '', yaxt = 'n', cex.axis = 0.8, cex.lab = 0.8, cex.names = 0.8, names.arg = rep('',ncol(dat) ) )
			axis(side=2,las=2,at=c(0,round(max(colSums(dat,na.rm=TRUE)),digits=-2)), labels = c(0,paste0( round(max(colSums(dat,na.rm=TRUE)),digits=-2), ' MW')),cex=0.8,cex.lab=0.8,cex.axis=0.8)
			text( mp, rep(-0.08*round(1.5*max(colSums(dat,na.rm=TRUE)),digits=-2),length(mp)), names(dat), cex = 0.75 )
			legend('top',legend = c('river','canal'), fill = hcol, bty = 'n', cex = 0.85, ncol = 2)
			dev.off()

			# Runoff into PIDs
			pids = nt.df$pid
			ups = unique(pids)
			ro.df = do.call( cbind, lapply( names(runoff.df), function( timestep ){

				rs1 = data.frame( unlist( lapply( ups, function( pid_check ){ sum( runoff.df[ which( pids == pid_check ), timestep ] ) } ) ) )

				names(rs1) = timestep

				row.names(rs1) = as.character( basin.spdf@data$PID[ ups ] )

				return(rs1)

				} ) )

			# Groundwater recharge into PIDs
			pids = nt.df$pid
			ups = unique(pids)
			rc.df = do.call( cbind, lapply( names(recharge.df), function( timestep ){

				rs1 = data.frame( unlist( lapply( ups, function( pid_check ){ sum( recharge.df[ which( pids == pid_check ), timestep ] ) } ) ) )

				names(rs1) = timestep

				row.names(rs1) = as.character( basin.spdf@data$PID[ ups ] )

				return(rs1)

				} ) )

			# Natural flow between PIDs based on reduced form network and transmission loss assumptions
			vo.df = do.call( cbind, lapply( names( ro.df ), function( timestep ){

				rom.df = data.frame( unlist( ro.df[,timestep] ), row.names = row.names( ro.df ) )

				names(rom.df) = timestep

				bm.df = data.frame( basin.spdf )

				bm.df$DPID = bm.df$PID[ match( bm.df$DOWN, bm.df$PID ) ]

				while( nrow(bm.df)>0 )
					{

					up = bm.df$PID[ which( !( bm.df$PID %in% bm.df$DPID ) & !is.na( bm.df$DPID ) ) ]

					dn = bm.df$DPID[ which( !( bm.df$PID %in% bm.df$DPID ) & !is.na( bm.df$DPID ) ) ]

					#windows()
					#plot(basin.spdf[match(up,basin.spdf@data$PID),],col='red')
					#plot(basin.spdf[match(dn,basin.spdf@data$PID),],add=TRUE,col='blue')

					if(length(which(dn %in% pids))>0){ for( i in 1:length(dn) ){ rom.df[ as.character( dn[i] ), timestep ] = rom.df[ as.character( dn[i] ), timestep ] + rom.df[ as.character( up[i] ), timestep ] } }

					bm.df = bm.df[ -1*match( up, bm.df$PID ), ]

					}

				return(rom.df)

				} ) )

			# Pullout river projects and aggregate to PID-level
			hriv.df = do.call( cbind, lapply( names(runoff.df), function( timestep ){
				rs1 = data.frame( unlist( lapply( ups, function( pid_check ){ return( sum( c( 0, sites[ which( sites$pid == pid_check & sites$type == 'river' ), timestep ] ), na.rm=TRUE ) ) } ) ) )
				names(rs1) = timestep
				row.names(rs1) = as.character( ups )
				return(rs1)
				} ) )

			# Pullout canal projects and aggregate to PID level
			hcan.df = do.call( cbind, lapply( names(runoff.df), function( timestep ){
				rs1 = data.frame( unlist( lapply( ups, function( pid_check ){ return( sum( c( 0, sites[ which( sites$pid == pid_check & sites$type == 'canal' ), timestep ] ), na.rm=TRUE ) ) } ) ) )
				names(rs1) = timestep
				row.names(rs1) = as.character( ups )
				return(rs1)
				} ) )

			# Linear transformation coefficients for converting network flow to hydropower potential
			hydro_coeff.df = do.call( rbind, lapply( ups, function( pid_check ){
				rr = unlist( ro.df[ as.character( pid_check ), ] )
				cc = unlist( vo.df[ as.character( pid_check ), ] )
				mr = mean(rr)
				mc = mean(cc)
				cp = unlist( hcan.df[ as.character( pid_check ), ] )
				rp = unlist( hriv.df[ as.character( pid_check ), ] )
				cx = sum( sites$power[ which( sites$pid == pid_check & sites$type == 'canal'  ) ]  )
				rx = sum( sites$power[ which( sites$pid == pid_check & sites$type == 'river'  ) ]  )
				if( rx > 0 )
					{
					rr = rr[ -1*which( rp >= 0.95 * rx ) ]
					rp = rp[ -1*which( rp >= 0.95 * rx ) ]
					r = lm( rp ~ 0 + rr )
					riv_coeff = unlist( coef(r)[1] )
					windows()
					plot( rr, rp )
					lines( c( min( rr ), max( rr ) ),  riv_coeff * c( min( rr ), max( rr ) ) )
					}else{ riv_coeff = 0 }
				if( cx > 0 )
					{
					cc = cc[ -1*which( cp >= 0.95 * cx ) ]
					cp = cp[ -1*which( cp >= 0.95 * cx ) ]
					r = lm( cp ~ 0 + cc )
					can_coeff = unlist( coef(r)[1] )
					windows()
					plot( cc, cp )
					lines( c( min( cc ), max( cc ) ),  can_coeff * c( min( cc ), max( cc ) ) )
					}else{ can_coeff = 0 }
				dfs = round( data.frame( 	canal_max_mw = cx,
											canal_mw_per_km3_per_day = can_coeff,
											canal_mean_mw = mc * can_coeff,
											canal_cf = max( 0, mc * can_coeff / cx, na.rm=TRUE ),
											river_max_mw = rx,
											river_mw_per_km3_per_day = riv_coeff,
											river_mean_mw = mr * riv_coeff,
											river_cf = max( 0, mr * riv_coeff / rx, na.rm=TRUE )	), digits = 2 )
				return( dfs )
				} ) )
			row.names( hydro_coeff.df ) = ups

			# Existing hydropower
			basin_hydropower.df = data.frame( readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_power_plants', verbose = FALSE ) ) %>%
				filter( TPS == 'hydro' ) %>%
				select( PID, STATUS, MW ) %>%
				mutate( STATUS = if_else( STATUS %in% c('PLN','CON'), 'PLN', 'OPR'	) ) %>%
				group_by( PID, STATUS ) %>% summarise( MW = sum(MW ) ) %>% as.data.frame()

			hydro_coeff.df$existing_MW = round( sapply( row.names(hydro_coeff.df), function(iii){ return( sum( basin_hydropower.df$MW[ which( as.character( unlist( basin_hydropower.df$PID ) ) == iii & as.character( unlist( basin_hydropower.df$STATUS ) ) == 'OPR' )  ] ) ) } ) )
			hydro_coeff.df$planned_MW = round( sapply( row.names(hydro_coeff.df), function(iii){ return( sum( basin_hydropower.df$MW[ which( as.character( unlist( basin_hydropower.df$PID ) ) == iii & as.character( unlist( basin_hydropower.df$STATUS ) ) == 'PLN' )  ] ) ) } ) )

			# Output to csv
			names(ro.df) = unlist( lapply( paste( 'runoff_km3_per_day', c(2015,2020,2030,2040,2050,2060), sep = '_' ), function( vv ){ return( paste( vv, c( seq(1,12,by=1) ), sep = '.' ) ) } ) )
			names(rc.df) = unlist( lapply( paste( 'recharge_km3_per_day', c(2015,2020,2030,2040,2050,2060), sep = '_' ), function( vv ){ return( paste( vv, c( seq(1,12,by=1) ), sep = '.' ) ) } ) )
			out.df = cbind( data.frame( PID = row.names(hydro_coeff.df ) ),
							round(ro.df,digits=4),
							round(rc.df,digits=4),
							hydro_coeff.df )
			out.df = out.df[ order( out.df$PID ), ]
			write.csv( out.df, paste0( 'input/basin_water_resources/basin_water_resources_',climate_model,'_',climate_scenario,'_extreme.csv' ), row.names=FALSE )

			names(vo.df) = unlist( lapply( paste( 'natural_flow_km3_per_day', c(2015,2020,2030,2040,2050,2060), sep = '_' ), function( vv ){ return( paste( vv, c( seq(1,12,by=1) ), sep = '.' ) ) } ) )
			write.csv( cbind( data.frame( PID = ups ), vo.df ), paste0('input/basin_water_resources/basin_environmental_flow_',climate_model,'_',climate_scenario,'_extreme.csv'), row.names=FALSE )

			graphics.off()

			gc()

			}

		}

	}

# # Summary plot

# # import water resources

# wr.df = bind_rows( lapply( list.files( 'input/basin_water_resources', pattern = 'basin_water_resources_' ), function( fl ){

	# read.csv( paste0 ( 'input/basin_water_resources/', fl ) ) %>%
		# select( names( . )[ grepl( 'runoff|recharge|PID', names( . ) ) ] ) %>%
		# melt( ., id = 'PID' ) %>%
		# mutate( dat = variable ) %>%
		# mutate( type = unlist( strsplit( as.character( dat ), '_' ) )[ seq( 1, 5*length( dat ), by = 5 ) ],
				# year = unlist( strsplit( unlist( strsplit( as.character( dat ), '_' ) )[ seq( 5, 5*length( dat ), by = 5 ) ], '[.]' ) )[seq(1,2*length(dat),by=2)],
				# month = unlist( strsplit( as.character( dat ), '[.]' ) )[ seq( 2, 2*length( dat ), by = 2 ) ],
				# climate_model = unlist( strsplit( unlist( strsplit( fl, '.csv' ) )[1], '_' ) )[4],
				# climate_scenario = unlist( strsplit( unlist( strsplit( fl, '.csv' ) )[1], '_' ) )[5] ) %>%
				# left_join( ., data.frame( month = as.character(1:12), days = c(31,28.25,31,30,31,30,31,31,30,31,30,31) ) ) %>%
				# left_join( ., bind_rows( data.frame( month = as.character( c( 6, 7, 8, 9, 10, 11 ) ), season = 'kharif' ), bind_rows( data.frame( month = as.character( c( 12, 1, 2, 3, 4, 5 ) ), season = 'rabi' ) ) ) ) %>%
				# mutate( country = unlist( strsplit( as.character( PID ), '_') )[ seq( 1, 2*length( PID ), by = 2 ) ] ) %>%
				# mutate( value = value * days, units = 'km3' ) %>%
		# select( PID, country, climate_scenario, climate_model, type, units, year, season, month, value )

	# } ) )

# # Boxplot by kharif and rabi seasons for each country
# df = wr.df %>% select( type, country, climate_scenario, climate_model, year, season, value ) %>%
	# group_by( type, country, climate_scenario, climate_model, season, year ) %>%
	# summarise( value = mean( value ) ) %>% as.data.frame()

# pdf( 'input/check/water_inflows.pdf', width = 6.5, height = 8.5 )
# p1 = layout( matrix( c(9,9,1,5,2,6,3,7,4,8),5,2,byrow=TRUE ), widths = c(0.3,0.3), heights= c(0.05,0.2,0.2,0.2,0.2) )
# par(mar=c(3,3,2,1),oma=c(0,0,0,0))
# for( tp in unique( wr.df$type ) )
	# {
	# for( cn in unique( wr.df$country ) )
		# {
		# df1 = df %>% filter( country == cn, type == tp ) %>% select( climate_scenario, season, value )
		# boxplot( 	value ~ climate_scenario + season, data = df1,
					# at = c(1,2,3, 4,5,6), boxlwd = 0.5, medlwd = 0.5,
					# col = c('deepskyblue','forestgreen','orange'),
					# names = c( '', unique( df1$season )[1], '', '', unique( df1$season )[2], '' ),
					# xaxs = FALSE, xaxt = 'n',main = bquote( .(cn) ~ ' - ' ~ .(tp) ~ ' [ ' ~ km^3 ~ ' ]' ) )
		# axis( side = 1, at = c(1,2,3, 4,5,6), labels = c( '', unique( df1$season )[1], '', '', unique( df1$season )[2], '' ), lwd.ticks=FALSE )
		# abline(v=3.5)
		# }
	# }
# par(mar=c(0,0,0,0))
# plot.new()
# legend('center',legend = c( 'historical','rcp2.6','rcp6.0' ), fill = c('deepskyblue','forestgreen','orange'), ncol= 3, bty = 'n', cex = 1.2 )
# dev.off()


#Table of R2 values for supplement.
rm(list=ls())
source('paths_fall2019.r')
source('paths.r')
library(RColorBrewer)

#set output path.----
output.path <- 'figures/Supplementary_Data_File_1.csv'

#Load calibration/validation rsq.1 data, Moran's I data.----
d.ITS <- readRDS(NEON_dmilti.ddirch_analysis_summary.path)
d.16S <- readRDS(NEON_dmilti.ddirch_analysis_summary_16S.path)

#group together rsq_raw and rsq_1.1 for fungi across scales.----
#Fungi.
all.scale <- list()
for(i in 1:length(d.ITS$validation$val.stat)){
  scale     <- d.ITS$validation$val.stat[[i]]
  scale.lab <- names(d.ITS$validation$val.stat)[i]
  scale.lab <- sub("\\..*", "", scale.lab)
  scale.out <- list()
  for(k in 1:length(scale)){
    tax <- scale[[k]]
    tax <- tax[,1:3]
    tax[,2:3] <- round(tax[,2:3],2)
    tax[,3] <- ifelse(tax[,3] < 0, 0, tax[,3])
    colnames(tax)[2:3] <- c('rsq_raw','rsq_1.1')
    colnames(tax)[2:3] <- paste0(colnames(tax)[2:3],'_',scale.lab)
    if(i == 1){
      tax$grouping <- names(scale)[k]
    }
    scale.out[[k]] <- tax
  }
  scale.out <- data.frame(do.call(rbind, scale.out))
  all.scale[[i]] <- scale.out
}
fun <- merge(all.scale[[1]], all.scale[[2]])
fun <- merge(fun, all.scale[[3]])
fun$kingdom <- 'Fungi'

#Bacteria.
all.scale <- list()
for(i in 1:length(d.16S$validation$val.stat)){
  scale     <- d.16S$validation$val.stat[[i]]
  scale.lab <- names(d.16S$validation$val.stat)[i]
  scale.lab <- sub("\\..*", "", scale.lab)
  scale.out <- list()
  for(k in 1:length(scale)){
    tax <- scale[[k]]
    tax <- tax[,1:3]
    tax[,2:3] <- round(tax[,2:3],2)
    tax[,3] <- ifelse(tax[,3] < 0, 0, tax[,3])
    colnames(tax)[2:3] <- c('rsq_raw','rsq_1.1')
    colnames(tax)[2:3] <- paste0(colnames(tax)[2:3],'_',scale.lab)
    if(i == 1){
      tax$grouping <- names(scale)[k]
    }
    scale.out[[k]] <- tax
  }
  scale.out <- data.frame(do.call(rbind, scale.out))
  all.scale[[i]] <- scale.out
}
bac <- merge(all.scale[[1]], all.scale[[2]])
bac <- merge(bac, all.scale[[3]])
bac$name <- paste(toupper(substring(bac$name, 1,1)), substring(bac$name, 2), sep="")
bac$kingdom <- 'Bacteria'

#Merge together and save.----
#merge.
out <- rbind(bac, fun)
out <- out[,c('kingdom','grouping','name',
              'rsq_raw_core','rsq_1.1_core',
              'rsq_raw_plot','rsq_1.1_plot',
              'rsq_raw_site','rsq_1.1_site')]
out <- out[order(out$rsq_1.1_site, decreasing = T),]

#save.
write.csv(out, output.path)


## lines that SDSS tracks

speclines <- c(3727.092,3729.875,3869.857,3890.151,3971.123,4102.892,4341.684,4364.435,
4686.991,4862.683,4960.295,5008.240,5413.024,5578.888,6302.046,6313.806,
6365.535,6549.859,6564.614,6585.268,6718.294,6732.678,7137.757)

names(speclines) <- c("O_II_3725","O_II_3727","Ne_III_3868","H_epsilon",
"Ne_III_3970","H_delta","H_gamma","O_III_4363",
"He_II_4685","H_beta","O_III_4959","O_III_5007",
"He_II_5411","O_I_5577","O_I_6300","S_III_6312",
"O_I_6363","N_II_6548","H_alpha","N_II_6583",
"S_II_6716","S_II_6730","Ar_III_7135")

## major emission lines

lambda_f <- c(3727.092,3729.875,3869.857,3971.123,4960.295,
              5008.240,6302.046,6365.535,6549.859,6585.268,
              6718.294,6732.678)
names(lambda_f) <- c("oii_3727","oii_3729","neiii_3869",
                     "neiii_3970","oiii_4959","oiii_5007",
                     "oi_6300","oi_6363","nii_6548","nii_6584",
                     "sii_6717","sii_6730")

lambda_balmer <- c(3890.151,3970.072,4102.892,4341.684,4862.683,6564.614)
names(lambda_balmer) <- c("h_zeta","h_epsilon","h_delta","h_gamma","h_beta","h_alpha")

lambda_em <- sort(c(lambda_f, lambda_balmer))

## forbidden & recombination lines that are usually weak

lambda_weak <- c(4364.435, 4686.991, 5413.024, 5578.888, 6313.806, 7137.757)
names(lambda_weak) <- c("oiii_4363", "heii_4685", "heii_5411", "oi_5577", "siii_6312", "ariii_7135")

## legacy support for reading an sdss spectrum in a csv file

readsdsspec <- function(fname, z, dname="spectra") {
  gdat <- read.csv(file.path(dname,fname), header=TRUE)
  gdat$lambda <- gdat$lambda/(1+z)
  gdat$flux[gdat$ivar==0] <- NA
  gdat$flux[gdat$flux== -9999.] <- NA
  gdat$ivar[gdat$ivar==0] <- NA
  gdat$ivar[gdat$ivar== -9999.] <- NA
  gdat
}

regrid <- function(lambda.out, lib) {
    lambda.in <- lib$lambda
    nc <- ncol(lib)
    lib.out <- matrix(NA, length(lambda.out), nc)
    lib.out[,1] <- lambda.out
    for (i in 2:nc) {
        lib.out[,i] <- approx(lambda.in, lib[,i], xout=lambda.out)$y
    }
    colnames(lib.out) <- colnames(lib)
    data.frame(lib.out)
}

closest <- function(x, vec) which.min(abs(x-vec))

vactoair <- function(lambda) lambda/(1+2.735182e-4+131.4182/lambda^2+2.76249E8/lambda^4)

airtovac <- function(lambda) {
  s2 <- (1e4/lambda)^2
  fac <- 1 + 5.792105e-2/(238.0185-s2)+1.67917e-3/(57.362-s2)
  lambda*fac
}

## Galactic extinction correction from Fitzpatrick (1998): http://arxiv.org/abs/astro-ph/9809387v1
## This is spline fit portion valid from near-UV to near-IR and R=3.1

elaw <- function(lambda, ebv) {
  il <- c(0,0.377,0.820,1.667,1.828,2.141,2.433,3.704,3.846)
  al <- c(0,0.265,0.829,2.688,3.055,3.806,4.315,6.265,6.591)
  fai <- splinefun(il,al)
  10^(0.4*fai(10000/lambda)*ebv)
}

fitz <- function(lambda, tauv) {
  il <- c(0,0.377,0.820,1.667,1.828,2.141,2.433,3.704,3.846)
  al <- c(0,0.265,0.829,2.688,3.055,3.806,4.315,6.265,6.591)
  fai <- splinefun(il,al)
  exp(-fai(10000/lambda)*tauv)
}

## Calzetti et al. (2000-2001) extinction curve

calzetti.orig <- function(lambda, tauv) {
  lambda <- lambda/10000
  kl <- numeric(length(lambda))
  lb <- lambda < 0.63
  kl[lb] <- 1+(2.659/4.05)*(-2.151285+1.509/lambda[lb]-0.198/(lambda[lb]^2)+0.011/(lambda[lb]^3))
  kl[!lb] <- 1+(2.659/4.05)*(-1.8561715+1.04/lambda[!lb])
  exp(-kl*tauv)
}

## approximation to above using a single function

calzetti <- function(lambda, tauv) {
  ls <- lambda/10000
  k <- -0.2688+0.7958/ls-4.785e-2/(ls^2)-6.033e-3/(ls^3)+7.163e-04/(ls^4)
  exp(-k*tauv)
}

## modified calzetti relation from Salim et al. 2018

calzetti_mod <- function(lambda, tauv, delta=0) {
  ls <- 5500./lambda
  kl <- -0.101771 + 0.549882 * ls + 1.393039 * ls^2 - 1.098615 * ls^3 + 0.260618 * ls^4
  kl <- kl * ls^delta
  exp(-tauv * kl)
}

## galactic extinction law of Cardelli, Clayton, & Mathis 1989, ApJ 345, 245

ccm <- function(lambda, tauv, rv=3.1) {
  x <- 10000/lambda
  y <- x-1.82

  kl <- numeric(length(lambda))
  a <- numeric(length(lambda))
  b <- numeric(length(lambda))

  lb <- (x <= 1.1)

  a[lb] <- 0.574*x[lb]^1.61
  b[lb] <- -0.527*x[lb]^1.61

  a[!lb] <- 1 + 0.17699*y[!lb] - 0.50447*y[!lb]^2 - 0.02427*y[!lb]^3 + 0.72085*y[!lb]^4 +
            0.01979*y[!lb]^5 - 0.7753*y[!lb]^6  + 0.32999*y[!lb]^7
  b[!lb] <- 1.41338*y[!lb] + 2.28305*y[!lb]^2 + 1.07233*y[!lb]^3 - 5.38434*y[!lb]^4 -
            0.62251*y[!lb]^5 + 5.30260*y[!lb]^6 - 2.09002*y[!lb]^7
  kl <- a + b/rv
  exp(-tauv * kl)
}

simplescreen <- function(lambda, tauv, delta = 0.) {
    exp(-tauv*(5500./lambda)^(0.7 + delta))
}

## make a fake emission line library

make_emlib <- function(lambda_em, vdisp_em, loglambda, isok, sthresh=5000) {
    vdisp_p <- vdisp_em/(299792.458*log(10))
    n_em <- length(lambda_em)
    nl <- length(loglambda)
    x_em <- matrix(0, nl, n_em)
    for (i in 1:n_em) {
        x_em[,i] <- dnorm(loglambda, mean=log10(lambda_em[i]), sd=vdisp_p)
    }
    in_em <- which(colSums(x_em[isok, ]) >= sthresh)
    x_em <- x_em[,in_em]/10000
    list(x_em=x_em, in_em=in_em)
}

blur.lib <- function(lib.ssp, vdisp, dlogl=1.e-4) {
  c <- 299792.458
  sigma.p <- vdisp/(dlogl*c*log(10))
  kw <- max(round(6*sigma.p), 3)
  if ((kw%%2)==0) kw <- kw+1
  k0 <- (kw %/% 2) + 1
  kernel <- dnorm((1:kw)-k0, sd=sigma.p)
  kernel <- kernel/sum(kernel)
  sp.st <- filter(lib.ssp[,-1], kernel, method="convolution")
  as.matrix(sp.st)
}

dblineratios <- function(db, dthresh=3) {
    o3hbeta <- log10(db$oiii_flux) - log10(db$h_beta_flux)
    o3hbeta[(db$oiii_flux/db$oiii_flux_err < dthresh) | (db$h_beta_flux/db$h_beta_flux_err < dthresh)] <- NA
    n2halpha <- log10(db$nii_6584_flux) -log10(db$h_alpha_flux)
    n2halpha[(db$nii_6584_flux/db$nii_6584_flux_err < dthresh) | (db$h_alpha_flux/db$h_alpha_flux_err < dthresh)] <- NA
    db <- cbind(db, o3hbeta, n2halpha)
    return(db)
}

## galaxy class by emission line strengths, from Kewley et al. 2006 and Schawinski et al. 2007
## only using n2halpha and o3hbeta for now.

emclass <- function(db=NULL, snthresh=3, PLOT=TRUE) {

  if (!is.null(db)) {
    attach(db)
    class <- as.factor(rep("no em.",length(n2halpha)))
    levels(class) <- c("no em.", "SF", "Comp.", "AGN", "LINER", "EL")

    #starforming

    class[(o3hbeta <= 0.61/(n2halpha-0.05)+1.3) & (n2halpha <= 0.05)] <- "SF"

    # composite

    class[((o3hbeta > 0.61/(n2halpha-0.05)+1.3) | (n2halpha > 0.05)) &
    (o3hbeta <= .61/(n2halpha-0.47)+1.19)] <- "Comp."

    # Seyfert == AGN

    class[(o3hbeta > .61/(n2halpha-0.47)+1.19) & (o3hbeta > 1.05*n2halpha+0.45)] <- "AGN"
    class[(n2halpha > 0.47) & (o3hbeta > 1.05*n2halpha+0.45)] <- "AGN"

    # Liners

    class[(o3hbeta > .61/(n2halpha-0.47)+1.19) & (o3hbeta <= 1.05*n2halpha+0.45)] <- "LINER"
    class[(n2halpha > 0.47) & (o3hbeta <= 1.05*n2halpha+0.45)] <- "LINER"

    # weak emission line

    class[((is.na(n2halpha) | is.na(o3hbeta)) & ((oii_flux/oii_flux_err > snthresh) |
    (oiii_flux/oiii_flux_err > snthresh) |
    (h_alpha_flux/h_alpha_flux_err > snthresh) |
    (nii_6584_flux/nii_6584_flux_err > snthresh)))] <- "EL"

    class <- as.factor(class)
    if (PLOT) {
      plot(n2halpha, o3hbeta, pch=20, col=unclass(class))
    }
    detach(db)
  }

  if (PLOT) {

    #kauffmann et al. curve

    curve(1.3+.61/(x-0.05),from= -1.5,to= -0.2,lty=2,add=TRUE)

    #kewley 2001 curve

    curve(.61/(x-0.47)+1.19, from= -1.5, to= 0.22, add=TRUE)

    #Shawinski et al. curve

    curve(0.45+1.05*x, from=-0.2, to= 1, add=TRUE)
  }

  if (!is.null(db)) return(class)
}

## flux ratio at the 4000 A discontinuity. Note 20130908 - weights have been dropped; improves
## correlation with MPA-JHU pipeline estimates. Also corrected lambda weighting

## d4000_n index

d4000n <- function(lambda, flux, ivar, wl4000=c(3850,3950,4000,4100)) {
    wl4000 <- airtovac(wl4000)
    ni <- which(lambda>=wl4000[3] & lambda<=wl4000[4])
    di <- which(lambda>=wl4000[1] & lambda<=wl4000[2])
    dln <- diff(lambda)[ni]
    dld <- diff(lambda)[di]
    fn <- flux[ni]
    if (length(which(!is.na(fn))) < 2) {
        return(list(d4000_n=NA, d4000_n_err=NA))
    }
    if (any(is.na(fn))) {
        fn <- approx(lambda[ni], fn, xout=lambda[ni])$y
    }
    fd <- flux[di]
    if (length(which(!is.na(fd)))<2) {
        return(list(d4000_n=NA, d4000_n_err=NA))
    }
    if (any(is.na(fd))) {
        fd <- approx(lambda[di], fd, xout=lambda[di])$y
    }
    num <- sum(fn*dln*(lambda[ni]^2))
    vn <- sum((dln^2)*(lambda[ni]^4)/ivar[ni])
    den <- sum(fd*dld*(lambda[di]^2))
    vd <- sum((dld^2)*(lambda[di]^4)/ivar[di])
    d4000_n <- num/den
    d4000_n_err <- sqrt(num^2/den^2*(vn/den^2+vd/num^2))
    list(d4000_n=d4000_n, d4000_n_err=d4000_n_err)
}

## lick indices

lickew <- function(lambda, flux, ivar, which.index=1) {

  wl <- t(matrix(airtovac(c(4083.5,4122.25,4041.6,4079.75,4128.5,4161,
                                      4142.125,4177.125,4080.125,4117.625,4244.125,4284.125,
                                      4142.125,4177.125,4083.875,4096.375,4244.125,4284.125,
                                      4222.250,4234.750,4211.000,4219.750,4241.000,4251.000,
                                      4281.375,4316.375,4266.375,4282.625,4318.875,4335.125,
                                      4369.125,4420.375,4359.125,4370.375,4442.875,4455.375,
                                      4452.125,4474.625,4445.875,4454.625,4477.125,4492.125,
                                      4514.250,4559.250,4504.250,4514.250,4560.500,4579.250,
                                      4634.000,4720.250,4611.500,4630.250,4742.750,4756.500,
                                      4758.500,4800.000,4742.750,4756.500,4827.875,4847.875,
                                      5069.125,5134.125,4895.125,4957.625,5301.125,5366.125,
                                      5154.125,5196.625,4895.125,4957.625,5301.125,5366.125,
                                      5160.125,5192.625,5142.625,5161.375,5191.375,5206.375,
                                      5245.650,5285.650,5233.150,5248.150,5285.650,5318.150,
                                      5312.125,5352.125,5304.625,5315.875,5353.375,5363.375,
                                      5387.500,5415.000,5376.250,5387.500,5415.000,5425.000,
                                      5445.000,5600.000,5420.000,5442.000,5630.000,5655.000,
                                      5696.625,5720.375,5672.875,5696.625,5722.875,5736.625,
                                      5776.625,5796.625,5765.375,5775.375,5797.875,5811.625,
                                      5876.875,5909.375,5860.625,5875.625,5922.125,5948.125,
                                      5936.625,5994.125,5816.625,5849.125,6038.625,6103.625,
                                      6189.625,6272.125,6066.625,6141.625,6372.625,6415.125,
                                      6357.500,6401.750,6342.125,6356.500,6408.500,6429.750,
                                      6775.000,6900.000,6510.000,6539.250,7017.000,7064.000)),6,24))
  inames <- c("HdeltaA","CN_1","CN_2","Ca4227","G4300",
              "Fe4383","Ca4455","Fe4531","Fe4668","bTiO",
              "Mg_1","Mg_2","Mg_b","Fe5270","Fe5335",
              "Fe5406","aTiO","Fe5709","Fe5782","Na_D",
              "TiO_1","TiO_2","CaH1", "CaH2")
  imag <- rep(FALSE, length(inames))
  imag[c(2,3,11,12,21,22)] <- TRUE
  imag <- imag[which.index]
  wl <- matrix(wl[which.index,], length(which.index), 6)
  ni <- nrow(wl)
  ew <- rep(NA,ni)
  ew_sd <- rep(NA,ni)
  df <- data.frame(lambda=lambda, flux=flux, ivar=ivar)
  for (j in 1:ni) {
    pb <- which(lambda>=wl[j,1] & lambda<=wl[j,2])
    bsb <- which(lambda>=wl[j,3] & lambda<=wl[j,4])
    rsb <- which(lambda>=wl[j,5] & lambda<=wl[j,6])
    if (all(is.na(flux[pb])) || all(is.na(flux[bsb])) || all(is.na(flux[rsb]))) next
    cfit <- lm(flux~lambda, data=df, subset=union(bsb,rsb))
    cont <- predict(cfit, newdata=df[pb,], interval="prediction", level=0.7)
    sd.cont <- (cont[,3]-cont[,2])/2
    dl <- (diff(lambda))[pb]
    num <- flux[pb]
    den <- cont[,1]
    if (imag[j]) {
      ewd <- sum(num/den*dl)
      ew[j] <- -2.5*log10(ewd/(wl[j,2]-wl[j,1]))
      ew_sd[j] <- sqrt(sum(num^2/den^2*(1/(ivar[pb]*num^2)+sd.cont^2/den^2)*dl^2))/
      ewd*2.5/log(10)
    } else {
      ew[j] <- sum((1-num/den)*dl)
      ew_sd[j] <- sqrt(sum(num^2/den^2*(1/(ivar[pb]*num^2)+sd.cont^2/den^2)*dl^2))
    }
  }
  in_names <- inames[which.index]
  in_err_names <- paste(in_names, "err", sep="_")
  retdat <- c(ew, ew_sd)
  names(retdat) <- c(in_names, in_err_names)
  retdat
}


context("TwoSampleMR")
library(gwasglue)

test_that("gwasvcf_to_TwoSampleMR", {
	fn <- system.file("extdata","data.vcf.gz", package="gwasvcf")
	vcf1 <- VariantAnnotation::readVcf(fn)
	exposure_dat <- gwasvcf_to_TwoSampleMR(vcf1)
	expect_true(nrow(exposure_dat) == nrow(vcf1))
})

test_that("ieugwasr_to_TwoSampleMR", {
	a <- ieugwasr::tophits("ieu-a-2")
	b <- ieugwasr::associations(a$rsid, "ieu-a-7")
	exposure_dat <- ieugwasr_to_TwoSampleMR(a)
	outcome_dat <- ieugwasr_to_TwoSampleMR(b, type="outcome")
	dat <- TwoSampleMR::harmonise_data(exposure_dat, outcome_dat)
	out <- TwoSampleMR::mr(dat)
	expect_true(nrow(exposure_dat) == nrow(dat))
	expect_true(nrow(out) > 3)
})


##### preparing Bahram prior metadata. #####
# later combined with abundance data for the prior model fits.

##### clear environment, source packages, functions and paths #####
rm(list=ls())

# devtools::install_version("lubridate", "1.6.0") # something about Red Hat Enterprise Linux 6; currently need to use older version
library(lubridate)
library(data.table)
library(rgdal)
library(raster)

#library(SRAdb)
source('paths.r')
source('NEFI_functions/worldclim2_grab.r')
source('NEFI_functions/arid_extract.r')

# set output path
metadata.output.path <- bahram_metadata.path
otu.output.path <- bahram_dada2_SV_table_rare.path #output is the otu table, subsetted by the metadata samples

##### load files ####

# SRA RunInfo table from: https://trace.ncbi.nlm.nih.gov/Traces/study/?acc=ERP021922
SRA <- read.csv(SRA.path)

# metadata file that was sent to Colin
metadata_raw <- read.csv(metadata_bahram_raw.path)

# load tedersoo mapping file
map_raw <- read.csv(ted_map_raw.path, header = TRUE, na.strings=c("", "NA"))
map_raw <- data.table(map_raw)

# load times - sent to Colin separately by Leho Tedersoo
time <- read.csv(ted_sampling_dates.path, header = TRUE, row.names=1, check.names = FALSE)
otu <- readRDS(bahram_dada2_SV_table_rare_all.samples.path) # otu table with 233 samples

##### Format metadata file #####

# combine SRA sample names with Bahram sample names.
sample_names <- SRA[,c(7,9)]
has_F <- grep('_[A-Za-z]$', levels(sample_names$Sample_Name))
levels(sample_names$Sample_Name)[has_F] <- substr(levels(sample_names$Sample_Name)[has_F],1,
                                                  nchar(levels(sample_names$Sample_Name)[has_F])-2)
metadata <- merge(sample_names, metadata_raw, by.x = "Sample_Name", by.y = "X")
metadata <- data.table(metadata)

# now merge the Bahram Run names into Tedersoo's mapping data.
map <- merge(map_raw, metadata[,1:2], by.x='tedersoo.code', by.y='Sample_Name')

#subset to northern temperate latitudes
map <- map[latitude < 66.5 & latitude > 23.5,]

#format the time data frame (get rid of an empty column, etc.)----
colnames(time)[1] <- 'human.date'
time[2] <- NULL
#convert human readable date to days since epoch
time$epoch.date <- round(
  as.numeric(
    as.POSIXlt(time$human.date,
               format = "%m/%d/%y", origin = "01/01/1970"))/86400)
#get day of year (doy) as well.
time$doy  <- lubridate::yday(as.Date(time$human.date,format='%m/%d/%Y'))
time$year <- lubridate::year(as.Date(time$human.date,format='%m/%d/%Y'))
time$epoch.date <- (time$year - 9)*365 + time$doy

#drop samples in time table not present in mapping file.
time <- time[row.names(time) %in% map$tedersoo.code,]
#push times into the mapping file
time$tedersoo.code <- rownames(time)
map <- merge(map,time, by = 'tedersoo.code', all.x=T)
map$forest <-ifelse(map$Biome %in% c('Temperate coniferous forests','Temperate deciduous forests','Dry Tropical Forests','Boreal forests'),1,0)
map$conifer <- ifelse(map$Biome %in% c('Temperate coniferous forests'),1,0)
map[grep('Pinus',Dominant.Ectomycorrhizal.host),conifer := 1]

#rename some things, subset to columns of interest.----
map$relEM <- map$Relative.basal.area.of.EcM.trees.....of.total.basal.area.of.all.AM.and.EcM.tees.taken.together.
map$Run <- as.character(map$Run)
rownames(map) <- map$Run
map <- map[,.(tedersoo.code,Run,Site,longitude,latitude,pH,Moisture,N,C,C_N,human.date,doy,epoch.date,NPP,forest,conifer,relEM,LogP,LogK,LogMg,LogCa)]
setnames(map,c('tedersoo.code','Moisture','N' ,'C' ,'C_N','LogP','LogK','LogMg','LogCa'),
         c('Mapping.ID'   ,'moisture','pN','pC','cn','P','K','Mg','Ca'))
map <- as.data.frame(map)
#get worldclim2 cliamte variables and aridity index.----
climate <- worldclim2_grab(latitude = map$latitude, longitude = map$longitude)
climate$aridity <- arid_extract(map$latitude, map$longitude)
map <- cbind(map, climate)

#subset map so that it does not include observations not in otu table.----
map <- map[map$Run %in% rownames(otu),]
otu <- otu[rownames(otu) %in% map$Run,]
otu <- otu[order(match(rownames(otu), map$Run)),]

#save output.----
saveRDS(map, metadata.output.path)
saveRDS(otu, otu.output.path)


library(coda)
library(data.table)
library(parallel)
library(stringr)

options(scipen = 100)

load('../generated/model/model-data-image.rdata', v=F)
load('../generated/model/model-fitted.rdata', v=F)

## * Turn samples to long form
mcmc <- rbindlist(lapply(1:length(codasamples), function(ch) {
    d <- data.table(codasamples[[ch]])
    d[, chain := ch]
    d[, ch_sample := 1:.N]
    return(melt(d, id.vars = c('chain', 'ch_sample')))
}))

setorder(mcmc, variable, chain, ch_sample)

mcmc[, sample := 1L:.N, variable]

## * Get meaning out of the parameters

agg_fit[,  id := 1L:.N]
agg_pred[, id := 1L:.N]

get_meaning <- function(vars, covariate = NULL) {
    ## ** Returns the covariates given the variable name
    ## ** If `covariate` is NULL, returns all the covariates as data.table, otherwise returns a vector of single given covariate

    unvars <- unique(vars)

    if (!is.null(covariate) & length(covariate) > 1)  stop('get_meaning only accepts a single covariate to be specified')
    maxdim <- max(str_count(unvars, ',')) + 1L
    vartype <- sub('\\[.*\\]', '', unvars)
    ind1 <- rep(NA_integer_, length.out = length(unvars))
    singleidx <- grepl('.*\\[([0-9]+)\\].*', unvars)
    ind1[singleidx] <- as.integer(sub('.*\\[([0-9]+)\\].*', '\\1', unvars[singleidx]))
    ind2 <- rep(NA_integer_, length.out = length(unvars))
    if (maxdim > 1) {
        firstidx  <- grepl('\\[[0-9]+,', unvars)
        ind1[firstidx] <- as.integer(sub('.*\\[([0-9]+),.*', '\\1', unvars[firstidx]))
        secondidx <- grepl('\\[[0-9]+,[0-9]+\\]', unvars)
        ind2[secondidx] <- as.integer(sub('.*,([0-9]+)\\].*', '\\1', unvars[secondidx]))
    }
    dt <- data.table(unvars, vartype, ind1, ind2)

    add_attributes <- function(vartypes, from_dat, cols=NULL) {
        if (any(vartypes %in% dt$vartype)) {
            max1 <- sapply(vartypes, function(vt) {
                if (vt %in% dt$vartype) {
                    return(dt[vartype %in% vt, max(ind1)])
                } else return(0)
            })
            if (length(unique(setdiff(max1, 0))) != 1) {
                print(max1)
                stop('Inconsistencies between vartypes')
            }
            max1 <- unique(setdiff(max1, 0))
            if ('data.table' %in% class(from_dat)) {
                if (is.null(cols)) {
                    cols <- setdiff(names(from_dat), 'id')
                }
                stopifnot(max1 == max(from_dat$id))
                for (v in cols) {
                    dt[vartype %in% vartypes, eval(v) := from_dat[match(ind1, id), get(v)]]
                }
            } else {
                stopifnot(max1 == length(from_dat))
                dt[vartype %in% vartypes, eval(cols) := from_dat[ind1]]
            }
        }
    }
    print('Captures...')
    add_attributes(c('captures_o', 'dead_captures_o', 'live_captures_o', 'loglik_dead_o', 'loglik_live_o', 'q_g_o'),
                   agg_fit,
                   c('fishery_group', 'flag', 'species_group', 'species_code', 'site', 'grid_id', 'quarter'))

    print('APF')
    add_attributes(c('apf_t', 'observable_captures_t', 'observable_captures_ident_t', 'incidents_t'),
                   agg_pred,
                   c('fishery_group', 'flag', 'species_group', 'species_code', 'role', 'site', 'grid_id', 'quarter'))

    print('identifications')
    add_attributes(c('dead_unident_o', 'live_unident_o', 'loglik_unident_dead', 'loglik_unident_live',
                     'p_live_cap', 'q_f', 'q_f0'),
                   obs_fg, 'fishery_group')

    print('N')
    add_attributes(c('ntot', 'ntot_prior'), allspp, 'species_code')

    print('Vulnerability')
    add_attributes(c('q_g', 'q_g0', 'p_survive_cap'), attr(DUMMYVAR_SPECIES_GROUP_O, 'levels'))

    #print('Interaction')
    #add_attributes(c('q_gf', 'q_gf0'), attr(DUMMYVAR_INTERACTION_O, 'levels'))

    if (dt[grep('\\[', unvars), any(apply(.SD, 1, function(x) all(is.na(x)))), .SDcols = c('ind1', 'ind2')])
        stop('Some indices not parsed properly')

    nocovs <- dt[, apply(.SD, 1, function(x) all(is.na(x))), .SDcols = setdiff(names(dt), c('unvars', 'vartype', 'ind1', 'ind2'))]

    if (any(nocovs & dt[, !(vartype %in% c('q0', 'p_identified', 'p_observable', 'lp__', grep('^log_lik', vartype, val=T)))])) {
        warning('Some variables with no associated covariates')
        print( dt[nocovs==T & !(vartype %in% c('q0', 'p_identified', 'p_observable', 'lp__', grep('^log_lik', vartype, val=T))), .N, vartype] )
    }

    dt <- dt[match(vars, unvars)]
    setnames(dt, 'unvars', 'variable')

    if (!is.null(covariate)) {
        return(dt[, get(covariate)])
    } else return(dt)

}

vars <- levels(mcmc$variable)
vars <- vars[!grepl('_s$', sub('\\[.*\\]', '', vars))]

mc_attributes <- get_meaning(vars)
mc_attributes[grid_id %in% 0, grid_id := NA]
mc_attributes[quarter   %in% 0, quarter   := NA]

mcmc_core <- mcmc[grep('^[apf|capt]', variable, invert=TRUE)]
mcsumm <- mcmc[, .(mean = mean(value),
                  min  = min(value),
                  max  = max(value),
                  lcl  = quantile(value, 0.025, names=F),
                  ucl  = quantile(value, 0.975, names=F)),
              .(variable)]
mcsumm <- merge(mcsumm, mc_attributes, on = 'variable')

save(mcmc, mcmc_core, mc_attributes, mcsumm, file='../generated/model/mcmc-results.rdata', compress=F)
saveRDS(mcsumm, file='../generated/model/mcmc-results-summary.rds', compress=F)


## Set up the scenario
library(flume)
set.seed(12345)

scales = c(0, 0.02, 0.035, 0.05, 0.075, 0.1, 0.4, 1)
for(sc in scales) {
	options(mc.cores = 4)
	cat(as.character(Sys.time()), "-- starting scale =", sc, "\n")
	nopts_sim = nopts
	nopts_sim$r_use = nopts_sim$r_use * sc
	mc = metacommunity(nsp, nr = 1, niches = niches_custom,
					   niche_args = nopts_sim, dispersal = dispersal_custom,
					   dispersal_args = dopts, comp_scale = comp)
	mod = flume(mc, net, sp0 = start_sp, st0 = start_r,
				spb = bound_sp, stb = bound_r)
	days = 3 * 365
	mod = run_simulation(mod, days, reps = 8)
	saveRDS(mod, paste0("res_ex1/model_", sc, ".rds"))
}

## floods

sc = 1
nopts_sim = nopts
nopts_sim$r_use = nopts_sim$r_use * sc
mc = metacommunity(nsp, nr = 1, niches = niches_custom,
				   niche_args = nopts_sim, dispersal = dispersal_custom,
				   dispersal_args = dopts, comp_scale = comp)
mod = flume(mc, net, sp0 = start_sp, st0 = start_r,
			spb = bound_sp, stb = bound_r)
normal_q = flood_q = state(mod$networks[[1]], "Q")
flood_q[left_trib] = 10*flood_q[left_trib]
for(i in 1:18) { ## approx 3 years, 18 2-month periods
	mod = run_simulation(mod, 60, reps = 8)
	for(j in 1:length(mod$networks)) {
		discharge(mod$networks[[j]]) = flood_q
		state(mod$networks[[j]], "species")[left_trib,] = 0
	}
	mod = run_simulation(mod, 7)
	for(j in 1:length(mod$networks)) {
		discharge(mod$networks[[j]]) = normal_q
	}
}
saveRDS(mod, paste0("res_ex1/model_", sc, "_floods.rds"))

# too much resource use just makes the disperser fail no matter what
# either the environment is poison, or the competitors manage to reduce all
# resources
sc = 0.05
nopts_sim = nopts
nopts_sim$r_use = nopts_sim$r_use * sc
mc = metacommunity(nsp, nr = 1, niches = niches_custom,
				   niche_args = nopts_sim, dispersal = dispersal_custom,
				   dispersal_args = dopts, comp_scale = comp)
bound_r_sim = bound_r
bound_r_sim[52] = 0.9*20

# relax immigration, allow from everywhere
# otherwise dispersers can't invade the polluted reach
bound_sp_sim = sweep(0 * bound_sp, 2, pdisp/2, `+`)

## test run just to see how pollution moves downstream with no consumption
mod = flume(mc, net, sp0 = start_sp, st0 = start_r,
			spb = bound_sp_sim * 0, stb = bound_r_sim)
mod = run_simulation(mod, 40, 1)
plot(mod$networks[[1]])
saveRDS(mod, paste0("res_ex1/model_pollution_only.rds"))

mod = flume(mc, net, sp0 = start_sp, st0 = start_r,
			spb = bound_sp_sim, stb = bound_r_sim)
mod = run_simulation(mod, 365*4, 8)
saveRDS(mod, paste0("res_ex1/model_pollution_species_lo_comp.rds"))

# repeat but with high competition
sc = 0.4
nopts_sim = nopts
nopts_sim$r_use = nopts_sim$r_use * sc
mc = metacommunity(nsp, nr = 1, niches = niches_custom,
				   niche_args = nopts_sim, dispersal = dispersal_custom,
				   dispersal_args = dopts, comp_scale = comp)
mod = flume(mc, net, sp0 = start_sp, st0 = start_r,
			spb = bound_sp_sim, stb = bound_r_sim)
mod = run_simulation(mod, 365*4, 8)
saveRDS(mod, paste0("res_ex1/model_pollution_species_hi_comp.rds"))


#研究t_for问题
#对不同占空比下的数据进行排列整理
#一张大图，对应一张小图，小图嵌套在大图中

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
q2<-read.xlsx("t_for.xls", sheetName = "15nl", header = TRUE)
q3<-read.xlsx("t_for.xls", sheetName = "27nl", header = TRUE)
q4<-read.xlsx("t_for.xls", sheetName = "54nl", header = TRUE)
q5<-read.xlsx("t_for.xls", sheetName = "180nl", header = TRUE)

#pdf保存
#pdf("t_for_q54.pdf")

#设定空间位置
par(mfrow = c(2,2), mar = c(4,4,2,2), oma = c(2,2,2,2))

plot(q2$fv, q2$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 125 Hz", ylab = "t_for (ms)", main = "Q = 1.5nl/min", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 125), ylim = c(0.2, 38))

#model1 = loess(q2$X0.2 ~ q2$fv, span = 1.6 , degree = 2)
lines(q2$fv, q2$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(q2$X0.3 ~ q2$fv, span = 1.6, degree = 2)
lines(q2$fv,  q2$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(q2$X0.4 ~ q2$fv, span = 1.6, degree = 2)
lines(q2$fv, q2$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(q2$X0.5 ~ q2$fv, span = 1.6, degree =2)
lines(q2$fv, q2$X0.5, col="#27408B", lwd=2, type="l")

abline(h = 5, lwd =2, col = "red", lty = 3)

legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

plot(q3$fv, q3$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 125 Hz", ylab = "t_for (ms)", main = "Q = 27nl/min", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 125), ylim = c(0.2, 30))

#model1 = loess(q3$X0.2 ~ q3$fv, span = 1.6 , degree = 2)
lines(q3$fv, q3$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(q3$X0.3 ~ q3$fv, span = 1.6, degree = 2)
lines(q3$fv,  q3$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(q3$X0.4 ~ q3$fv, span = 1.6, degree = 2)
lines(q3$fv, q3$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(q3$X0.5 ~ q3$fv, span = 1.6, degree =2)
lines(q3$fv, q3$X0.5, col="#27408B", lwd=2, type="l")
abline(h = 5, lwd =2, col = "red", lty = 3)
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

plot(q4$fv, q4$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 125 Hz", ylab = "t_for (ms)", main = "Q = 54nl/min", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 125), ylim = c(0.2, 25))

#model1 = loess(q4$X0.2 ~ q4$fv, span = 1.6 , degree = 2)
lines(q4$fv, q4$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(q4$X0.3 ~ q4$fv, span = 1.6, degree = 2)
lines(q4$fv,  q4$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(q4$X0.4 ~ q4$fv, span = 1.6, degree = 2)
lines(q4$fv, q4$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(q4$X0.5 ~ q4$fv, span = 1.6, degree =2)
lines(q4$fv, q4$X0.5, col="#27408B", lwd=2, type="l")
abline(h = 5, lwd =2, col = "red", lty = 3)
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

plot(q5$fv, q5$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 125 Hz", ylab = "t_for (ms)", main = "Q = 180nl/min", cex.lab = 1.2, cex.main = 1.3, xlim = c(0, 125), ylim = c(0.2, 20))

#model1 = loess(q5$X0.2 ~ q5$fv, span = 1.6 , degree = 2)
lines(q5$fv, q5$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(q5$X0.3 ~ q5$fv, span = 1.6, degree = 2)
lines(q5$fv,  q5$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(q5$X0.4 ~ q5$fv, span = 1.6, degree = 2)
lines(q5$fv, q5$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(q5$X0.5 ~ q5$fv, span = 1.6, degree =2)
lines(q5$fv, q5$X0.5, col="#27408B", lwd=2, type="l")
abline(h = 5, lwd =2, col = "red", lty = 3)
legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")


#script to read multipe Capital maps from asc file and create animated gif

rm(list=ls())

library(raster)
library(rasterVis)
library(gridExtra)
library(animation)
library(sf)
library(viridisLite)

fig_yrs <- c(2001, 2005, 2010, 2015) #year animation should be made for

path <- "C:/Users/k1076631/Google Drive/Shared/Crafty Telecoupling/Data/CRAFTYInput/Data/agricultureCapital/"
basefn <- "agricultureCapital"  #base filename to read
label <- "Agriculture Capital"  #use as title of plot

ras_pal <- viridis(100)  #map palette

mps <- list()   #list of plots

trim_map <- T  #shoudl the raster be trimmed? (may take some time)

#loop on fig_yrs to create list of map figures
for(i in seq_along(fig_yrs)){

  #read raster file
  mymap <- raster(paste0(path,basefn,fig_yrs[i],".asc"))

  if(trim_map) {
    print(paste0("trim ",fig_yrs[i]))
    mymap <- trim(mymap)
  }

  #create the plot
  p <- levelplot(mymap,
    col.regions=ras_pal,
    at=seq(from=0,to=1,by=0.01),
    contour=F,
    margin=F,
    main = (paste0(label, " - ", fig_yrs[i]))
  )

  #add to list
  mps[[i]] <- p

}

#create gif
saveGIF(
  for(i in seq_along(mps)){
      print(mps[[i]])
    },
  movie.name = paste0(path,basefn,"_anim",fig_yrs[1],"-",fig_yrs[length(fig_yrs)],".gif"),
    interval=2,
    loop=T
)


# user options
nox<-1; noy<-1;
paper<-F   # if output on paper (paper=T) or screen (paper=F)
cleanup()

first.year.in.mean<-2020    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2040

# Scenarios, defined further later on
scenario<-"ConstantF"
do.simulation<-T       # do the simulations and create data files for plots
do.plots<-T            # do the plots
plot.F.line<-F
include.probability<-T

legend.pos<-"topright"
max.y.axis<- 4   # maximum value for yield and SS, use -1 for value defined by data

######### end user options #########
do.HCR.batch<-function() {

#Read refence points from file reference_points.in
ref<-Read.reference.points()
blim<-ref[1,"Blim"]
bpa<-ref[1,"Bpa"]
T1<-blim
T1<-1500
T2<-bpa
T2<-2000

outdir<-file.path(data.path,scenario)

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'
prob.out<-'HCR_prob.dat'

if (do.simulation) {

  setwd(data.path)
  bio.interact<-FALSE

  #  runs are made in a separate dirictory
  copy.SMS.scenario.files(directory= scenario)

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.names<-control@species.names

  if (scenario=="ConstantF") {
    HCR@HCR[1]<-1
   # HCR@real.time[,1]<--1
   # HCR@survey[,1]<--1
   # HCR@assessment[,1]<--1
   # HCR@implementation[,1]<- -1
   # HCR@real.time[,1]<--1

    min<-0.05
    max<-0.75
    step=0.10
    xlab.title<<-'F'
    HCR.vari<-"constant.F"    # slot name to be changed for each iteration

     }

  setwd(outdir)

  write.FLSMS.control(control,file='SMS.dat')

  iterations<-seq(min,max,step)

  # headers in output files
  cat('option SSB025 SSB250 SSB500 SSB750 SSB975 \n',file=ssb.out)
  cat('option y025 y050 y500 y750 y975 \n',file=yield.out)
  cat('option F025 F050 F500 F750 F975 \n',file=F.out)
  cat('option p.T1 p.T2 \n',file=prob.out)

  iter<-0

  for (option in (iterations)) {
      iter<-iter+1

      print(paste("Iteration:",iter))

      if (HCR.vari !="") {
        slot(HCR,HCR.vari)[1,1]<-option
      }

     # if (scenario=="ConstantF) { }

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

      #run SMS
      shell(paste('"',file.path(root,"program","sms.exe"),'"'," -mceval",sep=""), invisible = TRUE)

      a<-Read.MCMC.SSB.rec.data(dir=outdir)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      #print(a)
      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=ssb.out,append=TRUE)
      cat(b[[1]],file=ssb.out,append=TRUE)
      cat('\n',file=ssb.out,append=TRUE)

      q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
      q[q>T2]<-0
      q[q>0]<-1
      p.T2<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])

      q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
      q[q>T1]<-0
      q[q>0]<-1
      p.T1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])
      cat(paste(option,p.T1,p.T2,'\n'),file=prob.out,append=TRUE)

      a<-Read.MCMC.F.yield.data(dir=outdir)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=yield.out,append=TRUE)
      cat(b[[1]],file=yield.out,append=TRUE)
      cat('\n',file=yield.out,append=TRUE)

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=F.out,append=TRUE)
      cat(b[[1]],file=F.out,append=TRUE)
      cat('\n',file=F.out,append=TRUE)
  }
}   # end do.simulations

if (do.plots) {

  setwd(outdir)
   # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.names<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  prob<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,prob)
  a<-merge(a,fi)

  if (paper) dev<-"wmf" else dev<-"screen"
  newplot(dev,nox,noy,dir=outdir,filename=paste("HCR_",sp.names,sep=''),Portrait=T);

  par(mar=c(5,4,4,5)+.1)
  s<-a$SSB500/1000
  y<-a$y500/1000
  x<-a$option
  x.lab<-xlab.title
  if (max.y.axis>0) max.y<-max.y.axis
  else max.y<-max(s,y)

  plot(x,s,ylab='SSB & Yield (1000 t)',xlab=x.lab ,ylim=c(min(s,y,0),max.y),lty=1,type='l',lwd=2)

  l.string<-c('SSB','Yield')
  l.lty<-c(1,2)
  l.pch<-"  "
  if (plot.F.line) {
    l.string<-c(l.string,'F')
    l.lty<-c(l.lty,5)
    l.pch<-paste(l.pch," ",sep='')
  }
  if (include.probability) {
    l.string<-c(l.string,paste('p(SSB<',T1,'t)'), paste('p(SSB<',T2,'t)'))
    l.lty<-c(l.lty,3,4)
    l.pch<-paste(l.pch,"12",sep="")
  }
  legend(legend.pos,l.string,pch=l.pch,lty=l.lty,lwd=rep(2,5))
  if (include.probability) lines(x,y,lty=2,lwd=2)

  par(new=T)
  if (plot.F.line) F.col<-1
  else F.col<-0

  plot(x,a$F500,axes=F,xlab=x.lab, ylab=' ',lty=5,lwd=2,,ylim=c(0,1),type='l',col=F.col)
  if (include.probability) {
    lines(x,a$p.T1,lty=3,type='b',pch="1")
    lines(x,a$p.T2,lty=4,type='b',pch="2")
    abline(h=0.05)
  }
  axis(side=4)

  mtext(side=4,line=3.0,"Probability & F")
  par(xaxs="r")

  if (paper) cleanup()

} #end do.plots

setwd(data.path)
}
do.HCR.batch()