### Digit Span Processing Script ###
### Author: James Stone ###
### Version: 1.0 ###
### For use with the digit span task available at http://www.cognitivetools.uk/ ###

#Set the working directory to the folder that holds the digit span datafiles you wish to analyse

### function that takes an output file and returns summary information for that participant
digit_span_processing <- function(data.frame) {

	#standard output form digit span has each element of a trial as a row,
	#also need to collate these into success/failure for whole trials.
	num.trials <- max(data.frame$trial.digit_span.trialNo)
	trial.load <- numeric(num.trials)
	num.corr <- numeric(num.trials)
	prop.corr <- numeric(num.trials)
	trial.success <- numeric(num.trials)

	for (i in 1:num.trials) {
		indi_trial <- data.frame$trial.digit_span.result[data.frame$trial.digit_span.trialNo == i]
		numDigits <- length(indi_trial)
		numCorr <- sum(indi_trial == "success")
		trial.success[i] <- numDigits == numCorr
		trial.load[i] <- numDigits
		num.corr[i] <- numCorr
		prop.corr[i] <- numCorr / numDigits
	}
	#make that a data.frame
	wholeTrialSuccess <- as.data.frame(cbind(trial.load,num.corr,prop.corr,trial.success))
	wholeTrialSuccess <- transform(wholeTrialSuccess, score = trial.load * trial.success)

	#highest load with a fully correct response
	if (length(wholeTrialSuccess$trial.load[wholeTrialSuccess$trial.success == 1]) == 0) {
		#no successes
		max.span <- NA
	} else {
		max.span <- max(wholeTrialSuccess$trial.load[wholeTrialSuccess$trial.success == 1])
	}

	#total number of words correctly recalled in correct serial position throughout
	number.successes <- sum(data.frame$trial.digit_span.result == "success")
	#span two trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 2)) == 0) {
		#then there were no span size 2 trials, therefore
		span.2.corr <- NA
	} else {
		span.2.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 2])
	}
	#span three trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 3)) == 0) {
		#then there were no span size 3 trials, therefore
		span.3.corr <- NA
	} else {
		span.3.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 3])
	}
	#span four trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 4)) == 0) {
		#then there were no span size 4 trials, therefore
		span.4.corr <- NA
	} else {
		span.4.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 4])
	}
	#span five trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 5)) == 0) {
		#then there were no span size 5 trials, therefore
		span.5.corr <- NA
	} else {
		span.5.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 5])
	}
	#span six trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 6)) == 0) {
		#then there were no span size 6 trials, therefore
		span.6.corr <- NA
	} else {
		span.6.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 6])
	}
	#span seven trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 7)) == 0) {
		#then there were no span size 7 trials, therefore
		span.7.corr <- NA
	} else {
		span.7.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 7])
	}
	#span eight trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 8)) == 0) {
		#then there were no span size 8 trials, therefore
		span.8.corr <- NA
	} else {
		span.8.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 8])
	}
	#span nine trials correct
	if (nrow(subset(wholeTrialSuccess, trial.load == 9)) == 0) {
		#then there were no span size 9 trials, therefore
		span.9.corr <- NA
	} else {
		span.9.corr <- sum(wholeTrialSuccess$trial.success[wholeTrialSuccess$trial.load == 9])
	}

	#calculate a full-trial-accuracy score
	fta.score <- sum(wholeTrialSuccess$score)
	prop.score <- mean(wholeTrialSuccess$prop.corr)
	median.rt <- median(data.frame$trial.digit_span.durationTime)
	user.name <- data.frame$user.name[1]

	p.summary <- c(fta.score, prop.score, number.successes, median.rt, max.span,
	span.2.corr, span.3.corr, span.4.corr, span.5.corr, span.6.corr, span.7.corr, span.8.corr,
	span.9.corr)

	return(p.summary)
}

##now can use that function on all our data files for digit span
#put all digit span files into one folder and set that folder as working directory

compile_digit_span_data <- function() {
	multiple.sessions <- character()
	filenames <- list.files()
    digit.span.data <- matrix(nrow=length(filenames), ncol=13)
	user <- character()

	for (i in 1:length(filenames)) {
		tmp.df <- read.csv(filenames[i])
		user[i] <- toString(tmp.df$user.name[1])

		if (length(unique(tmp.df$session.id)) > 1) {
			multiple.sessions[length(multiple.sessions) + 1] <- filenames[i]
		}

		tmp.ds.summary <- digit_span_processing(tmp.df)

		digit.span.data[i, ] <- tmp.ds.summary
	}

    digit.span.data <- as.data.frame(digit.span.data)
	digit.span.data$user <- user

	ds.names <- c("fta.score", "prop.score", "number.successes", "median.rt", "max.span",
	"span.2.corr", "span.3.corr", "span.4.corr", "span.5.corr", "span.6.corr", "span.7.corr",
	"span.8.corr", "span.9.corr", "user")

	names(digit.span.data) <- ds.names

	if (length(multiple.sessions > 0)) {
		cat("The following files contained trials with more than one session id: \n", multiple.sessions)
	}

	return(digit.span.data)
}

digit.span.data <- compile_digit_span_data()

rm(compile_digit_span_data, digit_span_processing)


REBOL [
	System: "REBOL [R3] Language Interpreter and Run-time Environment"
	Title: "REBOL 3 Mezzanine: Debug"
	Rights: {
		Copyright 2012 REBOL Technologies
		REBOL is a trademark of REBOL Technologies
	}
	License: {
		Licensed under the Apache License, Version 2.0
		See: http://www.apache.org/licenses/LICENSE-2.0
	}
]

dt: delta-time: funct [
	{Delta-time - returns the time it takes to evaluate the block.}
	block [block!]
][
	start: stats/timer
	do block
	stats/timer - start
]

dp: delta-profile: func [
	{Delta-profile of running a specific block.}
	block [block!]
	/local start end
][
	start: values-of stats/profile
	do block
	end: values-of stats/profile
	foreach num start [
		change end end/1 - num
		end: next end
	]
	start: make system/standard/stats []
	set start head end
	start
]

speed?: funct [
	"Returns approximate speed benchmarks [eval cpu memory file-io]."
	/no-io "Skip the I/O test"
	/times "Show time for each test"
][
	result: copy []
	foreach block [
		[
			loop 100'000 [
				; measure more than just loop func
				; typical load: 1 set, 2 data, 1 op, 4 trivial funcs
				x: 1 * index? back next "x"
				x: 1 * index? back next "x"
				x: 1 * index? back next "x"
				x: 1 * index? back next "x"
			]
			calc: [100'000 / secs / 100] ; arbitrary calc
		][
			tmp: make binary! 500'000
			insert/dup tmp "abcdefghij" 50000
			loop 10 [
				random tmp
				decompress compress tmp
			]
			calc: [(length? tmp) * 10 / secs / 1900]
		][
			repeat n 40 [
				change/dup tmp to-char n 500'000
			]
			calc: [(length? tmp) * 40 / secs / 1024 / 1024]
		][
			unless no-io [
				write file: %tmp-junk.txt "" ; force security request before timer
				tmp: make string! 32000 * 5
				insert/dup tmp "test^/" 32000
				loop 100 [
					write file tmp
					read file
				]
				delete file
				calc: [(length? tmp) * 100 * 2 / secs / 1024 / 1024]
			]
		]
	][
		secs: now/precise
		calc: 0
		recycle
		do block
		secs: to decimal! difference now/precise secs
		append result to integer! do calc
		if times [append result secs]
	]
	result
]


# set root directory
AVLROOT <- "."

commandlineargs <- commandArgs(TRUE)

nfields <- 5
filenames <- vector(length=nfields)

# legend for use in plot
legends <- vector(length=n)
# first nfields command line arguments are file names
for(i in 1:nfields) {
    filenames[i] <- commandlineargs[i]
    legends[i] <- paste("field ", i, sep="") # set nth legend to field number
}
# then the next is the parameter that was being varied
param <- commandlineargs[nfields+1]

#print(filenames)

# set x labels for different parameters
labels <- list(depth="Max depth of mobile BCBPs", rel_force_mean="Mean relative force")

# open pdf file
pdf(file=paste("pvals_", param, "_combined_fields.pdf", sep=""))

colours_init <- rainbow(n)

# get maximum and minimum x-values and y-values for plotting
n <- length(filenames)
tables <- list()  # initialise a list of tables for reuse later
minx <- NA
maxx <- NA
miny <- NA
maxy <- NA
for(j in 1:n) {
	file <- filenames[j]
        path <- sprintf("%s/%s", AVLROOT, file)
        #print(path)
	table <- read.table(path, header=TRUE)
        local_minx <- min(as.numeric(row.names(table)))
        if(is.na(minx) || local_minx < minx) {
            minx <- local_minx
        }
        local_maxx <- max(as.numeric(row.names(table)))
        if(is.na(maxx) || local_maxy > maxx) {
            maxx <- local_maxx
        }
        local_miny <- min(table$pBCBCBP)
        if(is.na(miny) || local_miny < miny) {
            miny <- local_miny
        }
        local_maxy <- max(table$pBCBCBP)
        if(is.na(maxy) || local_maxy > maxy) {
            maxy <- local_maxy
        }
        tables[[j]] <- table
}

#print(minx)
#print(maxx)
#print(miny)
#print(maxy)

first <- TRUE
for(k in 1:n) {
    table <- tables[[k]]
    x <- row.names(table)  # range of values of 'param' for this field
    y <- table$pBCBCBP  # range of p values for this field
    if(!first) {
        par(new=TRUE)  # plot on same graph
        plot(x, y, type="l", lty=k%%6, lwd=3, col=colours[k],
             xlab=labels[[param]], ylab="Cross p value",
             xlim=c(minx, maxx), ylim=c(miny, maxy))
    } else {
        plot(x, y, type="l", lty=k%%6, lwd=3, col=colours[k],
             xlab=NULL, ylab=NULL, # stop r superimposing 'x' and 'y' on labels
             xlim=c(minx, maxx), ylim=c(miny, maxy),
             main=paste("Sensitivity to ", param, ", all fields", sep=""))
        first <- FALSE
    }
}

legend(x="topright", legend=legends, col=colours, lty=1:n)

dev.off()


library("gplots");
drawmarker <- function(filename, outname)
{
filename;
outname;
	read.table(filename, sep="\t", header=TRUE) -> t
	t2 = t[,seq(4, length(t))]
	t2[is.na(t2)] = 0
	t3 = as.matrix(t2)
	per = paste("Percent = ", format((length(t3[t3==1]) / length(t3) * 100), digits = 2, nsmall=2), "%")
	c = gray((max(t3) + 1) : 0 / (max(t3) + 1))
	pdf(outname);
	heatmap.2(t3, margins=c(5,10), dendrogram="none", trace="none", density.info=c("none"), Rowv = FALSE, Colv = FALSE, col=c)
	text(0.5, 0.9, per)
	dev.off()
}

args <- commandArgs(TRUE);
drawmarker(args[1], args[2])


library(RODBC)
library(arules)
require(arulesViz)

ch <- odbcConnect("DBM_SANDBOX", believeNRows=FALSE)
nzdata <- sqlQuery(ch, paste("
SELECT B.TRANSACTION_ID,
	   MAX(CASE WHEN ROWNUM = 1 THEN B.CLASS ELSE NULL END) AS CLASS1,
     MAX(CASE WHEN ROWNUM = 2 THEN B.CLASS ELSE NULL END) AS CLASS2,
     MAX(CASE WHEN ROWNUM = 3 THEN B.CLASS ELSE NULL END) AS CLASS3,
     MAX(CASE WHEN ROWNUM = 4 THEN B.CLASS ELSE NULL END) AS CLASS4,
     MAX(CASE WHEN ROWNUM = 5 THEN B.CLASS ELSE NULL END) AS CLASS5,
     MAX(CASE WHEN ROWNUM = 6 THEN B.CLASS ELSE NULL END) AS CLASS6,
     MAX(CASE WHEN ROWNUM = 7 THEN B.CLASS ELSE NULL END) AS CLASS7,
     MAX(CASE WHEN ROWNUM = 8 THEN B.CLASS ELSE NULL END) AS CLASS8,
     MAX(CASE WHEN ROWNUM = 9 THEN B.CLASS ELSE NULL END) AS CLASS9,
     MAX(CASE WHEN ROWNUM = 10 THEN B.CLASS ELSE NULL END) AS CLASS10,
     MAX(CASE WHEN ROWNUM = 11 THEN B.CLASS ELSE NULL END) AS CLASS11,
     MAX(CASE WHEN ROWNUM = 12 THEN B.CLASS ELSE NULL END) AS CLASS12,
     MAX(CASE WHEN ROWNUM = 13 THEN B.CLASS ELSE NULL END) AS CLASS13,
     MAX(CASE WHEN ROWNUM = 14 THEN B.CLASS ELSE NULL END) AS CLASS14,
     MAX(CASE WHEN ROWNUM = 15 THEN B.CLASS ELSE NULL END) AS CLASS15
     FROM (
     SELECT A.TRANSACTION_ID,
     A.SKU_DISPLAY_NUMBER || ' - ' || A.SKU_NAME AS CLASS,
     A.SALES,
     ROW_NUMBER() OVER(PARTITION BY A.TRANSACTION_ID ORDER BY A.SALES DESC) AS ROWNUM
     FROM (
     SELECT SH.INBOUND_INTERACTION_KEY AS TRANSACTION_ID,
     PD.SKU_DISPLAY_NUMBER,
     PD.SKU_NAME,
     SUM(SD.SALES_PRICE) AS SALES
     FROM EDW_SPOKE..FACT_BPS_SALES_HEADER SH
     JOIN EDW_SPOKE..FACT_BPS_SALES_DETAIL SD ON SH.INBOUND_INTERACTION_KEY = SD.SH_INBOUND_INTERACTION_KEY
     JOIN EDW_SPOKE..DIM_STORE ST ON SD.STORE_MEMBER_KEY = ST.MEMBER_KEY
     JOIN EDW_SPOKE..DIM_DATE DT ON SH.TRANSACTION_DATE_KEY = DT.DATE_KEY
     JOIN EDW_SPOKE..DIM_PRODUCT_BPS PD ON SD.SALES_PRODUCT_MEMBER_KEY = PD.MEMBER_KEY
     WHERE DT.FISCAL_YEAR >= 2016
     AND ST.CHANNEL_GROUP IN ('DIRECT','RETAIL')
     AND PD.SKU_DISPOSITION_CODE IN ('A','N')
     AND SD.RETURN_FLAG <> 'Y'
     AND SD.ACTUAL_SALE_FLAG = 'Y'
     AND PD.SUB_DEPARTMENT_DISPLAY_NUMBER <> '0700-0740'
     AND PD.DEPARTMENT_MEMBER_NUMBER NOT IN (875, 999)
     GROUP BY 1,2,3
     ORDER BY 1,3 DESC
     ) AS A
     ) AS B
     GROUP BY 1
     HAVING CLASS2 IS NOT NULL
     "))

nzdata$TRANSACTION_ID <- NULL
tData <- as (nzdata, 'transactions')
size(head(tData))
LIST(head(tData, 3))

frequentItems <- eclat(tData, parameter = list(supp = 0.0001, minlen = 2))
inspect(head(frequentItems))

itemFrequencyPlot(tData, topN=10, type='absolute', main='Item Frequency')

item <- 'CLASS1=1620147 - 360 QUALIFIER BACKPACK'

rules <- apriori(tData, parameter = list(supp=0.00001, conf=0.15, minlen = 2, maxtime=10),
                 appearance=list(default='lhs', rhs=item),
                 control = list(verbose=F))
rules_conf <- sort(rules, by='confidence', decreasing=TRUE)
inspect(head(rules_conf))

plot(rules)

plotly_arules(rules)
inspectDT(rules)


#This function formats a dataframe into a jags data object.
#N in your model must be the number of observations.

jd_format <- function(y,preds){
  #make sure y is not a data.table
  if(is.data.table(y) == T){ y <- as.data.frame(y)}
  #subset to complete cases.
  all <- cbind(y,preds)
  all <- all[complete.cases(all),]
  y <- all[,1]
  y <- as.vector(y)
  preds <- all[,-1]
  #assign fixed effects to objects x1 -> xn
  colnames(preds)  <- paste0('x', 1:(ncol(preds)))
  jd <- as.list((preds))

  #Get jags data object together.
  pre.list <- list(y=y, N = length(y))
  jd <- c(pre.list, as.list(preds))
  return(jd)
}


###### Baseline Policies  #######
# default policy options that does not require activation, identify the baseline

## current policies in India on solar energy
# use share equations
shares.set = c( shares.set, 'solar_electricity' )

type_tec.set = c(type_tec.set,'share_total','share_solar')

power_tec = (cat_tec.set %>% filter(type_tec == 'power' & !grepl('trs|distribution|ethanol|genset|biom|wind|geothermal',tec)) )$tec

cat_tec.set = cat_tec.set %>% bind_rows(data.frame(type_tec = 'share_total',
                                               tec = power_tec),
                                        data.frame(type_tec = 'share_solar',
                                                   tec = power_tec[grepl('solar',power_tec)]))

node_share.tmp = map_node.set %>% filter(node1 %in% c('IND') & !node2 %in% c('IND')) %>%
  rename(node_share = node1, node = node2)
map_shares_commodity_total.set = crossing(data.frame(shares = 'solar_electricity',
                                          type_tec = 'share_total',
                                          mode = factor(c(1,2,3,4)),
                                          commodity = 'electricity',
                                          level = 'energy_secondary'),
                                          node_share.tmp ) %>%
  dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)

map_shares_commodity_share.set = crossing(data.frame(shares = 'solar_electricity',
                                                     type_tec = 'share_solar',
                                                     mode = factor(c(1,2,3,4)),
                                                     commodity = 'electricity',
                                                     level = 'energy_secondary'),
                                          node_share.tmp ) %>%
  dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)

share_commodity_lo.par = crossing(data.frame(shares = 'solar_electricity',
                                             node_share = node_share.tmp$node_share,
                                             unit = '%'),
                                  crossing(data.frame(year_all = as.factor(c(2020, 2030, 2040, 2050, 2060)),
                                                      value =    c(0.1,  0.2,  0.2,  0.2,  0.2)),
                                           time = time) ) %>%
  dplyr::select(shares,node_share,year_all,time,value)

# boundaries on surface water matching historical
tmp3 = historical_new_capacity.par %>%
  filter(grepl('irrigation_sw_diversion',tec)) %>% filter(year_all < 2020) %>%
  group_by(node,tec,year_all) %>%
  summarise(value = sum(value)) %>% ungroup() %>%
  filter( !grepl('AFG|CHN',node)  )

# force water diversion in 2020 to be as calibration ONLY in 2020
bound_total_capacity_lo.par = rbind(bound_total_capacity_lo.par,
                                    crossing(tmp3 %>% select(-year_all),
                                             year_all = '2020') %>%
                                      select(node,tec,year_all,value)  )

bound_total_capacity_up.par = rbind(bound_total_capacity_up.par,
                                    crossing(tmp3 %>% select(-year_all),
                                             year_all = '2020' ) %>%
                                      mutate(value = 1.05 * value) %>%
                                      select(node,tec,year_all,value)  )

###### Baseline Policies  #######
# Policies that require activation

# ## Reduced fresh surface runoff into system from high elevation sources due to climate change
# # Used to simulate more extreme impacts than projected in the hydrological model/output/
# # A fraction of the run off is reduced in the upstream parts of the basin considered to be mountain regions
# # Exponential function that saturates at an assumed percentrage decrease relaive to the hydrological model
fraction_reduction = 0.5
saturation_year = 2050
saturation_rate = -1 * log( 0.1 ) / ( saturation_year - baseyear )
fraction_value = fraction_reduction * ( 1 - exp( -1 * saturation_rate * ( year_all[ year_all > baseyear ] - baseyear ) ) )
fdf = data.frame( year_all = year_all[ year_all >= baseyear ], frc = c( 0, fraction_value ) )
fdf$frc = fdf$frc * fraction_reduction / fdf$frc[ which( fdf$year_all == saturation_year ) ]
mountain_nodes = c( bcus[ grepl( 'IND|CHN|AFG', bcus ) ], 'PAK_7', 'PAK_8', 'PAK_11', 'PAK_13')

frc = c(0.2,0.2,0.2,0.5,0.8, 0.9, 0.9, 0.8, 0.6, 0.5, 0.4, 0.3)
fdf.df = data.frame(time = time,frc = as.numeric(frc), stringsAsFactors = F)
if (!REDUCE_RUNOFF){}else{
	demand.par = demand.par %>% left_join(fdf.df ) %>%
		mutate( value = if_else( level == 'inflow', value * (1-frc), value ) ) %>%
		dplyr::select( -frc )
	}

## Indus water treaty
if (IND_TREAT){

	# Get upstream nodes in India
	policy_nodes = as.character( basin.spdf@data$PID[ which( basin.spdf@data$type_1 %in% c('Upper_Indus','Shyok','Jhelum','Chenab') &  basin.spdf@data$REGION != 'pakistan' ) ] )
	policy_nodes = policy_nodes[ -1*which( grepl( 'CHN', policy_nodes ) ) ]

	# Constrain closed loop and once through energy withdrawals to zero in all upstream basins outside Pakistan considered in the treaty
	# Also limit new hydro plants
	tec2limit = technology.set[ grepl( '_ot|_cl|hydro_river|hydro_canal', technology.set ) ]
	bound_total_capacity_up.par = rbind( bound_total_capacity_up.par, do.call( rbind,  lapply( tec2limit, function( tt ){

		do.call( rbind, lapply( policy_nodes, function( rr ){

			data.frame( node = rep( rr, length( year_all[ which( year_all > baseyear ) ] ) ),
						tec = rep( tt,length( year_all[ which( year_all > baseyear ) ] ) ),
						year_all = as.character(year_all[ which( year_all > baseyear ) ]),
						value = rep(1e-6,length( year_all[ which( year_all > baseyear ) ] ) ) )

				} ) )

			} ) )

		)

	# Constrain irrigated area from Annex C in Treaty document
	# 70,000 acres max in Indus
	# 400,000 acres max in Jhelum
	# 225,000 acres max  in Chenab
	land_constraint.df = data.frame( 	IND_5 = 35000, # Indus
										IND_6 = 35000, # Indus
										IND_1 = 400000, # Jhelum
										IND_2 = 225000 ) * 0.404 / 1e6 # Chenab - convert to Mha

	# Simplified approach: Bound irrigation withdrawals to historical levels in the sub-basins of India impacted by the policy
	historical_capacity.df1 = hist_new_cap.df
	bound_total_capacity_up.par = bind_rows( bound_total_capacity_up.par,

		bind_rows( lapply( year_all[ year_all > baseyear ], function( yyy ){

			historical_capacity.df1 %>%
				filter( tec == 'irrigation_sw_diversion', node %in% policy_nodes ) %>%
				group_by( node, tec ) %>%
				summarise( value = sum( value ) + 1e-6 ) %>%
				ungroup() %>% data.frame() %>%
				mutate( year_all = as.character(yyy) ) %>%
				dplyr::select( node, tec, year_all, value )

			} ) )

		)

	# Divert Ravi / Sutlej flows to represent transfers outside the basin through canals such as Indira Ghandhi
	# Note that some diversions are already included in the irrigation representation
	# See Wescoat et al. 2018 figure 3
	# Get upstream nodes in India
	policy_nodes = as.character( basin.spdf@data$PID[ which( basin.spdf@data$type_2 == 'eastern_rivers' &  basin.spdf@data$REGION != 'pakistan' ) ] )
	policy_nodes = policy_nodes[ -1*which( grepl( 'CHN', policy_nodes ) ) ]
	bound_activity_up.par = bind_rows( bound_activity_up.par,
		bind_rows( lapply( policy_nodes, function( nnn ) {
			expand.grid( 	node = nnn,
							tec = paste0( 'river|',nnn,'|',basin.spdf@data$DOWN[ which( basin.spdf@data$PID == nnn ) ] ),
							year_all = as.character(year_all),
							mode = c('1'),
							time = as.character( time ),
							value = 3.5 ) # approx. 1 MAF  per yearconverted to MCM per day - Note Wescoat et al 2018 show declining flows to ~ 1 MAF per year
			} ) )
	)

	# Remove inconsistent activity bounds from environmental flows
	bound_activity_lo.par = bound_activity_lo.par %>% filter( !(node %in% policy_nodes & tec == 'environmental_flow') )

	# Remove opportunity to expand conveyance out of eastern rivers PIDs to other basin PIDs
	# Allow transferring between eastern river Pid but disallow transfers out to other PIDs e.g., to PAK and CHN.
	tlim = technology.set[ grepl( c('lined_canal|conv_canal'), technology.set ) ]
	tlim = tlim[ grepl( paste( policy_nodes, collapse = '|' ), tlim ) ]
	tlim = unlist( c( sapply( policy_nodes, function( nnn ){ tlim[ grepl( nnn, unlist( strsplit( tlim, '[|]' ) )[seq(2,3*length(tlim),by=3)] ) & !( grepl( paste( policy_nodes, collapse = '|' ), unlist( strsplit( tlim, '[|]' ) )[seq(3,3*length(tlim),by=3)] ) ) ] } ) ) )
	bound_total_capacity_up.par	= bind_rows( bound_total_capacity_up.par,
		bind_rows( lapply( tlim, function( ttt ){
			expand.grid(	node = unlist( strsplit( ttt, '[|]' ) )[ 2 ],
							tec = tlim,
							year_all = as.character(year_all[year_all>baseyear]),
							value = 1e-6 )
			} ) )
		)

	} #end if

## Environmental flows (EF)
# Indus can't be transformed to naturalized conditions so better to focus on improving EFs instead of basis on natural flows
# see: Acreman et al "Environmental flows for natural, hybrid, and novel riverine ecosystems in a changing world"
if (sc == 'environment'){fractional_increment_ef = 2
} else if (sc == 'economy'){
fractional_increment_ef = 0.5
} else {
  fractional_increment_ef = 1
}
if ( ENV_FLOWS & sc != baseline0 ){

	# Import baseline0 solution from gdx
	igdx( gams_path )
	upath = paste( indus_ix_path, '/model/output/', sep='')
	fpath = paste( 	'MSGoutput_', baseline0, '.gdx', sep = '' )
	vv = c('ACT')
	tmp = rgdx( paste( upath, fpath, sep = '' ), list( name = vv, form = "sparse" ) )
	names(tmp$uels) = tmp$domains
	rs = data.frame( tmp$val )
	names(rs) = c( unlist( tmp$domains ), 'value' )
	rs[ , which( names(rs) != 'value' ) ] = do.call( cbind, lapply( names( rs )[ which( names(rs) != 'value' ) ], function( cc ){
		sapply( unlist( rs[ , cc ] ) , function(ii){ return( tmp$uels[[ cc ]][ ii ] ) } )
		} ) )
	rs = rs %>% filter( tec == 'environmental_flow' ) %>%
	  mutate( value = value * ( 1 + fractional_increment_ef )) %>%
	  select(node,tec,year_all,mode,time,value)
	rm( tmp )

	value_by_time =  data.frame(val = c(12.23, 12.23, 12.23, 46.21, 46.21 ,46.21, 46.21, 46.21, 46.21, 12.23, 12.23, 12.23),
	                            time = as.character(seq(1,12,1)), stringsAsFactors = F )

	pak_4_pol = environmental_flow.df %>% mutate(tec = 'environmental_flow',mode = c('1'),time = as.character(time),year_all = as.character(year_all)) %>%
	  filter(node %in% c('PAK_4'), year_all >2015) %>% left_join(value_by_time) %>%
	  mutate(value = val) %>%  ungroup() %>% # already in MCM
	  dplyr::select(node,tec,year_all,mode,time,value) %>%
	  left_join(rs %>% rename(base_val = value)) %>%
	  mutate(base_val = if_else(is.na(base_val), 0, base_val) ) %>%
	  mutate(value = pmax(value,base_val)) %>%
	  select(node,tec,year_all,mode,time,value)

	bound_activity_lo.par = rbind( bound_activity_lo.par, pak_4_pol   )

	}

## No planned hydropower
if (!NOT_PLANNED_HYDRO){} else {

	bound_total_capacity_lo.par =  rbind(
		bound_total_capacity_lo.par %>% filter( tec != 'hydro_old' ),
		bound_total_capacity_lo.par %>% filter(tec == 'hydro_old') %>%
			group_by( node, tec ) %>%
			mutate( value = min(value) ) %>%
			as.data.frame( )
		)

	bound_total_capacity_up.par =  rbind(
		bound_total_capacity_up.par %>% filter( tec != 'hydro_old' ),
		bound_total_capacity_up.par %>% filter(tec == 'hydro_old') %>%
			group_by( node, tec ) %>%
			mutate( value = min(value) ) %>%
			as.data.frame( )
		)

	bound_storage_up.par = bound_storage_up.par %>%
		group_by(node,commodity,level,time) %>%
		mutate(value = min(value)) %>%
		as.data.frame( )

	bound_storage_lo.par = bound_storage_lo.par %>%
		group_by(node,commodity,level,time) %>%
		mutate(value = min(value)) %>%
		as.data.frame( )

	} #end if

## Water access and treatment rates for SDG6 targets
if (SDG6 & sc != baseline0){

	tmp = rbind(
	  # Urban piped water access
		do.call( rbind, lapply( nds, function( nnn ){

			ww = demand.df %>% filter( node == nnn, level == 'urban_final', commodity == 'freshwater' )%>%
					dplyr::rename( demand = value )

			fr = basin_water_connections.df %>% filter( PID == nnn ) %>%
					dplyr::select( year, urban_connection_rate ) %>%
					dplyr::rename( year_all = year )

			df = merge( ww, fr, by = 'year_all', all.x=TRUE ) %>%
					mutate( value = abs( round( demand * urban_connection_rate, digits = 2 ) ) ) %>%
					mutate( mode = 1 ) %>%
					dplyr::select( node, year_all, mode, time, value  )

			return( df )

			} ) ) %>% mutate(tec = 'urban_piped_distribution') %>% dplyr::select( node, tec, year_all, mode, time, value ),

		# Rural piped water access
		do.call( rbind, lapply( nds, function( nnn ){

					ww = demand.df %>% filter( node == nnn, level == 'rural_final', commodity == 'freshwater' )%>%
							dplyr::rename( demand = value )

					fr = basin_water_connections.df %>% filter( PID == nnn ) %>%
							dplyr::select( year, rural_connection_rate ) %>%
							dplyr::rename( year_all = year )

					df = merge( ww, fr, by = 'year_all', all.x=TRUE ) %>%
							mutate( value = abs( round( demand * rural_connection_rate, digits = 2 ) ) ) %>%
							mutate( mode = 1 ) %>%
							dplyr::select( node, year_all, mode, time, value  )

					return( df )

					} ) ) %>% mutate(tec = 'rural_piped_distribution') %>% dplyr::select( node, tec, year_all, mode, time, value ),

		# Urban wastewater treatment rate
		do.call( rbind, lapply( nds, function( nnn ){

			ww = demand.df %>% filter( node == nnn, level == 'urban_final', commodity == 'wastewater' )%>%
					dplyr::rename( demand = value )

			fr = basin_water_connections.df %>% filter( PID == nnn ) %>%
					dplyr::select( year, urban_treated_rate ) %>%
					dplyr::rename( year_all = year )

			df = merge( ww, fr, by = 'year_all', all.x=TRUE ) %>%
					mutate( value = abs( round( demand * urban_treated_rate, digits = 2 ) ) ) %>%
					mutate( mode = 1 ) %>%
					dplyr::select( node, year_all, mode, time, value  )

			return( df )

			} ) ) %>% mutate(tec = 'urban_wastewater_collection') %>% dplyr::select( node, tec, year_all, mode, time, value ),

		# Industry wastewater treatment rate
		do.call( rbind, lapply( nds, function( nnn ){

			ww = demand.df %>% filter( node == nnn, level == 'industry_final', commodity == 'wastewater' )%>%
					dplyr::rename( demand = value )

			fr = basin_water_connections.df %>% filter( PID == nnn ) %>%
					dplyr::select( year, urban_treated_rate ) %>%
					dplyr::rename( year_all = year )

			df = merge( ww, fr, by = 'year_all', all.x=TRUE ) %>%
					mutate( value = abs( round( demand * urban_treated_rate, digits = 2 ) ) ) %>%
					mutate( mode = 1 ) %>%
					dplyr::select( node, year_all, mode, time, value  )

			return( df )

			} ) ) %>% mutate(tec = 'industry_wastewater_collection') %>% dplyr::select( node, tec, year_all, mode, time, value ),

		# Rural wastewater treatment rate
		do.call( rbind, lapply( nds, function( nnn ){

			ww = demand.df %>% filter( node == nnn, level == 'rural_final', commodity == 'wastewater' )%>%
					dplyr::rename( demand = value )

			fr = basin_water_connections.df %>% filter( PID == nnn ) %>%
					dplyr::select( year, rural_treated_rate ) %>%
					dplyr::rename( year_all = year )

			df = merge( ww, fr, by = 'year_all', all.x=TRUE ) %>%
					mutate( value = abs( round( demand * rural_treated_rate, digits = 2 ) ) ) %>%
					mutate( mode = 1 ) %>%
					dplyr::select( node, year_all, mode, time, value  )

			return( df )

			} ) ) %>% mutate(tec = 'rural_wastewater_collection') %>% dplyr::select( node, tec, year_all, mode, time, value )

		) %>% mutate(year_all = as.character(year_all), mode = as.character(mode))
	bound_activity_lo.par = bind_rows( bound_activity_lo.par, tmp)
	## Wastewater recycling
	# Constrain wastewater recycling to at least X % urban return flow
	tmp = rbind(

		do.call( rbind, lapply( node[ node != basin ], function( nnn ){

			do.call( rbind, lapply( year_all[ which( year_all > baseyear ) ], function( yyy ){

				do.call( rbind, lapply( time, function( mmm ){

					data.frame( node = nnn,
								tec = 'urban_wastewater_recycling',
								year_all = yyy,
								mode = 1,
								time = as.character( mmm ),
								value = abs( round( 	0.25 * min( 	0,
															demand.par %>%
																dplyr::filter( node == nnn, commodity == 'wastewater', level == 'urban_final', year_all == yyy, time == mmm ) %>%
																dplyr::select( value ) %>% unlist() ,
															na.rm = TRUE ), digits = 3 ) ) )

					} ) )

				} ) )

			} ) ),

		do.call( rbind, lapply( node[ node != basin ], function( nnn ){

			do.call( rbind, lapply( year_all[ which( year_all > baseyear ) ], function( yyy ){

				do.call( rbind, lapply( time, function( mmm ){

					data.frame( node = nnn,
								tec = 'industry_wastewater_recycling',
								year_all = yyy,
								mode = 1,
								time = as.character( mmm ),
								value = abs( round( 	0.25 * min( 	0,
															demand.par %>%
																dplyr::filter( node == nnn, commodity == 'wastewater', level == 'industry_final', year_all == yyy, time == mmm ) %>%
																dplyr::select( value ) %>% unlist() ,
															na.rm = TRUE ), digits = 3 ) ) )

					} ) )

				} ) )

			} ) )

		)
	tmp = tmp %>% mutate_if(!sapply(tmp, is.character), as.character) %>%
	  mutate(value = as.numeric(value))
	bound_activity_lo.par = bind_rows( bound_activity_lo.par, tmp)

	## WHAT BEFORE WE CALLED SURFACE_ALLOCATION
	# allocation_reduction = 3
	## Maintain surface withdrawal capacity to limit expanded surface allocation (surface water fully allocated in Indus ie.., no room for expanded use)

	  # Get the historical capacity of surface water diversions and then bound total capacity of sw_extract to prevent further expansion
	  historical_capacity.df1 = hist_new_cap.df
	  sw_extract_cap.df = historical_capacity.df1 %>%
	    filter( grepl( 'sw_diversion', tec ) ) %>%
	    filter(node != 'PAK_13') %>%
	    group_by( node ) %>%
	    summarise( value = sum(value) * 1) %>%
	    as.data.frame( )

	  # gw_extract_agri_cap.df = historical_capacity.df1 %>%
	  #   filter( grepl( 'irrigation_gw_diversion', tec ) ) %>%
	  #   filter(node != 'PAK_13') %>%
	  #   group_by( node ) %>%
	  #   summarise( value = sum(value) * allocation_reduction) %>%
	  #   as.data.frame( ) %>%
	  #   crossing(year_all =  c('2030','2040','2050')) %>%
	  #   mutate( tec = 'irrigation_gw_diversion' ) %>%
	  #   dplyr::select( names( bound_total_capacity_up.par )) %>%
	  #   mutate(value = if_else((node == 'IND_1' & year_all == 2050), value +2 ,
	  #                      if_else((node == 'IND_2' & year_all == 2050), value +3 ,
	  #                          if_else((node %in% c('PAK_5','PAK_12','PAK_9') & year_all == 2050), value + 10 ,
	  #                              if_else((grepl('PAK_',node) & year_all == 2050), value * 1.5 ,
	  #                                 if_else((node %in% c('IND_5','IND_6') & year_all == 2050), value +0.05 , value ) ) ) )) )

	  # bound_total_capacity_up.par = data.frame( node=factor(),tec=factor(),year_all=factor(),value=numeric() )
	  bound_total_capacity_up.par = bind_rows(
	    bound_total_capacity_up.par,
	    bind_rows( lapply( c(2030,2040,2050), function( yyy ){
	      sw_extract_cap.df %>% mutate( tec = 'sw_extract', year_all = as.character(yyy) ) %>% dplyr::select( names( bound_total_capacity_up.par ) )
	    } ) )
	    # bind_rows(
	    #   gw_extract_agri_cap.df   )
	  )

	  # demand and food production at basin level, not countrty level
	  demand.par = demand.par %>% filter(level != 'raw') %>%
	    bind_rows(	demand.par %>% filter(level == 'raw') %>%
	                 mutate(node = gsub('_.*','',node) ) %>%
	                 group_by(node,commodity,level,year_all,time) %>%
	                 summarize(value = sum(value)) %>% as.data.frame() %>%
	                 dplyr::select(node,commodity,level,year_all,time,value) )

	  output.par = output.par %>% filter(level != 'raw') %>%
	    bind_rows(	output.par %>% filter(level == 'raw') %>%
	                 mutate(node_out = gsub('_.*','',node) ) %>%
	                 group_by(node,tec,vintage,year_all,mode,node_out,commodity,level,time,time_out) %>%
	                 summarize(value = sum(value)) %>% ungroup() %>%
	                 dplyr::select(node,tec,vintage,year_all,mode,node_out,commodity,level,time,time_out,value) )
}# END if

## GHG Emissions
if( EMISS & sc != baseline0 ){

	# Set emissions trajectory relative to baseline emissions
	require( gdxrrw )
	igdx( gams_path ) ## Set based on local machine
	tmp = rgdx( paste( paste( indus_ix_path, '/model/output/', sep=''),
	                   paste( 	'MSGoutput_no_planned_hydro.gdx', sep = '' ), sep = '' ),
								list( name = 'EMISS', form = "sparse" ) )
	names(tmp$uels) = tmp$domains
	rs = data.frame( tmp$val )
	names(rs) = c( unlist( tmp$domains ), 'value' )
	rs[ , which( names(rs) != 'value' ) ] = do.call( cbind, lapply( names( rs )[ which( names(rs) != 'value' ) ], function( cc ){ sapply( unlist( rs[ , cc ] ) , function(ii){ return( tmp$uels[[ cc ]][ ii ] ) } ) } ) )
	base_ems.df = rs %>% filter( node == basin, emission == 'CO2eq', type_tec == 'all' ) %>% dplyr::select( year_all, value )
	rm( rs, tmp )

	bound_emission.par = data.frame( 	node = basin,
										type_emission = 'CO2eq',
										type_tec = 'all',
										type_year = base_ems.df$year_all,
										value = c(0.5,0.3,0.1,0.1,0.1) * base_ems.df$value )

	} #end if

# Wind / solar target (in produced MW over the entire year)
if (SDG7 & sc != baseline0){

	# # use share equations
	# shares.set = c( shares.set, 'solar_wind_electricity' )
	#
	# type_tec.set = c(type_tec.set,'share_total','share_solar_wind')
	#
	# power_tec = (cat_tec.set %>% filter(type_tec == 'power' & !grepl('trs|distribution|ethanol|genset|biom',tec)) )$tec
	#
	# cat_tec.set = cat_tec.set %>% bind_rows(data.frame(type_tec = 'share_total',
	#                                                tec = power_tec),
	#                                         data.frame(type_tec = 'share_solar_wind',
	#                                                    tec = power_tec[grepl('solar|wind|geothermal',power_tec)]))
	#
	# node_share.tmp = map_node.set %>% filter(node1 %in% c('AFG','IND','PAK') & !node2 %in% c('AFG','IND','PAK')) %>%
	#   rename(node_share = node1, node = node2)
	# map_shares_commodity_total.set = crossing(data.frame(shares = 'solar_wind_electricity',
	#                                           type_tec = 'share_total',
	#                                           mode = factor(c(1,2,3,4)),
	#                                           commodity = 'electricity',
	#                                           level = 'energy_secondary'),
	#                                           node_share.tmp ) %>%
	#   dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
	#
	# map_shares_commodity_share.set = crossing(data.frame(shares = 'solar_wind_electricity',
	#                                                      type_tec = 'share_solar_wind',
	#                                                      mode = factor(c(1,2,3,4)),
	#                                                      commodity = 'electricity',
	#                                                      level = 'energy_secondary'),
	#                                           node_share.tmp ) %>%
	#   dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
	#
	# share_commodity_lo.par = crossing(data.frame(shares = 'solar_wind_electricity',
	#                                              node_share = node_share.tmp$node_share,
	#                                              unit = '%'),
	#                                   crossing(data.frame(year_all = as.factor(c(2020, 2030, 2040, 2050, 2060)),
	#                                                       value =    c(0.1,  0.2,  0.2,  0.3,  0.3)),
	#                                            time = time) ) %>%
	#   dplyr::select(shares,node_share,year_all,time,value)

	# phase out of coal and once through tecghnologies
	bound_activity_up.par = rbind( bound_activity_up.par,
								   crossing( crossing(node = node[ node != basin ],
											year_all = c(2030,2040,2050,2060),
											time = as.numeric(time)),
								   crossing(tec = technology.set[grepl('_ot',technology.set)],
												 mode = c(1,2)) %>%
									  bind_rows(data.frame(tec = "coal_st_ot",mode = c(3,4),stringsAsFactors = F))
								  ) %>%
									dplyr::select(node,tec,year_all,mode,time) %>%
									mutate(value = 1e-6))

	} #end if

## Nonrenewable Groundwater extraction
if( GROUNDWAT & sc != baseline0 ){

	# Constrain fossil groundwater extraction to pct of baseline0
	pct_bsl =  data.frame( year_all = as.character(c(2020,2030,2040,2050,2060 )), val = c( 0.5, 0.1, 0.1, 0.1, 0 ) ,stringsAsFactors = F) # 2020 to 2060

	require( gdxrrw )
	igdx( gams_path ) ## Set based on local machine
	tmp = rgdx( paste( paste( indus_ix_path, '/model/output/', sep=''),
								paste( 	'MSGoutput_', baseline0, '.gdx', sep = '' ), sep = '' ),
								list( name = 'EMISS', form = "sparse" ) )
	names(tmp$uels) = tmp$domains
	rs = data.frame( tmp$val )
	names(rs) = c( unlist( tmp$domains ), 'value' )
	rs[ , which( names(rs) != 'value' ) ] = do.call( cbind, lapply( names( rs )[ which( names(rs) != 'value' ) ], function( cc ){ sapply( unlist( rs[ , cc ] ) , function(ii){ return( tmp$uels[[ cc ]][ ii ] ) } ) } ) )
	base_gw.df = rs %>% filter( node %in% bcus, emission == 'groundwater', type_tec == 'all' ) %>% dplyr::select( node, emission, type_tec, year_all, value )
	rm( rs, tmp )
	tmp = crossing(node = node[-25] ,type_year =as.character( c(2020,2030,2040,2050,2060) ))

	gw_bound = tmp %>% left_join(left_join( base_gw.df, pct_bsl ) %>%
	                               mutate( value = val * value * Beta_water) %>%
	                               dplyr::select( node, emission, type_tec, year_all, value ) %>%
	                               rename( type_emission = emission, type_year = year_all ) ) %>%
	  mutate(type_emission = 'groundwater',type_tec = 'all') %>%
	  group_by(type_year) %>%
	  mutate(value = if_else(is.na(value), 0,value)) %>%
	  mutate(value = if_else(value == 0, max(value),value)) %>% ungroup()

	bound_emission.par = bind_rows( bound_emission.par,
	                                gw_bound		)

} #end if

if(CONSTRAINT_LAND){

	## release area constraints
	expand_par = data.frame(year_all = c(1990,2000,2010,2015,2020,2030,2040,2050,2060),
                          mult_ind = c(1   ,1   ,1   ,1   ,0.1 ,0.18 ,0.18 ,0.18  ,0.19 ) ,
                          mult_pak = c(1   ,1   ,1   ,1   ,0.1 ,0.18 ,0.18, 0.18 ,0.18 ))

	demand.par = demand.par %>% filter(level != 'area') %>%
		bind_rows(demand.par %>% filter(level == 'area') %>%
        left_join(expand_par) %>%
		group_by(node,commodity,level,time) %>%
		mutate(value = if_else(grepl('IND',node) , 0.4 * value , value ) ) %>%
		mutate(value = if_else(grepl('PAK',node) , 0.3 * value , value ) ) %>%
		ungroup() %>%
		dplyr::select(-mult_ind, -mult_pak))

	}

if(CHANGE_FOOD_DEMAND){

	mult = data.frame( 	year_all = c(2015,2020,2030,2040,2050,2060),
						mult = c(1,   0.9, 0.8,0.8, 0.7,0.7 ) )

	demand.par = demand.par %>%
		left_join(mult) %>%
		mutate(value = if_else(level == 'raw', value * mult, value )) %>%
		dplyr::select(-mult)

	}

# import upper bound
# fix electricity import to be lower or equal to the baseline0, not to
if (FIX_ELEC_IMPORT){

	igdx( gams_path ) ## Set based on local machine
	tmp = rgdx( paste( paste( indus_ix_path, '/model/output/', sep=''),
					   paste( 	'MSGoutput_', baseline0, '.gdx', sep = '' ), sep = '' ),
				list( name = 'ACT', form = "sparse" ) )
	names(tmp$uels) = tmp$domains
	rs = data.frame( tmp$val )
	names(rs) = c( unlist( tmp$domains ), 'value' )
	rs[ , which( names(rs) != 'value' ) ] = do.call( cbind, lapply( names( rs )[ which( names(rs) != 'value' ) ], function( cc ){ sapply( unlist( rs[ , cc ] ) , function(ii){ return( tmp$uels[[ cc ]][ ii ] ) } ) } ) )

	trs_bound = rs %>%
		filter(tec %in% exp_routes_names) %>% filter(mode == 2) %>%
		dplyr::select(node,tec,year_all,mode,time,value) %>%
		group_by(node,tec,year_all,mode,time) %>%
		summarise(value = sum(value)) %>%
		as.data.frame( )

	bound_activity_up.par = rbind( bound_activity_up.par, trs_bound )

	}

if (SMART_IRR_WATER){
# smart irrigation share constraints

	perc_red = 50

	if (perc_red == 0){} else {

		percentages_smart = data.frame(	year_all = as.factor(c(2020, 2030, 2040, 2050, 2060)),
										value = c(0.5 * perc_red,  perc_red,  perc_red, perc_red,  perc_red) /100 )
    # use share equations
    # share on the whole use of freshwater.irrigation_final

		shares.set = c( shares.set, 'smart_irr_water' )

		type_tec.set = c(type_tec.set,'water_irr_total','water_irr_smart')

		cat_tec.set = cat_tec.set %>%
			bind_rows( 	data.frame(type_tec = 'water_irr_total', tec = irr_tech_names ),
                        data.frame(type_tec = 'water_irr_smart', tec = irr_tech_names[grepl('smart',irr_tech_names)]) )

		node_share.tmp = map_node.set %>%
			filter(node1 %in% c('AFG','IND','PAK') & !node2 %in% c('AFG','IND','PAK')) %>%
			rename(node_share = node1, node = node2)

		map_shares_commodity_total.set = map_shares_commodity_total.set %>%
			bind_rows(
				crossing(
					data.frame(	shares = 'smart_irr_water',
								type_tec = 'water_irr_total',
								mode = factor(c(1,2,3,4)),
								commodity = 'freshwater',
								level = 'irrigation_final'),
					node_share.tmp ) %>%
				dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
				)

		map_shares_commodity_share.set = map_shares_commodity_share.set %>%
			bind_rows(
				crossing(
					data.frame( shares = 'smart_irr_water',
								type_tec = 'water_irr_smart',
								mode = factor(c(1,2,3,4)),
								commodity = 'freshwater',
								level = 'irrigation_final'),
					node_share.tmp ) %>%
				dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
				)

		share_commodity_lo.par = share_commodity_lo.par %>%
			bind_rows(
				crossing(
					data.frame(	shares = 'smart_irr_water',
								node_share = node_share.tmp$node_share,
								unit = '%'),
					crossing( percentages_smart, time = time)
					) %>%
				dplyr::select(shares,node_share,year_all,time,value)
				)

		}

	}

# constraint to keep limit the shre of rainfed agriculture to X%
type_tec.set = c(type_tec.set,'agri_land_total','agri_land_rainfed')

		cat_tec.set = cat_tec.set %>% bind_rows(data.frame(type_tec = 'agri_land_total',
														   tec = c(irr_tech_names,rainfed_crop_names) ),
												data.frame(type_tec = 'agri_land_rainfed',
														   tec = rainfed_crop_names) )
if(RAINFED_LAND){
	# smart irrigation share constraints

	perc_red = 20

	if (perc_red == 0){} else {

		percentages_smart = data.frame( year_all = as.factor(c(2020, 2030, 2040, 2050, 2060)), value =  perc_red /100 )
		# use share equations
		# share on the whole use of freshwater.irrigation_final

		shares.set = c( shares.set, 'rainfed_land' )

		node_share.tmp = map_node.set %>%
			filter(grepl(('AFG_|IND_|PAK_'),node1)) %>%
			rename(node_share = node1, node = node2)

		map_shares_commodity_total.set = map_shares_commodity_total.set %>%
			bind_rows(
				crossing(
					data.frame(	shares = 'rainfed_land',
								type_tec = 'agri_land_total',
								mode = factor(c(1,2,3,4)),
								commodity = 'crop_land',
								level = 'area'),
					node_share.tmp ) %>%
				dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
				)

		map_shares_commodity_share.set = map_shares_commodity_share.set %>%
			bind_rows(
				crossing(
					data.frame(	shares = 'rainfed_land',
								type_tec = 'agri_land_rainfed',
								mode = factor(c(1,2,3,4)),
								commodity = 'crop_land',
								level = 'area'),
					node_share.tmp ) %>%
			dplyr::select(shares,node_share,node,type_tec,mode,commodity,level)
			)

		share_commodity_up.par = share_commodity_up.par %>%
			bind_rows(
				crossing(
					data.frame(	shares = 'rainfed_land',
								node_share = node_share.tmp$node_share,
								unit = '%'),
					crossing( percentages_smart, time = time ) ) %>%
			dplyr::select(shares,node_share,year_all,time,value)
			)

		}

	}

# minimum activity for crops and power plants in 2020, based on historical capacity

tmp1 = historical_new_capacity.par %>% filter(year_all < 2020) %>%
  filter(grepl('crop|irr_flood|rainfed',tec)) %>% filter(!grepl('fruit',tec)) %>%
  group_by(node,tec,year_all) %>%
  summarise(value = sum(value)) %>% ungroup() %>%
  filter( !(grepl('AFG',node) & grepl('vegetables',tec)) )

if (!HIST_AGRICULTURE){ year_pol = c(2030,2040,2050)
# in 2020 70% match with historical
bound_total_capacity_lo.par = rbind(bound_total_capacity_lo.par,
                                    crossing(tmp1  %>%
                                               select(-year_all),
                                             year_all = 2020) %>%
                                      mutate(value = 0.7 * value) %>%
                                      select(node,tec,year_all,value)  )

#after 2020 50% match with historical location, but irrigation technology can change
bound_total_capacity_lo.par = rbind(bound_total_capacity_lo.par,
                                    crossing(tmp1 %>% filter( !grepl('irr_flood',tec) ) %>%
                                               select(-year_all),
                                             year_all = year_pol) %>%
                                      mutate(value = 0.5 * value) %>%
                                      select(node,tec,year_all,value)  )

} else { year_pol = c(2020,2030,2040,2050)

bound_total_capacity_lo.par = rbind(bound_total_capacity_lo.par,
                                    crossing(tmp1 %>% select(-year_all),
                                             year_all = year_pol) %>%
                                      select(node,tec,year_all,value)  )}

if(FULL_COOPERATION){

		  # demand and food production at basin level, not countrty level
		  demand.par = demand.par %>% filter(level != 'raw') %>%
		    bind_rows(	demand.par %>% filter(level == 'raw') %>%
		                 group_by(commodity,level,year_all,time) %>%
		                 summarize(value = sum(value)) %>% as.data.frame() %>%
		                 mutate(node = 'Indus') %>%
		                 dplyr::select(node,commodity,level,year_all,time,value) )

		  output.par = output.par %>% filter(level != 'raw') %>%
		    bind_rows(	output.par %>% filter(level == 'raw') %>%
		                 group_by(node,tec,vintage,year_all,mode,commodity,level,time,time_out) %>%
		                 summarize(value = sum(value)) %>% ungroup() %>%
		                 mutate(node_out = 'Indus') %>%
		                 dplyr::select(node,tec,vintage,year_all,mode,node_out,commodity,level,time,time_out,value) )

		  #cooperative electricity - remove the hurdle rates
		  var_cost.par = var_cost.par %>% mutate(value = if_else(grepl('trs_',tec) & !(tec %in% exp_routes_names)
		                                                         , 0 , value ) )

	} #end if

## Policies specific for one scenario ####
# in this way we do not add several policy options

if(sc == 'irr_Nexus'){

	# demand and food production at basin level, not countrty level
	demand.par = demand.par %>% filter(level != 'raw') %>%
		bind_rows(	demand.par %>% filter(level == 'raw') %>%
					group_by(commodity,level,year_all,time) %>%
					summarize(value = sum(value)) %>% as.data.frame() %>%
					mutate(node = 'Indus') %>%
					dplyr::select(node,commodity,level,year_all,time,value) )

	output.par = output.par %>% filter(level != 'raw') %>%
		bind_rows(output.par %>% filter(level == 'raw') %>%
                group_by(node,tec,vintage,year_all,mode,commodity,level,time,time_out) %>%
                summarize(value = sum(value)) %>% ungroup() %>%
                mutate(node_out = 'Indus') %>%
				dplyr::select(node,tec,vintage,year_all,mode,node_out,commodity,level,time,time_out,value) )

	# crop production level remains constant
	demand.par = demand.par %>%
		group_by(node,commodity,level,time) %>%
		mutate(value = if_else(level == 'raw', first(value), value )) %>%
		ungroup()

	#cooperative electricity trading - remove the hurdle rates
	var_cost.par = var_cost.par %>% mutate(value = if_else(grepl('trs_',tec), 0 , value ) )

	} # end if

if(grepl('extreme|glacier',sc)){

  # bound_activity_lo.par = bound_activity_lo.par %>% filter(!grepl('canal|lining|river',tec))

  bound_storage_lo.par = bound_storage_lo.par %>% mutate(value = 0)

  bound_total_capacity_lo.par = bound_total_capacity_lo.par %>% filter(tec == 'interbasin_canal' | year_all == '2020')

  require( gdxrrw )
  igdx( gams_path ) ## Set based on local machine
  tmp = rgdx( paste( paste( indus_ix_path, '/model/output/', sep=''),
                     paste( 	'MSGoutput_', baseline, '.gdx', sep = '' ), sep = '' ),
              list( name = 'CAP', form = "sparse" ) )
  names(tmp$uels) = tmp$domains
  rs = data.frame( tmp$val )
  names(rs) = c( unlist( tmp$domains ), 'value' )
  rs[ , which( names(rs) != 'value' ) ] = do.call( cbind, lapply( names( rs )[ which( names(rs) != 'value' ) ], function( cc ){ sapply( unlist( rs[ , cc ] ) , function(ii){ return( tmp$uels[[ cc ]][ ii ] ) } ) } ) )
  base_gw.df = rs %>% filter( node %in% bcus, tec == 'irrigation_gw_diversion' ) %>% dplyr::select( node, tec, year_all, value )
  rm( rs, tmp )

  gw_extract_agri_cap.df = base_gw.df %>%
    filter(node != 'PAK_13') %>%
    group_by(node,tec,year_all) %>% summarise(value = sum(value) * mean(frc)) %>% ungroup()
  bound_total_capacity_up.par = bound_total_capacity_up.par %>% rbind(
    gw_extract_agri_cap.df
  )
}


# Make Confusion matrix table

#-----------------------------------------------------------------------------------------------------#
#							Library
#-----------------------------------------------------------------------------------------------------#
#-----------------------------------------------------------------------------------------------------#
#							Settings
#-----------------------------------------------------------------------------------------------------#

# Details about ROC curves
	s_ROC_direction = "<"
	s_ROC_Level  = "Class1"

#-----------------------------------------------------------------------------------------------------#
#							1 load + 2 Rename
#-----------------------------------------------------------------------------------------------------#
CM_Rootdir = "C:/DATA STORAGE/Projects/PPMI/Results"

# Table has 32 rows; 2*4*4; make counter
CM_table = data.frame(matrix(nrow=2*4*4,ncol=20+7+2))
Colnamess = c("Outcome","Feature subset","Algorithm","NumberOfFeatures","TP","TN","FP","FN","Accuracy","Kappa ","AccuracyLower","AccuracyUpper","AccuracyNull","AccuracyPValue","McnemarPValue","Sensitivity","Specificity","Pos Pred Value","Neg Pred Value","Precision","Recall","F1","Prevalence ","Detection Rate","Detection Prevalence","Balanced Accuracy","MCC","AUC","AUC_CI")
colnames(CM_table)=Colnamess

counter = 1

# Class
for( i_class in c(0,1)){
	# 0 = Impairment outcome, 1 = PDD outcome, 2 = MCIvsPDD
	if(i_class==0){temp_Outcome = "Impairment"}
	if(i_class==1){temp_Outcome = "PDD"}
	if(i_class==2){temp_Outcome = "MCIvsPDD"}
	if(i_class==3){temp_Outcome = "Subjective_complaint"}

	# Subset
	for( o_subset in c("All","Clinical","Serum","Genetic_Epigenetic")){ #c("All","Clinical","Serum","Genetic_Epigenetic")

		# Machine learning algorithm
		for( p_algo in c("cforest","svmLinear","glmnet", "rf")){ # svmLinear/glmnet problems ; c("cforest","svmLinear","glmnet", "rf")
			load(paste0(CM_Rootdir,"/",temp_Outcome,"/",o_subset,"/",p_algo,"_model.RData"))

			resdata = list(Pred_P = superresult$Combine_data_main$model[[1]]$predictions_test, Pred_P_p = superresult$Combine_data_main$model[[1]]$predictions_test_p,Obs_C = force(superresult$Combine_data_main$model[[1]]$Test_samples_class[,2]),Metrics=superresult$Combine_data_main$model[[1]]$resultMCC_TEST,NumberOfFeatures = length(superresult$Combine_data_main$model[[1]]$fit$coefnames))

			minitable = table(data.frame(resdata$Pred_P,resdata$Obs_C))

			MLmetrics = caret::confusionMatrix(minitable,positive="Class1")

			# reset
			TP=NA;TN=NA;FP=NA;FN=NA

			# assign; but can fail
			TN=minitable["Class0","Class0"]
			TP=minitable["Class1","Class1"]
			FN=minitable["Class0","Class1"]
			FP=minitable["Class1","Class0"]

			MCC = as.numeric(resdata$Metrics["MCC"])

			rocc = pROC::roc(resdata$Obs_C, resdata$Pred_P_p[,s_ROC_Level], plot=FALSE, legacy.axes=FALSE, percent=TRUE, lwd=2, print.auc=TRUE,direction=s_ROC_direction)

			AUC = rocc$auc[1]
			auc_ci = paste0(round(as.numeric(pROC::ci.auc(rocc)),1)[c(1,3)],collapse = " - ",sep="%")

			# put in format
			CM_table[counter,] = c(i_class,o_subset,p_algo,resdata$NumberOfFeatures,TP,TN,FP,FN,MLmetrics$overall,MLmetrics$byClass,MCC,round(AUC/100,3),auc_ci)

			counter = counter+1
			#browser(auc_ci)
		}

	}

}

#-----------------------------------------------------------------------------------------------------#
#							Cleanup!
#-----------------------------------------------------------------------------------------------------#
# all except starting with ROC_
rm(list = ls()[grep(ls(),pattern = "^CM_",invert = T)])

#-----------------------------------------------------------------------------------------------------#
#							Start cleaning table metrics
#-----------------------------------------------------------------------------------------------------#
CM_table[,-c(1:3,29)] = apply(CM_table[,-c(1:3,29)],2,function(x){try(round(as.numeric(x),3))})

CM_table_MAIN = CM_table[,colnames(CM_table)%in%c("Outcome","Feature subset","Algorithm","NumberOfFeatures","TP","TN","FP","FN","Accuracy","Sensitivity","Specificity","MCC","AUC","AUC_CI")]

#-----------------------------------------------------------------------------------------------------#
#							save
#-----------------------------------------------------------------------------------------------------#
write.table(CM_table,file = paste0(CM_Rootdir,"/Table_metrics_full_",format(Sys.time(), "%M%S_%d%m%y"),".txt"),sep = "\t",quote = FALSE,row.names=FALSE)
write.table(CM_table_MAIN,file = paste0(CM_Rootdir,"/Table_metrics_main_",format(Sys.time(), "%M%S_%d%m%y"),".txt"),sep = "\t",quote = FALSE,row.names=FALSE)


## Experiments using all turns, not just those containing
## attributed speech

source("../scripts/collate-word-feats.r")

load("xprospn.dt")
xea.params.all <- train.test.re.all(xprospn, rsturn.only=F)
save(xea.params.all, file="xea.params.all")

rea.feats <- names(xea.params.all[["x0.data"]])
rea.feats <- rea.feats[!(rea.feats %in% c("p.thought","p.parc","p.said","p.rs20"))]

rea.pread.all <- pred.tune(xea.params.all, feats=rea.feats, outfile="pred.rea.all")
fs.rea.all <- get.fs.pred(xea.params.all, feats=rea.feats, outfile="fs.rea.all")

## only F0 and Intensity features
pcontext <- rea.feats[grep("(F0|I0)",rea.feats)]
rea.pred.pcontext <- pred.tune(xea.params.all, feats=pcontext, outfile="pred.rea.pcontext")
fs.rea.pcontext <- get.fs.pred(xea.params.all, feats=pcontext, outfile="fs.rea.pcontext")

## F0 and Int, no context
pros <- pcontext[grep("^d", pcontext, invert=T)]
rea.pred.pros <- pred.tune(xea.params.all, feats=pros, outfile="pred.rea.pros")
fs.rea.pros <- get.fs.pred(xea.params.all, feats=pros, outfile="fs.rea.pros")

## Lexical only
lex <- grep("^n\\.", rea.feats, value=T)
rea.pred.lex <- pred.tune(xea.params.all, feats=lex, outfile="pred.rea.lex")
fs.rea.lex <- get.fs.pred(xea.params.all, feats=lex, outfile="fs.rea.lex")

## Nonlexical only
nonlex <- grep("^n\\.", rea.feats, value=T, invert=T)
rea.pred.nonlex <- pred.tune(xea.params.all, feats=nonlex, outfile="pred.rea.nonlex")
fs.rea.nonlex <- get.fs.pred(xea.params.all, feats=nonlex, outfile="fs.rea.nonlex")

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

        m.end <- glmer(is.rsend ~ (1 | spk)
                        + to.zscore(mean.normF0) + to.zscore(mean.normI0)
                        + to.zscore(range.normF0) + to.zscore(range.normI0)
                        + to.zscore(mean.normF0 - p.mean.normF0)
                        + to.zscore(range.normF0 - p.range.normF0)
                        + to.zscore(mean.normI0 - p.mean.normI0)
                        + to.zscore(range.normI0 - p.range.normI0)
                        + to.zscore(n.mean.normF0 - mean.normF0)
                        + to.zscore(n.range.normF0 - range.normF0)
                        + to.zscore(n.mean.normI0 - mean.normI0)
                        + to.zscore(n.range.normI0 - range.normI0)
                        , data=xprospn,  family = binomial(link = "logit"))

###########################################################################
## only Intensity features
pi0 <- rea.feats[grep("I0",rea.feats)]
rea.pred.pi0 <- pred.tune(xea.params.all, feats=pi0, outfile="pred.rea.pi0")

## only F0
pf0 <- rea.feats[grep("F0",rea.feats)]
rea.pred.pf0 <- pred.tune(xea.params.all, feats=pf0, outfile="pred.rea.pf0")
fs.rea.pf0 <- get.fs.pred(xea.params.all, feats=pf0, outfile="fs.rea.pf0")

## only Intensity features
ti0 <- pros[grep("I0",pros)]
rea.pred.ti0 <- pred.tune(xea.params.all, feats=ti0, outfile="pred.rea.ti0")

## only F0
tf0 <- pros[grep("F0",pros)]
rea.pred.tf0 <- pred.tune(xea.params.all, feats=tf0, outfile="pred.rea.tf0")
fs.rea.tf0 <- get.fs.pred(xea.params.all, feats=tf0, outfile="fs.rea.tf0")

## `Significant' features from logistic regression
sigpros <- c("range.normF0","range.normI0","dp.range.I0", "dn.mean.I0","dn.range.I0")
rea.pred.sigpros <- pred.tune(xea.params.all, feats=sigpros, outfile="pred.rea.sigpros")


library(TwoSampleMR)

a <- extract_instruments(2)
b <- clump_data(a)
message(nrow(b))
c <- ld_matrix(a$SNP)
message(nrow(c))
d <- extract_outcome_data(a$SNP, 7)
e <- available_outcomes()
message(nrow(e))

load("~/repo/mr-eve/results/03/exposure_dat.rdata")
snplist <- unique(exposure_dat$SNP)

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
out1 <- extract_outcome_data(snplist, 1001, proxies=FALSE)
Sys.time()-t1

t1 <- Sys.time()
toggle_api("release")
out2 <- extract_outcome_data(snplist, 1001, proxies=FALSE)
Sys.time()-t1

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout1 <- extract_outcome_data(snplist[1:5000], 1001, proxies=TRUE)
Sys.time()-t1

t1 <- Sys.time()
toggle_api("release")
pout2 <- extract_outcome_data(snplist[1:5000], 1001, proxies=TRUE)
Sys.time()-t1

library(dplyr)

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout1 <- lapply(split(snplist[1:5000], 1:5), function(x) extract_outcome_data(x, 1001, proxies=TRUE)) %>% bind_rows()
Sys.time()-t1
# 48sec

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout2 <- extract_outcome_data(snplist[1:5000], 1001, proxies=TRUE)
Sys.time()-t1
# 39sec

t1 <- Sys.time()
toggle_api("release")
pout2 <- lapply(split(snplist[1:5000], 1:5), function(x) extract_outcome_data(x, 1001, proxies=TRUE)) %>% bind_rows()
Sys.time()-t1
# 53sec

t1 <- Sys.time()
toggle_api("release")
pout2 <- extract_outcome_data(snplist[1:5000], 1001, proxies=TRUE)
Sys.time()-t1
# 40sec

####

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout1 <- lapply(split(snplist, 1:4), function(x) extract_outcome_data(x, 1001, proxies=TRUE)) %>% bind_rows()
Sys.time()-t1
# 3,7m

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout2 <- extract_outcome_data(snplist, 1001, proxies=TRUE, proxy_splitsize=50)
Sys.time()-t1
# 2.6m - 500

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout2 <- extract_outcome_data(snplist, 1001, proxies=TRUE, proxy_splitsize=100)
Sys.time()-t1
# 2.3m - 500

t1 <- Sys.time()
options(mrbaseapi="http://ieu-db-interface.epi.bris.ac.uk:8080/")
pout2 <- extract_outcome_data(snplist, 1001, proxies=TRUE)
Sys.time()-t1

t1 <- Sys.time()
toggle_api("release")
pout2 <- extract_outcome_data(snplist, 1001, proxies=TRUE)
Sys.time()-t1

t1 <- Sys.time()
toggle_api("release")
pout2 <- lapply(split(snplist[1:5000], 1:5), function(x) extract_outcome_data(x, 1001, proxies=TRUE)) %>% bind_rows()
Sys.time()-t1
# 53sec

t1 <- Sys.time()
toggle_api("release")
pout2 <- extract_outcome_data(snplist[1:5000], 1001, proxies=TRUE)
Sys.time()-t1
# 40sec


#' @title make.hist
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
    make.hist = function (data, v, basedir, res=300, type="histogram", sizevar="cw", weightvar="sa.weight", bandwidth = 0.2, xrange, yrange, nsets) {

      outdir = file.path(type, basedir)
      dir.create(outdir, recursive=T)

      yr = unique(data$yr)

        if (dim(data)[1]>1) {
        for (vs in v) {
          z = data[filter.class(data, vs), c(sizevar, weightvar)]
          size = expand.weights (x=z[,sizevar], w=z[,weightvar])
          o = length(size)
          n = o / nsets
          rm (z)
          if (o > 1) {
            rootname = paste(vs, yr, sep="")
            outfile.png = file.path(outdir, paste(rootname, ".png", sep=""))
            outfile.pdf = file.path(outdir, paste(rootname, ".pdf", sep=""))

            print(paste(outfile, n))

             if (type=="density") {
                plot(density(size, bw=bandwidth, kernel="gaussian"), xlim=xrange, main=paste(vs, yr), lwd=4, cex=5)
              }
              if (type=="histogram") {
                breaks = seq(0, 190, bandwidth)
                hi = hist(size, breaks=breaks)
                hi$counts = hi$counts / nsets
                plot(hi, xlim=xrange, ylim=yrange, main=rootname, lwd=4, cex=5, col="blue3")
              }
            Pr(dev="pdf", fname=outfile.pdf, width=6, height=3)
            convert.graphics.format (outfile.pdf, outfile.png )
          #      mtext(signif(n,3), line=-4, side=3, font=1, col="blue", cex=1.5, adj=1)
            rm (size)
            gc()
          }
      }}
    }


nox<-2; noy<-3;
paper<-F        # graphics on paper=file (TRUE) or on screen (FALSE)

sumQuarerly<-T  # use sum of quarterly M2, or calc M2 from annual numbers dead.

run.ID<-'M2'         # file id used for paper output
cleanup()

first.year.on.plot<-1974
last.year.on.plot<-2016
doGrid<-T

#incl.sp<-c("Cod")                      # species to be included. Name(s) or "all"
incl.sp<-"all"

first.pch<-1    # first pch symbol
first.color<-1   # first color

palette("default")                # good for clolorfull plots
#palette(gray(seq(0,.9,len=6)))  # gray scale for papers, use len =500 to get black only

if (F) {    # sometimes the dir and labels are defined outside this script !
  dirs<-c("baltic-2012-keyRun-updated","baltic-2012-keyRun-4-areas")
  labels<-c("Key run 2012 updated","4 areas 2012")
}

dirs<-c("NS_63-10-sep-2014","NS_key-2014-ver15_codage3","NS_key-2014-ver17")
labels<-c("2011", "2014-key","2015-key")

dirs<-c("NS_key-2011","NS_key-2014-ver13-final-key-run", "NorthSeaKeyRun")
labels<-c("2011-run", "2014-run","2015-run")

dirs<-c("NS_key-2014-ver17","NS_key-2017-ver02")
labels<-c("2014-run", "2017-run")

Init.function() # get SMS.contol object  including sp.names

for (dir in dirs) {
   Init.function(dir=file.path(root,dir)) # get SMS.contol object  including sp.names
   a<-Read.summary.data(dir=file.path(root,dir),read.init.function=F)
   a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & ration>0),
             select=c(Species, Year,Age,ration))
   rat<-data.frame(scen=labels[which(dirs==dir)],vari='ration',a)
   names(rat)<-c("scenario","Variable","Species","Year","Age","Value")

 if (dir==dirs[1]) all<-rbind(rat) else all<-rbind(all,rat)
}

  values<-tapply(all$Value,list(all$Year,all$scenario,all$Species,all$Variable,all$Age),sum)

y<-as.numeric(dimnames(values)[[1]])

if (paper) dev<-"wmf" else dev<-"screen"
if (incl.sp=="all") sp.plot<-sp.names else sp.plot<-incl.sp

len.dir<-length(dirs)

 plotvar<-function(sp=sp,vari='M2',ylab='') {
   if (sp %in% dimnames(values)[[3]]) {
    v<-values[,,sp,vari,]
    #print(v)
    maxval<-max(v,na.rm=T)
    if (maxval>0) {
      if ((gi %% (nox*noy))==0  | gi==0) {
        newplot(dev,nox,noy,filename=paste("com_",run.ID,'_',sp,sep=''),Portrait=F);

         par(mar=c(0,0,0,0))
        # make legends
        if (paper) lwds<-2
        else  lwds<-2
        plot(10,10,axes=FALSE,xlab=' ',ylab=' ',xlim=c(0,1),ylim=c(0,1))
        legend("center",legend=labels,col=first.color:(first.color+len.dir-1),
              pch=first.pch:(first.pch+len.dir-1),cex=2,title=sp)
        gi<<-gi+1

        par(mar=c(3,3,3,1)) # c(bottom, left, top, right)
      }

      gi<<-gi+1

      ages<-dimnames(v)[[3]][1:min(nox*noy-1,dim(v)[[3]])]
      for (ag in ages) {
        maxval<-max(v[,,ag],na.rm=T)
        minval<-min(0,v[,,ag],na.rm=T)
        if (maxval>0) {
          plot(y,v[,labels[1],ag],main=paste("age",ag),xlab="",ylab=ylab,type='b',lwd=lwds,ylim=c(minval,maxval),
                    col=first.color,pch=first.pch)
          if (doGrid) grid()
          for (i in (2:len.dir)) {
            if (paper) lwds<-1
            else  lwds<-2;
            lines(y,v[,labels[i],ag],col=first.color+i-1,pch=first.pch+i-1,type='b',lwd=lwds)
           }
        }
       }
     }
   }
  }

 for (sp in (sp.plot)) {
  gi<-0
  plotvar(sp=sp,vari="ration",ylab="Ration")
}

if (paper) cleanup();


# ---------------------------------------------------------------------------
# Two-way Tanimoto algorithm: prediction accuracy for 2-Tanimoto_analysis.r
# ---------------------------------------------------------------------------

tanimoto_accuracy <- function(Tanimoto_analysis, predict.only = FALSE, empirical.only = FALSE) {
    load("./RData/interactions_source.RData")
    source("./Script/prediction_matrix.r")
    source("./Script/empirical_matrix.r")
    source("./Script/prediction_accuracy.r")

    accuracy <- matrix(ncol = 12, nrow = length(Tanimoto_analysis) * length(Tanimoto_analysis[[1]]) * length(Tanimoto_analysis[[1]][[1]]) * length(Tanimoto_analysis[[1]][[1]][[1]]), data = 0, dimnames = list(c(), c('MW','K','wt','Cm','a','b','c','d','TSS','ScoreY1','ScoreY0','FSS')))
    iteration <- 1
    for(n in 1: length(Tanimoto_analysis)) { #loop through MW values
        for(m in 1: length(Tanimoto_analysis[[1]])) { # loop through K values
            for(i in 1:length(Tanimoto_analysis[[1]][[1]])){ #1st loop for all types of wt values
                for(j in 1:length(Tanimoto_analysis[[1]][[1]][[1]])) { #2nd loop for all C[i]
                    # Arguments:
                    S1 <- Tanimoto_analysis[[n]][[m]][[i]][[j]][, 'consumer']
                    predictions <- Tanimoto_analysis[[n]][[m]][[i]][[j]]
                    interactions_source <- interactions_sources
                    source <- names(Tanimoto_analysis[[n]][[m]][[i]])[j]

                    accuracy[iteration, 'MW'] <- names(Tanimoto_analysis)[n]
                    accuracy[iteration, 'K'] <- names(Tanimoto_analysis[[n]])[m]
                    accuracy[iteration, 'wt'] <- names(Tanimoto_analysis[[n]][[m]])[i]
                    accuracy[iteration, 'Cm'] <- names(Tanimoto_analysis[[n]][[m]][[i]])[j]
                    accuracy[iteration, 5:12] <- prediction_accuracy(predicted = prediction_matrix(S1 = S1, predictions = predictions, predict.only = predict.only, empirical.only = empirical.only),
                                                        empirical = empirical_matrix(S1 = S1, interactions_source = interactions_source, source = source))

                    iteration <- iteration + 1
                    remove(S1, predictions, interactions_source, source)
                }#j
            }#i
        }#m
    }#n

    return(accuracy)

}#Tanimoto_accuracy function


#!/usr/local/bin/Rscript

library(ggplot2)

args <- commandArgs(trailingOnly=TRUE)
df <- read.csv(args[1], sep=" ")
df$Duration <- df$Duration.usec. / 1e6
bw <- 12e6
df$ofct <- (df$Size / bw) + 0.05
df$NormFct <- df$Duration / df$ofct
df$Bundle <- as.factor(df$BundleId)

ggplot(df, aes(x=Duration, colour=Bundle, linetype=Alg)) +
    stat_ecdf() +
    scale_x_log10()

ggsave(args[2], width=15, height=3)


require(ez)
require(permuco)
require(dplyr)

setwd("C:/Users/ACH/Documents/fearmem")
df <- read.csv('cleaned_avg_sm.csv')
str(df)
df$subject <- as.factor(df$subject)

x = df[with(df,encode_phase == 'baseline' & response_phase == 'acquisition' & condition == 'CS+'),'prop']
y = df[with(df,encode_phase == 'baseline' & response_phase == 'acquisition' & condition == 'CS-'),'prop']

acq = c[with(c,group == group & phase %in% c('fear1','fear2')),]


args <- commandArgs(TRUE)
hla_a_baf <- args[1]
hla_b_baf <- args[2]
hla_c_baf <- args[3]
name <- args[4]
outdir <- args[5]

outfig <- paste(outdir,'/',name,'.HLA.BAF.pdf',sep="")

pdf(file=outfig,width=8,height=4)

a <- read.table(hla_a_baf,header=TRUE,sep="\t")
b <- read.table(hla_b_baf,header=TRUE,sep="\t")
c <- read.table(hla_c_baf,header=TRUE,sep="\t")

# plot hla a
if (nrow(a) != 0){
    # have enough het snp pos
    plot(NULL,xlim=c(0,max(a$pos1)),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_A BAF")
    for (i in 1:nrow(a)){
        val <- a[i,]
        points(val$pos1,val$baf1,pch=20)
        points(val$pos1,val$baf2,pch=20)
    }
}else{
    plot(NULL,xlim=c(0,1000),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_A BAF")
}
abline(h=0.5,col="blue")

# plot hla b
if (nrow(b) != 0){
    plot(NULL,xlim=c(0,max(b$pos1)),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_B BAF")
    for (i in 1:nrow(b)){
        val <- b[i,]
        points(val$pos1,val$baf1,pch=20)
        points(val$pos1,val$baf2,pch=20)
    }
}else{
    plot(NULL,xlim=c(0,1000),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_B BAF")
}
abline(h=0.5,col="blue")

# plot hla c
if (nrow(c) != 0){
    plot(NULL,xlim=c(0,max(c$pos1)),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_C BAF")
    for (i in 1:nrow(c)){
        val <- c[i,]
        points(val$pos1,val$baf1,pch=20)
        points(val$pos1,val$baf2,pch=20)
    }
}else{
    plot(NULL,xlim=c(0,1000),ylim=c(0,1),xlab="Pos Index",ylab="BAF",xaxt="n",xaxs="i",main="HLA_C BAF")
}
abline(h=0.5,col="blue")

dev.off()


# rewrites the == operator to randomly fail ~90% of the time -- gives opposite answer

oldequalsequals <- `==`;

`oldequalsequals` <- `==`;
`==` <- function(x,y){
    if(runif(1) < 0.9){
        return( `oldequalsequals`(x, y))
    } else {
        return(! `oldequalsequals`(x,y))
        }
}

# see this for more on functions in R:
# http://adv-r.had.co.nz/Functions.html#all-calls


# This is a modified version
# of GJRM::prev that
# fixes selected bugs with
# survey weighting and
# subset prevalence computations

prev_modified <- function(x, sw = NULL, type = "joint", ind = NULL, delta = FALSE, n.sim = 100, prob.lev = 0.05,
                      hd.plot = FALSE, main = "Histogram and Kernel Density of Simulated Prevalences",
       xlab="Simulated Prevalences", ...) {

if(x$Cont == "YES") stop("This function is not suitable for bivariate models with continuous/discrete margins.")
if(x$Cont == "NO" && x$VC$ccss == "yes" ) stop("This function is not suitable for selection models with continuous/discrete margin.")

lb <- wm <- ub <- qz <- sv <- Vv <- G <- X2sg <- 1
wms <- NA

if((x$Model=="B" || x$Model=="BPO") && x$triv == FALSE) stop("This function is suitable for sample selection models only.")

if(x$triv == TRUE && x$Model != "TSS") stop("This function is suitable for sample selection models only.")

if( !( type %in% c("naive","univariate","joint") ) ) stop("Error in parameter type value. It should be one of: naive, univariate or joint.")

if(x$Model == "BSS") Xsg <- x$X2s
if(x$Model == "TSS") Xsg <- x$X3s

if(type == "univariate"){

if(x$Model == "BSS"){
        etasg <- Xsg%*%x$gam2$coefficients
        Vv    <- x$gam2$Vp
                    }

if(x$Model == "TSS"){
        etasg <- Xsg%*%x$gam3$coefficients
        Vv    <- x$gam3$Vp
                    }

}

if(type == "joint" || type == "naive"){ # naive useful for sw below

if(x$Model == "BSS") etasg <- x$eta2
if(x$Model == "TSS") etasg <- x$eta3

Vv <- x$Vb

}

if(!is.null(sw) & is.null(ind) ) { if( length(sw)!=length(etasg) & length(sw) != nrow(x$gam2$model)) stop("sw must have the same length as the number of observations used in fitting.")  }

if(is.null(sw) & type != "naive") sw <- rep(1,length(etasg))
if(is.null(sw) & type == "naive") sw <- rep(1, nrow(x$gam2$model))

if( !is.null(ind) ){

    if(is.logical(ind) == FALSE) stop("ind must be a logical variable.")
    if(length(table(ind))!=2 ) stop("ind must be a logical binary variable.")
    if( type != "naive" & length(ind)!=length(etasg) ) stop("ind must have the same length as the number of observations used in fitting.")

    etasg <- etasg[ind]
    Xsg <- Xsg[ind,]

   #sw <- sw[ind]

}

if(type != "naive"){

#######

wm <- weighted.mean(probm(etasg, x$margins[2])$pr, w=sw)
#wm <- weighted.mean(probm(etasg, x$margins[2], min.dn = x$VC$min.dn, min.pr = x$VC$min.pr, max.pr = x$VC$max.pr)$pr, w=sw)

#######

if(delta == TRUE){

core <- matrixStats::colWeightedMeans( c( probm(etasg, x$margins[2], only.pr = FALSE)$d.n )*Xsg, w = sw, na.rm = FALSE)
#core <- colWeightedMeans( c( probm(etasg, x$margins[2], only.pr = FALSE, min.dn = x$VC$min.dn, min.pr = x$VC$min.pr, max.pr = x$VC$max.pr)$d.n )*Xsg, w = sw, na.rm = FALSE)

if(x$Model == "BSS" && type == "joint"){

if( is.null(x$X3) ) zerod <- 0
if(!is.null(x$X3) ) zerod <- rep(0, x$X3.d2)

G <- c( rep(0,x$X1.d2), core, zerod)

}

if(x$Model == "TSS" && type == "joint"){

zerod <- c(0,0,0)
G <- c( rep(0, (x$X1.d2 + x$X2.d2)), core, zerod)

}

if(type == "univariate")  G <- c( core )

  sv <- sqrt( t(G)%*%Vv%*%G )

  qz <- qnorm(prob.lev/2, lower.tail = FALSE)

  lb <- wm - qz*sv
  ub <- wm + qz*sv

}

if(delta == FALSE){

  if(type == "joint") coefm <- x$coefficients

  if(type == "univariate"){

    if(x$Model == "BSS") coefm <- x$gam2$coefficients
    if(x$Model == "TSS") coefm <- x$gam3$coefficients

  }

   bs <- rMVN(n.sim, mean = coefm, sigma=Vv)

  if(type == "joint"){

    if(x$Model == "BSS") bs <- bs[, x$X1.d2 + (1 : x$X2.d2) ]
    if(x$Model == "TSS") bs <- bs[, x$X1.d2 + x$X2.d2 + (1 : x$X3.d2) ]

  }

  ps  <- probm( Xsg%*%t(bs) , x$margins[2])$pr
  #ps <- probm( Xsg%*%t(bs) , x$margins[2], min.dn = x$VC$min.dn, min.pr = x$VC$min.pr, max.pr = x$VC$max.pr)$pr
  wms <- colWeightedMeans( ps, w = sw, na.rm = FALSE)
  bb <- quantile(wms, probs = c(prob.lev/2,1-prob.lev/2), na.rm=TRUE )

  lb <- bb[1]
  ub <- bb[2]

  if(hd.plot == TRUE){

  hist(wms*100, freq = FALSE, main=main,
       xlab=xlab,
       ylim=c(0,max(density(wms*100)$y,hist(wms*100, plot = FALSE)$density)), ...)
  lines(density(wms*100))

                     }

}

} # end type

if( type == "naive"){

if(x$Model == "BSS") inde <- x$inde
if(x$Model == "TSS") inde <- x$inde2
#sw <- sw[inde]
if(x$Model == "BSS") resp <- x$y2
if(x$Model == "TSS") resp <- x$y3

if( !is.null(ind) ){

if( length(ind) != length(resp) ) stop("ind must have the same length as the number of selected observations for the outcome.")

resp <- resp[ind]

                    }

qz <- qnorm(prob.lev/2, lower.tail = FALSE)
if( !is.null(sw) ) { wm <- weighted.mean(resp, w = sw) } else { wm <- mean(resp) }
sv <- sqrt( (wm*(1 - wm))/length(resp) )
lb <- wm - qz*sv
ub <- wm + qz*sv

}

  res <- c(lb, wm, ub)

  rm(lb,wm,ub,qz,sv,Vv,G,Xsg)

  out <- list(res=res, prob.lev=prob.lev, sim.prev = wms)

  class(out) <- "prev"

  out

}