setwd("c:/Users/jianelli/Desktop/Chile SPRFMO/prg/Aug")

require(PBSadmb)
source('ADfunctions2.r')
source('ADfunctions.r')
source('IndexFit.r')

mod1<-readList("For_R.dat")

mod2<-readList("For_R.dat")
mod3<-readList("For_R.dat")
mod4<-readList("For_R.dat")
# comparing effective sample sizes for 2 fisheries in 2 models
windows(,9,6)
par(mfrow=c(2,2))
for(i in 1:length(mod1$Fshry_names)) p.eff.n(mod1, typ='F', f=i, new=FALSE)
for(i in 1:length(mod2$Fshry_names)) p.eff.n(mod2, typ='F', f=i, new=FALSE)

# 1 model
p.biom.pol(mod1, n.mod=1, typ='SSB')
p.biom.pol(mod3, n.mod=1, typ='Tot')

# 2 models - Spawning Stock Biomass
p.biom.pol(mod1, mod2, n.mod=2, typ='SSB')
legend('topright', legend=paste(c(2,3), 'Fisheries'), fill=c('light blue', 'light green'), bty='n')

# 2 models - Total Biomass
p.biom.pol(mod1, mod2, n.mod=2, typ='TB')
legend('topright', legend=paste(c(2,3), 'Fisheries'), fill=c('light blue', 'light green'), bty='n')

# construct plot of selectivies over time and age
# Model 1
# Fisheries selectivies
windows(,9,6.5)
par(mfrow=c(1, length(mod1$Fshry_names)))
for(i in 1:length(mod1$Fshry_names))
{
	sel.age.mountain(mod1, f=i, typ='F', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2.5, new=F, cex.yax=0.6)
}
Mntns(mod4)
windows(,9,6.5)
par(mfrow=c(1, length(mod3$Fshry_names)))
for(i in 1:length(mod3$Fshry_names))
{
	sel.age.mountain(mod3, f=i, typ='F', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2.5, new=F, cex.yax=2.)
}
sel.age.mountain(mod4, f=4, typ='S', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2.5, new=F, cex.yax=1)

windows(,9,6.5)
par(mfrow=c(1, length(mod3$Fshry_names)))
for(i in 1:length(mod3$Fshry_names))
{
	sel.age.mountain(mod3, f=i, typ='F', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2.5, new=F, cex.yax=0.6)
}
# Index selectivies
windows(,11, 6.5)
par(mfrow=c(1, length(mod3$Index_names)))
for(i in 1:length(mod3$Index_names))
{
	sel.age.mountain(mod3, f=i, typ='S', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2, new=F, cex.yax=0.6)
}

# Model 2
# Fisheries selectivies
windows(,9,6.5)
par(mfrow=c(1, length(mod2$Fshry_names)))
for(i in 1:length(mod2$Fshry_names))
{
	sel.age.mountain(mod2, f=i, typ='F', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2.5, new=F, cex.yax=0.6)
}

# Index selectivies
windows(,11, 6.5)
par(mfrow=c(1, length(mod2$Index_names)))
for(i in 1:length(mod2$Index_names))
{
	sel.age.mountain(mod2, f=i, typ='S', xvec=c(2:12), xlab='Age', ylab='Year', zscale=2, new=F, cex.yax=0.6)
}


#-------------------------------------------------------------------------------
# Script to run the assessment of Jack Mackerel and look at outputs
#
# By: Niels Hintzen
# Upate: 31 Aug 2011
#-------------------------------------------------------------------------------

rm(list=ls())
memory.size(4000)

  # Set libraries & source code
library(lattice)
require(PBSadmb)
library(RColorBrewer)
library(doBy)

  # Set paths
codePath    <- "N:/Projecten/SouthPacific/2012/SWG/R/"
inputPath   <- "D:/Repository/Dropbox/jurel/Codes/Work/"
outputPath  <- "N:/Projecten/SouthPacific/2012/SWG/Results/"
setwd(codePath)

  # Read in output data to create tables
jjm.comb  <- readList(file.path(inputPath,"arc/comb_r.rep"))
jjm.north <- readList(file.path(inputPath,"arc/north_r.rep"))
jjm.south <- readList(file.path(inputPath,"arc/south_r.rep"))

  # Likelihood table
tab       <- as.data.frame(cbind(jjm.comb$Like_Comp_names,round(jjm.comb$Like_Comp,1)))
tab       <- cbind(tab,round(jjm.north$Like_Comp,1),round(jjm.south$Like_Comp,1))
colnames(tab) <- c("name","comb","north","south")
tab$name  <- c("Catch biomass","Fishery age compositions","Fishery length composition",
               "Fishery selectivity"," ","Indices age composition","Indices selectivity",
               "Stock-recruitment","F penalty","Priors indices Q","priors","Residual","Total")

write.csv(tab,file=file.path(inputPath,"LikelihoodTable2012.csv"),row.names=F)


require(tidyverse)
require(ncdf4)
require(rgdal)
require(raster)
require(rgeos)
require(ggmap)
require(rasterVis)
require(countrycode)
memory.limit(size=1e9)

ssps= c( 'SSP1', 'SSP2', 'SSP3', 'SSP4', 'SSP5' )
n_days = c(31,28,31,30,31,30,31,31,30,31,30,31)

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

# Grab the basin boundaries
basin = 'Indus'
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
basin.spdf = spTransform(basin.spdf, CRS("+proj=longlat"))
basin.spdf@data$PID = as.character( basin.spdf@data$PID )
basin.spdf@data$CNTRY_ID = unlist( strsplit( basin.spdf@data$PID, '_' ) )[ seq(1,2*length(basin.spdf),by=2) ]
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
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)

## Electricity demand models from historical national data
graphics.off()
national.list = lapply( c('PAK','IND'), function(CNT){

	# Import historical socioeconomic and electricity data for estimating national model
	iea_wbi_population_gdp_2000to2015 = data.frame(read.csv(paste("input/",CNT,"_iea_wbi_population_gdp_2000to2015.csv",sep=""), header=TRUE, sep=",", stringsAsFactors=F, as.is=T))
	iea_electricity_consumption_2000to2015_by_sector_gwh = data.frame(read.csv(paste("input/",CNT,"_iea_electricity_consumption_2000to2015_by_sector_gwh.csv",sep=""), header=TRUE, sep=",", stringsAsFactors=F, as.is=T))

	# National SSP data
	national_population.df = data.frame(read.csv("input/OECD_SSP_POP.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T)) %>% # in millions
		filter( Region == CNT ) %>% dplyr::select( paste('X',seq(2015,2060,by=5),sep='') ) * 1e6

	# Fill in missing years
	national_population.df = data.frame( do.call( rbind, lapply( 1:nrow(national_population.df), function(j){ unlist(spline( seq(2015,2060,by=5), c(national_population.df[j,]) , n =2060-2015+1, method = 'fmm' )$y ) } ) ) )
	names(national_population.df) = as.character(seq(2015,2060,by=1))
	row.names(national_population.df) = ssps

	# make sure same start point
	for( yyy in as.character( 2015:2018 ) ){ national_population.df[ 2:5, yyy ] = national_population.df[1, yyy ] }

	# now for the gdp
	national_gdp.df = data.frame(read.csv("input/OECD_SSP_GDP_PPP.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T)) %>% # in billions
		filter( Region == CNT ) %>% dplyr::select( paste('X',seq(2015,2060,by=5),sep='') ) * 1e9

	# Fill in missing years
	national_gdp.df = data.frame( do.call( rbind, lapply( 1:nrow(national_gdp.df), function(j){ unlist(spline( seq(2015,2060,by=5), c(national_gdp.df[j,]) , n =2060-2015+1, method = 'fmm' )$y ) } ) ) )
	names(national_gdp.df) = as.character(seq(2015,2060,by=1))
	row.names(national_gdp.df) = ssps

	# make sure same start point
	for( yyy in as.character( 2015:2018 ) ){ national_gdp.df[ 2:5, yyy ] = national_gdp.df[1, yyy ] }

	# now urbanization
	national_urbanization.df = data.frame(read.csv("input/NCAR_SSP_Urban_Population_Share.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T)) %>% # in percent
		filter( Region == CNT ) %>% dplyr::select( paste('X',seq(2015,2060,by=5),sep='') ) * 0.01
	national_urbanization.df = data.frame( do.call( rbind, lapply( 1:nrow(national_urbanization.df), function(j){ unlist(spline( seq(2015,2060,by=5), c(national_urbanization.df[j,]) , n =2060-2015+1, method = 'fmm' )$y ) } ) ) )
	names(national_urbanization.df) = as.character(seq(2015,2060,by=1))
	row.names(national_urbanization.df) = ssps

	# make sure same start point
	for( yyy in as.character( 2015:2018 ) ){ national_urbanization.df[ 2:5, yyy ] = national_urbanization.df[1, yyy ] }

	# Per capita income
	national_income.df = national_gdp.df / national_population.df

	# Calibrate historical data to match scale of ssps
	iea_wbi_population_gdp_2000to2015$pop = iea_wbi_population_gdp_2000to2015$pop * ( national_population.df[1,'2015'] / iea_wbi_population_gdp_2000to2015$pop[nrow(iea_wbi_population_gdp_2000to2015)] )
	iea_wbi_population_gdp_2000to2015$gdp = iea_wbi_population_gdp_2000to2015$gdp * ( national_gdp.df[1,'2015'] / iea_wbi_population_gdp_2000to2015$gdp[nrow(iea_wbi_population_gdp_2000to2015)] )
	iea_wbi_population_gdp_2000to2015$inc = iea_wbi_population_gdp_2000to2015$inc * ( national_income.df[1,'2015'] / iea_wbi_population_gdp_2000to2015$inc[nrow(iea_wbi_population_gdp_2000to2015)] )

	## Estimate models - using most recent years to capture recent accelerated growth rates

	# Residential
	inds = 10:16 # years to include
	x = iea_wbi_population_gdp_2000to2015$inc[inds]
	y = 1e6 * iea_electricity_consumption_2000to2015_by_sector_gwh$Residential[inds] / iea_wbi_population_gdp_2000to2015$pop[inds]
	r = lm( log(y) ~ log(x) )
	res.a = unlist( coef(r)[1] )
	res.b = unlist( coef(r)[2] )
	yi = exp( res.a + res.b * log(x) )
	windows()
	plot(x,y,main=paste(CNT,' - Residential',sep=''),xlab='per capita income [USD]',ylab='per capita consumption [kWh]',pch=21)
	points(x,yi,pch=18)
	legend('bottomright',legend = c('data','model'),pch =c(21,18))

	# Commercial
	x = iea_wbi_population_gdp_2000to2015$inc[inds]
	y = 1e6 * iea_electricity_consumption_2000to2015_by_sector_gwh$Commercial[inds] / iea_wbi_population_gdp_2000to2015$pop[inds]
	r = lm( log(y) ~ log(x) )
	com.a = unlist( coef(r)[1] )
	com.b = unlist( coef(r)[2] )
	yi = exp( com.a + com.b * log(x) )
	windows()
	plot(x,y,main=paste(CNT,' - Commercial',sep=''),xlab='per capita income [USD]',ylab='per capita consumption [kWh]',pch=21)
	points(x,yi,pch=18)
	legend('bottomright',legend = c('data','model'),pch =c(21,18))

	# Industry
	x = iea_wbi_population_gdp_2000to2015$gdp[inds]
	y = iea_electricity_consumption_2000to2015_by_sector_gwh$Industry[inds]
	r = lm( log(y) ~ log(x) )
	ind.a = unlist( coef(r)[1] )
	ind.b = unlist( coef(r)[2] )
	yi = exp(ind.a + ind.b * log(x))
	windows()
	plot(x,y,main=paste(CNT,' - Industrial',sep=''),xlab='GDP [USD]',ylab='consumption [kWh]',pch=21)
	points(x,yi,pch=18)
	legend('bottomright',legend = c('data','model'),pch =c(21,18))

	## Future demands - use the models to project forward
	dat	= iea_electricity_consumption_2000to2015_by_sector_gwh$Residential[16]
	mod = national_population.df * ( exp( res.a + res.b * log( national_income.df ) ) ) / 1e6
	lambda = log(0.1) / length(seq(2015,2060,by=1))

	iiii = c( 1:length(seq(2015,2030,by=1)), seq(length(seq(2015,2030,by=1)), 30.75, by=0.5 ) )
	if( CNT == 'PAK' )
		{
		eff_res = data.frame( do.call( rbind, lapply( c(-4.5,-4.5,-4,-4.5, -4.5 )/100, function(iii){ ( 1 - iii )^( iiii ) } ) ) )
		eff_ind = data.frame( do.call( rbind, lapply( c(-4.5,-4.5,0,-4.5, -4.5 )/100, function(iii){ ( 1 - iii )^( iiii ) } ) ) )
		}else{
		eff_res = data.frame( do.call( rbind, lapply( c(-4,-4,-4,-4, -4 )/100, function(iii){ ( 1 - iii )^( iiii ) } ) ) )
		eff_ind = data.frame( do.call( rbind, lapply( c(-3,-3,0,-3, -3  )/100, function(iii){ ( 1 - iii )^( iiii ) } ) ) )
		}

	tt = seq(1,length(seq(2015,2060,by=1)))
	national_residential_gwh.df = mod * data.frame( do.call(rbind,lapply(1:5,function(hhh){ return( 1 + ( ( dat / mod[1,1] - 1 ) * exp( lambda * (tt-1) ) ) ) } ) ) ) * eff_res

	for( ss in 1:nrow( national_residential_gwh.df ) ){ national_residential_gwh.df[ss,] = national_residential_gwh.df[ss,] }

	dat	= iea_electricity_consumption_2000to2015_by_sector_gwh$Commercial[16]
	mod = national_population.df * ( exp( com.a + com.b * log( national_income.df ) ) ) / 1e6
	national_commercial_gwh.df = mod * data.frame( do.call(rbind,lapply(1:5,function(hhh){ return( 1 + ( ( dat / mod[1,1] - 1 ) * exp( lambda * (tt-1) ) ) ) } ) ) ) * eff_res
	for( ss in 1:nrow( national_commercial_gwh.df ) ){ national_commercial_gwh.df[ss,] = national_commercial_gwh.df[ss,]  }

	dat	= iea_electricity_consumption_2000to2015_by_sector_gwh$Industry[16]
	mod = exp( ind.a + ind.b * log( national_gdp.df ) )
	national_industry_gwh.df = mod * data.frame( do.call(rbind,lapply(1:5,function(hhh){ return( 1 + ( ( dat / mod[1,1] - 1 ) * exp( lambda * (tt-1) ) ) ) } ) ) ) * eff_ind
	for( ss in 1:nrow( national_industry_gwh.df ) ){ national_industry_gwh.df[ss,] = national_industry_gwh.df[ss,] }

	# Check national electricity demand projections
	windows()
	aa = c( unlist(national_residential_gwh.df),
			unlist(national_commercial_gwh.df),
			unlist(national_industry_gwh.df),
			unlist(iea_electricity_consumption_2000to2015_by_sector_gwh[,2:4])
			)
	matplot(iea_electricity_consumption_2000to2015_by_sector_gwh[1],iea_electricity_consumption_2000to2015_by_sector_gwh[2:4]/1000, type = 'l', lty = 1, xlim = c(2000,2060), ylim = c(min(aa),max(aa))/1000, xlab = 'year', ylab= 'Electricity Demand [ TWh ]', col = c('black','green','red'), main = CNT )
	matlines(as.numeric(names(national_residential_gwh.df)),t(national_residential_gwh.df/1000), col = 'green',lty = c(2,3,4,5) )
	matlines(as.numeric(names(national_commercial_gwh.df)),t(national_commercial_gwh.df/1000),col='red',lty = c(2,3,4,5) )
	matlines(as.numeric(names(national_industry_gwh.df)),t(national_industry_gwh.df/1000), col='black',lty = c(2,3,4,5) )
	abline(v=2015,lty=3)
	legend('top',c('Residential','Commercial','Industry'), lty=1,col=c('green','red','black'),bty='n',cex=0.9)

	# Downscale to the catchment scale using intensities and spatial GDP projections
	national_residential_kwh_per_usd.df = 1e6* national_residential_gwh.df / national_gdp.df
	national_commercial_kwh_per_usd.df = 1e6* national_commercial_gwh.df / national_gdp.df
	national_industry_kwh_per_usd.df =  1e6* national_industry_gwh.df / national_gdp.df

	# check intensities
	windows()
	aa = c( unlist(national_residential_kwh_per_usd.df),
			unlist(national_commercial_kwh_per_usd.df),
			unlist(national_industry_kwh_per_usd.df),
			unlist(data.frame( 1e6* iea_electricity_consumption_2000to2015_by_sector_gwh[,2:4]/cbind(iea_wbi_population_gdp_2000to2015$gdp,iea_wbi_population_gdp_2000to2015$gdp,iea_wbi_population_gdp_2000to2015$gdp) ))
			)
	matplot(iea_electricity_consumption_2000to2015_by_sector_gwh[,1],data.frame( 1e6* iea_electricity_consumption_2000to2015_by_sector_gwh[,2:4]/cbind(iea_wbi_population_gdp_2000to2015$gdp,iea_wbi_population_gdp_2000to2015$gdp,iea_wbi_population_gdp_2000to2015$gdp) ), main = CNT, type = 'l', lty = 1, xlim = c(2000,2060), ylim = c(min(aa),max(aa)), xlab = 'year', ylab= 'Electricity Intensity [ kWh / USD ]', col = c('black','green','red') )
	matlines(as.numeric(names(national_residential_kwh_per_usd.df)),t(national_residential_kwh_per_usd.df), col = 'green',lty = c(2,3,4,5) )
	matlines(as.numeric(names(national_commercial_kwh_per_usd.df)),t(national_commercial_kwh_per_usd.df),col='red',lty = c(2,3,4,5) )
	matlines(as.numeric(names(national_industry_kwh_per_usd.df)),t(national_industry_kwh_per_usd.df), col='black',lty = c(2,3,4,5) )
	abline(v=2015,lty=3)
	legend('top',c('Residential','Commercial','Industry'), lty=1,col=c('green','red','black'),bty='n',cex=0.9)
	temp = list( national_residential_kwh_per_usd.df, national_commercial_kwh_per_usd.df, national_industry_kwh_per_usd.df )
	names(temp) = c( 'national_residential_kwh_per_usd.df', 'national_commercial_kwh_per_usd.df', 'national_industry_kwh_per_usd.df' )

	return( temp )

	} )

# Assume AFG and CHN follow pakistan
national.list = list( national.list[[1]], national.list[[2]], national.list[[1]], national.list[[1]] )
names(national.list) = c('PAK','IND','AFG','CHN')

### Electricity demands from gridded indicators - using harmonized spatial datasets from Parkinson et al. 2016 A spatially explicit ...
# Simulation horizon
yy = c(2015,seq(2020,2060,by=10))

# import national manufacturing demand projections
national_manufacturing_withdrawal.df = data.frame(read.csv("input/manufacturing_water_demand_results/national/IIASA_water_withdrawal_manufacturing_Static.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T))
national_manufacturing_return.df = data.frame(read.csv("input/manufacturing_water_demand_results/national/IIASA_water_return_manufacturing_Static.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T))

# National GDP projections for scaling the manufacturing demands
national_gdp.df = data.frame(read.csv("input/OECD_SSP_GDP_PPP.csv", header=TRUE, sep=",", stringsAsFactors=F, as.is=T)) %>% # in billions
	filter( Region %in% unique( unlist( strsplit( basin.spdf@data$PID, '_' ) )[ seq( 1, 2*length(basin.spdf@data$PID), by=2 ) ] ) ) %>%
	dplyr::select( Scenario, Region, paste('X',seq(2015,2060,by=5),sep='') )

# hours in each month
hr = c(31,28.25,31,30,31,30,31,31,30,31,30,31) * 24

# go through each ssp and year and create flat dataframe containing the demand parameters
demands.df = bind_rows( lapply( c(1,2,5), function(ss){

	bind_rows( lapply( 1:length(yy), function(y){

		# haven't generated the data for each SSP - this is the mapping to the RCPs - could be updated to reflect different RCPs
		if(ss %in% c( 1,3,4 )){rr=1}
		if(ss==2){ rr=2 }
		if(ss==5){ rr=4 }

		 # 2015 not included in the data so using 2010
		if( yy[y]==2015 ){ yy2=2010 }else{ yy2=yy[y] }

		# import the harmonzied gridded data and rename to make generic headings, add PID by overlaying the polygons, and then sum to PID-level
		dat.df = data.frame( readRDS( paste('input/harmonized_rcp_ssp_data/water_use_ssp',ss,'_rcp',rr,'_',yy2,'_data.Rda',sep='') ) )
		cols = c( 'xloc', 'yloc', 'urban_pop', 'rural_pop', 'urban_gdp', 'rural_gdp', 'mean_tas', 'urban_withdrawal', 'rural_withdrawal', 'urban_return', 'rural_return' )
		for( nm in cols ){
			ind = which( grepl( nm, names( dat.df ) ) )
			if( length( ind ) > 1 ){ nm2 = paste( nm, 1:12,sep='.' )}else{ nm2 = nm }
			names(dat.df)[ ind ] = nm2 }
		dat.df = dat.df[,grepl( paste(cols,collapse='|'), names(dat.df) ) ]
		dat.df = dat.df %>%
			'coordinates<-'(~xloc+yloc) %>%
			'gridded<-'(TRUE) %>%
			'proj4string<-'( proj4string(basin.spdf) )
		dat.df$PID = unlist( over( dat.df, basin.spdf[,which(names(basin.spdf) == 'PID')] ) )
		dat.df = data.frame( dat.df ) %>% filter( !is.na( PID ) ) %>% dplyr::select( -xloc, -yloc )

		elec.df = bind_rows( lapply( 1:12, function( mm ){
			left_join( 	dat.df %>% dplyr::select( PID, paste( 'mean_tas', mm, sep = '.' ) ),
						dat.df %>% dplyr::select( PID, urban_pop, rural_pop )  ) %>%
			rename(tas = paste( 'mean_tas', mm, sep = '.' ) ) %>%
			group_by( PID ) %>%
			summarise( 	turb = abs( -18 -273 + sum( tas * urban_pop ) / sum( urban_pop ) ), 	# population weighted temperature
						trur = abs( -18 -273 + sum( tas * rural_pop ) / sum( rural_pop ) ) ) %>%
			as.data.frame( ) %>%
			mutate( turb = ifelse( is.nan( turb ), 0, turb ), trur = ifelse( is.nan( trur ), 0, trur ) ) %>%
			mutate( time = mm ) %>%
			dplyr::select( PID, time, turb, trur ) } ) ) %>%
			left_join( ., data.frame( time = 1:12, hr = hr ) ) %>% # add the hours in each month
			group_by( PID ) %>%
			mutate( turb =  0.4 * turb / sum( turb ) + 0.6 * hr / 8760, # downscaling factor assuming part of load insensitive to temperature
					trur =  0.4 * trur / sum( trur ) + 0.6 * hr / 8760 ) %>%
			as.data.frame( ) %>%
			mutate( turb = ifelse( is.nan( turb ), 0, turb ), trur = ifelse( is.nan( trur ), 0, trur ) ) %>%
			left_join( 	., dat.df %>% # adding gdp and pop for projecting demands based on intensities above
			dplyr::select( PID, urban_gdp, urban_pop, rural_gdp, rural_pop ) %>%
			group_by( PID ) %>% summarise_each( funs( sum ) ) %>% # summarise by PID
			as.data.frame( ) %>%
			mutate( urban_inc = urban_gdp / urban_pop, rural_inc = rural_gdp / rural_pop )	%>% # don't actually use the per capita income buts it's there in case used as alternative indicator
			mutate( urban_inc = ifelse( is.nan( urban_inc ), 0, round( urban_inc ) ),
					rural_inc = ifelse( is.nan( rural_inc ), 0, round( rural_inc ) ) ) ) %>%
			left_join( ., data.frame( PID =  basin.spdf@data$PID, country = unlist( strsplit( basin.spdf@data$PID, '_' ) )[ seq( 1, 2*length(basin.spdf@data$PID), by=2 ) ] ) ) %>%	# add countries
			left_join( . ,	as.data.frame( national.list )[ paste0( 'SSP', ss ),  ] %>%
								gather( parameter, value ) %>% # flatten
								mutate( country = unlist( strsplit( parameter, '[.]' ) )[ seq( 1, 4*length( parameter ), by = 4 ) ],
										var = unlist( strsplit( parameter, '[.]' ) )[ seq( 2, 4*length( parameter ), by = 4 ) ],
										year = unlist( strsplit( parameter, '[.]' ) )[ seq( 4, 4*length( parameter ), by = 4 ) ] ) %>%
								filter( year == yy[y] ) %>% dplyr::select( country, var, value ) %>%
								spread( var, value ) ) %>%
			group_by( PID, time ) %>% # now project the demands using the gdp - might also instead use the per capita demand model
			summarise( 	urban_municipal_mw = round( 1e-6 * urban_gdp * ( national_residential_kwh_per_usd + national_commercial_kwh_per_usd ) * turb / hr / 1e-3 ),
						rural_municipal_mw = round( 1e-6 * rural_gdp * ( national_residential_kwh_per_usd + national_commercial_kwh_per_usd ) * trur / hr / 1e-3 ),
						industry_mw = round( 1e-6 * ( urban_gdp + rural_gdp ) * national_industry_kwh_per_usd / 8760 / 1e-3 ) ) %>%
			as.data.frame( ) %>% mutate( year = yy[y], scenario = paste0( 'SSP', ss ) ) %>%
			dplyr::select( scenario, PID, year, time, urban_municipal_mw, rural_municipal_mw, industry_mw )	%>%
			gather( type, value, urban_municipal_mw, rural_municipal_mw, industry_mw ) %>%
			mutate( units = 'MW',
					type = ifelse( grepl( 'urban', type ), 'urban_final', ifelse( grepl( 'rural', type ), 'rural_final', 'industry_final' ) ) ) %>%
			dplyr::select( scenario, PID, type, year, time, value )

		# format for water demands
		dat.df = dat.df[ , ! grepl('mean_tas',names( dat.df )) ] # remove temperature
		dat.df = dat.df %>% group_by( PID ) %>%
			summarise_each( funs( sum ) ) %>%
			as.data.frame( ) %>%
			mutate( urban_inc = urban_gdp / urban_pop, rural_inc = rural_gdp / rural_pop )	%>%
			mutate( urban_inc = ifelse( is.nan( urban_inc ), 0, round( urban_inc ) ), rural_inc = ifelse( is.nan( rural_inc ), 0, round( rural_inc ) ) )

		# Add manufactruring demands
		mf.df = rbind(
				national_manufacturing_withdrawal.df %>%
					filter( Country_Code %in% unique( unlist( strsplit( basin.spdf@data$PID, '_' ) )[ seq( 1, 2*length(basin.spdf@data$PID), by=2 ) ] ) ) %>%
					filter( Scenario == paste0( 'SSP', ss ) ) %>%
					rename( scenario = Scenario, country = Country_Code ) %>%
					mutate( type = 'withdrawal' ) %>%
					dplyr::select( scenario, country, type, paste0( 'X', yy2  ) ),
				national_manufacturing_return.df %>%
					filter( Country_Code %in% unique( unlist( strsplit( basin.spdf@data$PID, '_' ) )[ seq( 1, 2*length(basin.spdf@data$PID), by=2 ) ] ) ) %>%
					filter( Scenario == paste0( 'SSP', ss ) ) %>%
					rename( scenario = Scenario, country = Country_Code ) %>%
					mutate( type = 'return' ) %>%
					dplyr::select( scenario, country, type, paste0( 'X', yy2  ) ) )
		names( mf.df )[ ncol( mf.df ) ] = 'value'
		mf.df$value = round( mf.df$value / 365.25, digits = 2 ) # convert to mcm_per_day
		mf.df = mf.df %>% spread( type, value )

		# national gdp for scaling mf demands
		gdp.df = national_gdp.df %>%
			rename( scenario = Scenario, country = Region ) %>%
			mutate( scenario = unlist( strsplit( scenario, '_' ) )[seq(1,3*length(scenario),by=3)] ) %>%
			dplyr::select( scenario, country, paste0( 'X', yy[y]  ) )
		names( gdp.df )[ ncol( gdp.df ) ] = 'gdp_national'

		# now scale
		dat.df = dat.df %>%
			mutate( country = unlist( strsplit( PID, '_' ) )[seq(1,2*length(PID),by=2)] ) %>%
			left_join( ., left_join( mf.df, gdp.df ), by = c( 'country' ) ) %>%
			mutate( manufacturing_withdrawal = round( withdrawal * ( urban_gdp + rural_gdp ) / ( 1e9 * gdp_national ), digits = 3 ) )  %>%
			mutate( manufacturing_return = round( return * ( urban_gdp + rural_gdp ) / ( 1e9 * gdp_national ), digits = 3 ) ) %>%
			dplyr::select(  -urban_pop, -urban_gdp, -rural_pop, -rural_gdp, -urban_inc, -rural_inc, -country, -scenario, -return, -withdrawal, -gdp_national )

		# expand manufacturing withdrawals and retunr flows to months - assuming constant instensity across the year
		mfw = bind_cols( lapply( 1:12, function( mmm ){ dat.df$manufacturing_withdrawal } ) )	%>% as.data.frame() %>% 'names<-'(paste('manufacturing_withdrawal',1:12,sep='.'))
		mfr = bind_cols( lapply( 1:12, function( mmm ){ dat.df$manufacturing_return } ) )	%>% as.data.frame() %>% 'names<-'(paste('manufacturing_return',1:12,sep='.'))
		dat.df = dat.df %>%
			dplyr::select( -manufacturing_withdrawal ) %>% cbind( ., mfw ) %>%
			dplyr::select( -manufacturing_return ) %>% cbind( ., mfr )

		# flatten the df
		dat.df = bind_rows( lapply( c( 'urban_withdrawal', 'urban_return', 'rural_withdrawal', 'rural_return', 'manufacturing_withdrawal', 'manufacturing_return'  ), function( tp ){
			dat.df %>%
				dplyr::select( PID, paste( tp, 1:12, sep = '.' ) ) %>%
				gather( 'month','value',-PID) %>%
				mutate( time = unlist( strsplit( month, '[.]' ) )[ seq(2,2*length(month),by=2) ], type = tp, scenario = paste0( 'SSP', ss ), year = yy[y], value = round( value, digits = 3 ) ) %>%
				dplyr::select( scenario, PID, type, year, time, value )
				} ) )

		# But the urban and rural withdrawal / return flow data are in million cubic meters per month not per day
		type2check = c( 'urban_withdrawal', 'urban_return', 'rural_withdrawal', 'rural_return' )
		dat.df = rbind( dat.df %>% filter( ! type %in% type2check ),
						dat.df %>% filter( type %in% type2check ) %>%
							left_join( ., data.frame( time = as.character( 1:12 ), days = c(31, 28.25, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
							mutate( value = round( value / days, digits = 3 ) ) %>% dplyr::select( -days ) )

		# add units
		dat.df$units = 'mcm_per_day'
		elec.df$units = 'MW'

		dat.df = rbind( dat.df, elec.df )

		return( dat.df )

		} ) )

	} ) )

# Harmonize with naming convention used previously - might update later
demands.df = demands.df %>%
	mutate( sector = unlist( strsplit( type, '_') )[seq(1,2*length(type),by=2)] ) %>%
	mutate( sector = ifelse( sector == 'manufacturing', 'industry', sector ) ) %>%
	mutate( type = unlist( strsplit( type, '_') )[seq(2,2*length(type),by=2)] ) %>%
	mutate( type = ifelse( type == 'final', 'electricity', type ) ) %>%
	dplyr::rename( pid = PID, month = time ) %>%
	dplyr::select( scenario, sector,  type,  pid,  year,  month, value, units )

write.csv( demands.df, "input/indus_demands_new.csv", row.names=FALSE )

demand.df = read.csv( 'input/indus_demands_new.csv', stringsAsFactors=FALSE )

# Plot the results

windows()
p1 = layout( matrix( c(5,5,1,2,3,4),3,2,byrow=TRUE ), widths = c(0.3,0.3), heights= c(0.05,0.3,0.3) )
hh = 1
for( tp in c('withdrawal','electricity') )
	{
	for(s in c('urban','rural'))
		{

		tmp = data.frame( do.call( cbind, lapply( unique(demand.df$scenario), function(pp){
			res = do.call( rbind, lapply( unique(demand.df$year), function(y){
				res2 = sum( sapply( unique(demand.df$month), function(m){ return( demand.df[ which( demand.df$sector == s & demand.df$type == tp & demand.df$year == y & demand.df$month == m & demand.df$scenario == pp ), 'value' ] ) } ) )
				return(res2)
				} ) )
			return(res)
			} ) ) )
		names(tmp) = unique(demand.df$scenario)
		row.names(tmp) = unique(demand.df$year)

		if( tp == 'withdrawal'){ yl = c('million m3 per day'); fc = 1 }
		if( tp == 'electricity'){ yl = c('Gigawatts'); fc = 1e3 }

		matplot( as.numeric( row.names(tmp) ), tmp/fc, type = 'l', col = c('green','blue','orange'), xlab = 'year', lty = 1, main = paste( s, tp, sep = ' - ' ), ylab = yl )

		}

	}

par(mar=c(0,0,0,0))
plot.new()
legend('bottom',legend=c('SSP1','SSP2','SSP5'),col = c('green','blue','orange'),lty=1,bty='n',ncol=3)


#' Estimate the bandwidth parameter for a lagr model
#'
#' \code{lagr.tune} estimates the bandwidth parameter for a LAGR model.
#'
#' This method calls \code{lagr} repeatedly via the \code{optimize} function, searching for the bandwidth that minimizes a bandwidth selection criterion. It returns the profiled value of the selection criterion at each bandwidth that is used in the evaluation.
#'
#' @param formula symbolic representation of the model
#' @param data data frame containing observations of all the terms represented in the formula
#' @param weights vector of prior observation weights (due to, e.g., overdispersion). Not related to the kernel weights.
#' @param family exponential family distribution of the response
#' @param coords matrix of locations, with each row giving the location at which the corresponding row of data was observed
#' @param fit.loc matrix of locations where the local models should be fitted
#' @param longlat \code{TRUE} indicates that the coordinates are specified in longitude/latitude, \code{FALSE} indicates Cartesian coordinates. Default is \code{FALSE}.
#' @param kernel kernel function for generating the local observation weights
#' @param bw bandwidth for the kernel
#' @param bw.type type of bandwidth - options are \code{dist} for distance (the default), \code{knn} for nearest neighbors (bandwidth a proportion of \code{n}), and \code{nen} for nearest effective neighbors (bandwidth a proportion of the sum of squared residuals from a global model)
#' @param bwselect.method criterion to minimize when tuning bandwidth - options are \code{AICc}, \code{BICg}, and \code{GCV}
#' @param range allowable range of the bandwidth
#' @param tol.bw global error tolerance for minimizing the bandwidth selection criterion
#' @param tol.loc local error tolerance for converting an adaptive bandwidth (e.g. \code{knn} or \code{nen}) to a distance
#' @param varselect.method criterion to minimize in the regularization step of fitting local models - options are \code{AIC}, \code{AICc}, \code{BIC}, \code{GCV}
#' @param tuning logical indicating whether this model will be used to tune the bandwidth, in which case only the tuning criteria are returned
#' @param a pre-specified matrix of distances between locations
#' @param verbose print detailed information about our progress?
#'
#' @return \code{list(bw, trace)} where \code{bw} minimizes the bandwidth selection criterion and trace is a data frame of each bandwidth that was tried during the optimization, along with the resulting degrees of freedom used inthe LAGR model and the value of the bandwidth selection criterion.
#'
#' @export
lagr.tune = function(formula, data, family=gaussian(), range=NULL, weights=NULL, coords, oracle=NULL, kernel=NULL, bw.type=c('dist','knn','nen'), varselect.method=c('AIC','BIC','AICc','jacknife','wAIC', 'wAICc'), verbose=FALSE, longlat=FALSE, tol.loc=.Machine$double.eps^0.25, tol.bw=.Machine$double.eps^0.25, bwselect.method=c('AIC', 'AICc','GCV','BIC'), lambda.min.ratio=0.001, n.lambda=50, lagr.convergence.tol=0.001, lagr.max.iter=20, na.action=na.fail, contrasts=NULL) {
    result = list()
    class(result) <- "lagr.bw"

    if (is.null(kernel))
        stop("Error: There is no kernel specified!")

    cl <- match.call()
    formula = eval.parent(substitute_q(formula, sys.frame(sys.parent())))
    mf = eval(lagr.parse.model.frame(formula, data, family, weights, coords, NULL, longlat, na.action, contrasts))

    y = mf$y
    x = mf$x
    w = mf$w
    mt = mf$mt
    coords = mf$coords
    dist = mf$dist
    max.dist = mf$max.dist
    min.dist = mf$min.dist
    family = mf$family

    bw.type = match.arg(bw.type)
    varselect.method = match.arg(varselect.method)
    bwselect.method = match.arg(bwselect.method)

    if (!is.null(range)) {
        beta1 = min(range)
        beta2 = max(range)
    } else {
        if (bw.type == "dist") {
            beta1 <- min.dist
            beta2 <- max.dist
        } else if (bw.type == 'knn') {
            beta1 <- 0
            beta2 <- 1
        } else if (bw.type == 'nen') {
            meany = mean(y)
            if (family=='binomial') {beta2 = sum(w / (meany*(1-meany)) * (y-meany)**2)}
            else if (family=='poisson') {beta2 = sum(w / meany * (y-meany)**2)}
            else if (family=='gaussian') {beta2 = sum(w * (y-meany)**2)}
            beta1 = beta2 / 1000
        }
    }

    #Create a new environment, in which we will store the likelihood trace from bandwidth selection.
    oo = new.env()
    opt <- optimize(
        lagr.tune.bw,
        interval=c(beta1, beta2),
        tol=tol.bw,
        maximum=FALSE,
        x=x,
        y=y,
        coords=coords,
        dist=dist,
        weights=w,
        env=oo,
        oracle=oracle,
        family=family,
        varselect.method=varselect.method,
        kernel=kernel,
        verbose=verbose,
        bw.type=bw.type,
        tol.loc=tol.loc,
        min.dist=min.dist,
        max.dist=max.dist,
        bwselect.method=bwselect.method,
        lambda.min.ratio=lambda.min.ratio,
        n.lambda=n.lambda,
        lagr.convergence.tol=lagr.convergence.tol,
        lagr.max.iter=lagr.max.iter
    )

    trace = oo$trace[!duplicated(oo$trace[,1]),]
    rm(oo)

    bdwt <- opt$minimum
    result[['bw']] <- bdwt
    result[['trace']] <- trace
    result[['bwselect.method']] <- bwselect.method
    result[['call']] <- cl
    result[['opt']] <- opt
    result[['bw.type']] = bw.type
    result[['dim']] = mf$dim
    result[['kernel']] = kernel

    return(result)
}


#dummify_input_tables
test_that("Breaks for wrong structure of input list", {
  expect_error(phyloseq2ML::dummify_input_tables(splitted_input_multi))
})

test_that("Response variable stayes as factor after dummification", {
  dummified <- phyloseq2ML::dummify_input_tables(merged_input_binary)
  target_factor <- merged_input_binary[[1]][,ncol(merged_input_binary[[1]])]
  target_dummified <- dummified[[1]][,ncol(dummified[[1]])]
  expect_true(all(is.factor(target_dummified), is.factor(target_factor)))
})

test_that("Returns unmodified table if no factor columns present", {
  # select numeric columns from the list's first table
  merged_input_regression[[1]] <- merged_input_regression[[1]][, 1:10]
  dummified <- phyloseq2ML::dummify_input_tables(merged_input_regression)
  expect_equal(dummified[[1]], merged_input_regression[[1]])
})

# scaling
test_that("Scaling returns unmodified response dummy col", {
  scaled_keras <- phyloseq2ML::scaling(augmented_keras_multi)
  target_scaled <- scaled_keras[[1]][["train_set"]][,ncol(scaled_keras[[1]][["train_set"]])]
  target_augmented <- augmented_keras_multi[[1]][["train_set"]][,ncol(augmented_keras_multi[[1]][["train_set"]])]
  expect_equal(target_scaled, target_augmented)
})

test_that("Scaling returns unmodified response regression col", {
  scaled_keras_regression <- phyloseq2ML::scaling(augmented_keras_regression)
  target_scaled <- scaled_keras_regression[[1]][["train_set"]][,ncol(scaled_keras_regression[[1]][["train_set"]])]
  target_augmented <- augmented_keras_regression[[1]][["train_set"]][,ncol(augmented_keras_regression[[1]][["train_set"]])]
  expect_equal(target_scaled, target_augmented)
})

test_that("Scaling took place on non-dummy columns setting mean to 0", {
  scaled_keras <- phyloseq2ML::scaling(augmented_keras_binary)
  train_set <- scaled_keras[[1]][["train_set"]]
  dummy_columns <- names(train_set)[vapply(train_set, is.dummy, logical(1))]
  dummy_columns <- c(dummy_columns, names(train_set)[ncol(train_set)])
  mean_scaled <- round(sum(apply(train_set[, !names(train_set) %in% dummy_columns], 2, mean)))
  expect_equal(mean_scaled, 0)
})

test_that("Scaling took place on non-dummy columns setting SD to 1", {
  scaled_keras <- phyloseq2ML::scaling(augmented_keras_binary)
  train_set <- scaled_keras[[1]][["train_set"]]
  dummy_columns <- names(train_set)[vapply(train_set, is.dummy, logical(1))]
  dummy_columns <- c(dummy_columns, names(train_set)[ncol(train_set)])
  standard_dev_scaled <- mean(apply(train_set[, !names(train_set) %in% dummy_columns], 2, stats::sd))
  expect_equal(standard_dev_scaled, 1)
})

test_that("Scaling ignored response var: SD to 1 not true for all columns", {
  scaled_keras_regression <- phyloseq2ML::scaling(augmented_keras_regression)
  train_set <- scaled_keras_regression[[1]][["train_set"]]
  standard_dev_scaled <- mean(apply(train_set, 2, stats::sd))
  expect_false(isTRUE(all.equal(standard_dev_scaled, 1)))
})

test_that("Scaling ignored response var: mean to 0 not true for all columns", {
  scaled_keras_regression <- phyloseq2ML::scaling(augmented_keras_regression)
  train_set <- scaled_keras_regression[[1]][["train_set"]]
  mean_scaled <- mean(apply(train_set, 2, mean))
  expect_false(isTRUE(all.equal(mean_scaled, 0)))
})
test_that("Breaks for wrong structure of input list", {
  expect_error(phyloseq2ML::scaling(merged_input_binary))
})

# inputtables_to_keras
test_that("Breaks for wrong structure of input list", {
  expect_error(phyloseq2ML::inputtables_to_keras(merged_input_multi))
})

test_that("Detect dummy response labels for train set", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_binary)
  train_target_scaled <- final[[1]][["trainset_labels"]]
  expect_true(all(sapply(train_target_scaled, is.dummy)))
})

test_that("Detect dummy response labels for test set", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_binary)
  test_target_scaled <- final[[1]][["testset_labels"]]
  expect_true(all(sapply(test_target_scaled, is.dummy)))
})

test_that("Detect non-dummy response labels for regression train set", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_regression)
  train_target_scaled <- final[[1]][["trainset_labels"]]
  expect_true(!is.dummy(train_target_scaled) & is.numeric(train_target_scaled))
})

test_that("Detect non-dummy response labels for regression test set", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_regression)
  test_target_scaled <- final[[1]][["testset_labels"]]
  expect_true(!is.dummy(test_target_scaled) & is.numeric(test_target_scaled))
})

test_that("Train set exists and is not NULL", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_multi)
  train_data <- final[[1]][["trainset_data"]]
  expect_true(!is.null(train_data))
})

test_that("Test set exists and is not NULL", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_binary)
  test_data <- final[[1]][["testset_data"]]
  expect_true(!is.null(test_data))
})

test_that("Input and output list have same length", {
  final <- phyloseq2ML::inputtables_to_keras(scaled_keras_multi)
  all_length <- unique(length(final), length(scaled_keras_multi),
    length(augmented_keras_multi), length(splitted_keras_multi))
  expect_equal(all_length, length(final))
})


## config
dataset = "data_std"  # swtich to "data_per_year" if yearly data is used
lags = 8  # swtich to "4" if time series is short (when fishing mortality is included)
is_robust_each_lag = FALSE  # swtich to "TRUE" if time series is short

time_ccm = 200
detrend_fun = detrend_sig
is_full = FALSE

library_var = "CV.CPUE"

## path for the results of ccm
ccm_path = paste0("output\\ccm\\", library_var, "_sig_detrend\\")
dir.create(file.path(wd, ccm_path), showWarnings = FALSE)

## path for the results of smap
smap_path = paste0("output\\smap\\", library_var, "_sig_detrend\\")
dir.create(file.path(wd, smap_path), showWarnings = FALSE)

## path for the results of robustness tes
robust_path = paste0("output\\robustness_test\\", library_var, "_sig_detrend\\")
dir.create(file.path(wd, robust_path), showWarnings = FALSE)


library(caret)
library(RWeka) # For J48
library(e1071) # For NB
library(Boruta)
library(DMwR)
library(data.table)
library(dplyr)
library(xgboost)
library(Matrix)
day1=read.csv("D:/DL/day1.csv")
day2=read.csv("D:/DL/day2.csv")
day3=read.csv("D:/DL/day3.csv")
day4=read.csv("D:/DL/day4.csv")
total=NULL
total$hour=c(day1$hour,day2$hour,day3$hour,day4$hour)
total$ratio=c(day1$ratio,day2$ratio,day3$ratio,day4$ratio)
plot(total$hour,total$ratio)

##read subset of data
train_sub=fread("train_sub.csv")
#rf_r_10=train(is_attributed~.,data=train_sub,method='rf')
#egb_r=train(is_attributed~.,data=train_sub,method='xgbTree')
set.seed(123456)
inTraining_id <- createDataPartition(train_sub$is_attributed, p = .677, list = FALSE,times =1) #sampleing without replacement
trainingData <- train_sub[inTraining_id,]
testData <- train_sub[-inTraining_id,]
summary(trainingData)

#downsampling
trainingData$is_attributed_f=as.factor(trainingData$is_attributed)
trainingData$hour=hour(trainingData$click_time)

train_down=downSample(y=trainingData$is_attributed_f,x=trainingData)
write.csv(x = train_down,file = 'train_down.csv')

train_down_r=train_down[,-c(1,7,8,10,12)]
table(train_down$is_attributed)
#train_down_r$hour=hour(train_down_r$click_time)
train_down_r[]= lapply(train_down_r[],factor)
#train_down_r$hour=hour(train_down_r$is_attributed)

##convert to sparse matrix
train_m=sparse.model.matrix(is_attributed ~ .-1,data=train_down_r)
train_lab=as.numeric(train_down_r$is_attributed)-1
train_matrix=xgb.DMatrix(data=train_m,label=train_lab)

testData$hour=hour(testData$click_time)
test_m=sparse.model.matrix(is_attributed ~ .-1,data=testData)
head(test_m)
test_lab=as.integer(testData$is_attributed)
test_matrix=xgb.DMatrix(data=test_m,label=test_lab)

watchlist<-list(train=train_matrix, test=test_matrix)

##Parameter
nc=2
xgb_params<-list("objective"="multi:softprob",
                 "eval_metric"="mlogloss",
                 "num_class"=nc
)
bst_model <- xgb.train(params = xgb_params,
                       data = train_matrix,
                       nrounds = 100,
                       eta = 0.001,
                       max.depth = 3,
                       watchlist=watchlist,
                       gamma = 0,
                       subsample = 1,
                       colsample_bytree = 1,
                       missing = NA,
                       seed = 123456)

confusionMatrix(predict(bst_model,test_matrix$data),test_matrix$test_lab)

xgb_linear_params<-list("objective"="reg:linear","eta"=
                      gama=)

##

##test other way
test_nb=NULL
test_nb$index=1:6
test_nb$cool=as.factor(c(1,0,1,0,3,2))
test_nb$is_attributed=c(1,0,0,1,0,1)
test_nb$some=as.factor(c(1,178,10,3,50,250))
test_nb$is_f=as.factor(c(1,178,10,3,50,250))

#test_nb[]=lapply(test_nb[],factor)

sparse.model.matrix(is_attributed ~ .-1,data=test_nb)[1,]

train_down_r[c(1:10),]
train_m_p=data.matrix(train_down_r[c(1:10),])
train_m_p=Matrix(train_m_p,sparse=TRUE)
train_m=sparse.model.matrix(is_attributed~.,data=train_down_r[c(1),])

data(agaricus.train, package='xgboost')
train <- agaricus.train
t_1=train[1]
dtrain <- xgb.DMatrix(train$data, label=train$label)

dtrain =xgb.DMatrix(data = data.matrix(train_down_r), label = is_attributed)
egb_r=xgboost(data = data.matrix(train_down_r[,-7]), label = as.numeric(train_down_r$is_attributed), max.depth = 2, eta = 1, nthread = 2, nround = 2, objective = "binary:logistic")

##
set.seed(0)
ctrl$sampling <- "down"
grid$nrounds <- 35
m_xgb_down <- train(is_attributed ~ ., data = train_down_r,
                    method = "xgbTree",
                    nthread = 8,
                    metric = "ROC",
                    tuneGrid = grid,
                    trControl = ctrl)


# By Yea-Hung Chen

# function for calling Stage2()
s2<-function(OUTCOME,CLUST.ADJ,SURVIVAL){
  ee<-Stage2(outcome=OUTCOME,clust.adj=CLUST.ADJ,
             data.input=cc,survival=SURVIVAL,weighting='indv',
             do.data.adapt=TRUE)
  ee$outcome<-OUTCOME
  ee$adj<-paste(CLUST.ADJ,collapse='+')
  ee$survival<-SURVIVAL
  if(SURVIVAL){ee$time<-TIME} else {ee$time<-'NA'}
  assign(OUTCOME,ee,envir=.GlobalEnv)
}


#CRAFTYOutput analysis - creates vector maps

#Outputs can be a combination of:
#1. figures showing raster maps of land use and Captials (.png files); years indicated by fig_yrs
#2. movies of 1. (.mp4); if video_output is TRUE
#3. comparison matrices for pairs of maps (.pdf); if comp_matrices is TRUE

#Nine raster maps for all cells
#1. Modelled LC (mode for muni)
#2. Agri Capital (mean for muni)
#3. Nature Capital (mean for muni)
#4. Port Access Capital (mean for muni)
#5. Other Agri Capital (mean for muni)
#6. Acessibility - only for raster
#7. LandPrice
#8. LandProtection
#9. GrowingSeason

#raster data from cell output data

rm(list=ls())

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

sim_yrs <- seq(2001, 2015, 1)   #movie made for all these years
fig_yrs <- c(2001, 2005, 2010, 2015) #figures output for only these years

#set for the run in CRAFTY (althrough runID difficult to control)
scenario <- "Testing_2018-09-27e"
runID <- "0-0"
cl <- "PastureB"  #classification for observed LU map
maskpath <- "Data/ObservedLCmaps/sim10_BRmunis_latlon_5km.asc"

#outputs to create
video_output <- FALSE
comp_matrices <- TRUE

##FUNCTIONS
#####
#converts data in CRAFTY output file for a single variable and creates a raster
outputRaster <- function(data, variable){

  out <- data %>%
    dplyr::select(X, Y, !!variable)

  ras <- rasterFromXYZ(out)

  return(ras)

}

#LU is a raster object
makeModLUmap <- function(LU, year) {

  #add categories for later plotting etc. (see https://stackoverflow.com/a/37214431)
  LU <- ratify(LU)     #tell R that the map raster is categorical
  rat <- levels(LU)[[1]]    #apply the levels (i.e. categories)

  #not all LUs may be present so need to create labels and colours dynamically
  uLU <- unique(LU)
  labs <- c()
  LUcols <- c()

  if(-1 %in% uLU) {
    labs <- c(labs, "LazyFR")
    LUcols <- c(LUcols, 'deeppink')}
  if(0 %in% uLU) {
    labs <- c(labs, "Soy")
    LUcols <- c(LUcols, 'wheat1')}
  if(1 %in% uLU) {
    labs <- c(labs, "Mze")
    LUcols <- c(LUcols, 'wheat2')}
  if(2 %in% uLU) {
    labs <- c(labs, "DblC")
    LUcols <- c(LUcols, 'wheat3')}
  if(3 %in% uLU) {
    labs <- c(labs, "SNat")
    LUcols <- c(LUcols, 'darkgreen')}
  if(4 %in% uLU) {
    labs <- c(labs, "PNat")
    LUcols <- c(LUcols, 'forestgreen')}
  if(5 %in% uLU) {
    labs <- c(labs, "OAg")
    LUcols <- c(LUcols, 'darkcyan')}
  if(6 %in% uLU) {
    labs <- c(labs, "O")
    LUcols <- c(LUcols, 'black')}
  if(7 %in% uLU) {
    labs <- c(labs, "Pas")
    LUcols <- c(LUcols, 'orange2')}

  rat$LandUse <- labs
  levels(LU) <- rat

  LUmap <- levelplot(LU, att = "LandUse", col.regions=LUcols, main = paste0("Mod LU ",year))

  return(LUmap)

}

makeObsLUmap <- function(LU, year, maskfile) {

  maskmap <- raster(maskfile)

  LU <- mask(LU, maskmap)
  LU <- trim(LU)

  #add categories for later plotting etc. (see https://stackoverflow.com/a/37214431)
  LU <- ratify(LU)     #tell R that the map raster is categorical
  rat <- levels(LU)[[1]]    #apply the levels (i.e. categories)

  uLU <- unique(LU)

  LUcols <- c()
  LUlabs <- c()

  if(1 %in% uLU) {
    LUcols <- c(LUcols, 'forestgreen')
    LUlabs <- c(LUlabs, 'Nat')  }
  if(2 %in% uLU) {
    LUcols <- c(LUcols, 'darkcyan')
    LUlabs <- c(LUlabs, 'OAg') }
  if(3 %in% uLU) {
    LUcols <- c(LUcols, 'wheat2')
    LUlabs <- c(LUlabs, 'Ag') }
  if(4 %in% uLU) {
    LUcols <- c(LUcols, 'black')
    LUlabs <- c(LUlabs, 'Oth') }
  if(5 %in% uLU) {
    LUcols <- c(LUcols, 'orange2')
    LUlabs <- c(LUlabs, 'Pas') }

  rat$LandUse <- LUlabs
  levels(LU) <- rat

  p <- levelplot(LU, att = "LandUse", col.regions=LUcols, main = paste0("Obs LU ",year))

  return(p)
}
##END FUNCTIONS
#####

#First, Raster maps
mps <- list()
lus <- list()
s <- stack()

for(i in seq_along(sim_yrs)){

  #i = 1

  print(paste0("raster: ", sim_yrs[i]))

  #Load model output data
  output <- read_csv(paste0("Data/",scenario,"/",runID,"/",scenario,"-",runID,"-Cell-",sim_yrs[i],".csv"))

  LU <- outputRaster(output, "LandUseIndex")
  Agri <- outputRaster(output, "Capital:Agriculture")
  Nat <- outputRaster(output, "Capital:Nature")
  Infra <- outputRaster(output, "Capital:Port Access")
  OAg <- outputRaster(output, "Capital:Other Agriculture")
  Aces <- outputRaster(output, "Capital:Nature Access")
  Lprice <- outputRaster(output, "Capital:Land Price")
  Spro <- outputRaster(output, "Capital:Soy Protection")
  GrowS <- outputRaster(output, "Capital:Growing Season")

  #create stack of LU for comparison matrices
  LU[LU == -1] <- NA #remove LazyFR if present
  if(i == 1) { s <- stack(LU) }
  else { s <- stack(s, LU) }

  pl <- list()  #this will hold the plots for the all map for this year
  lul <- list()  #this will hold the plots for the LU map for this year

  #create the Modelled LU plot and add to the list
  ModLUmap <- makeModLUmap(LU, sim_yrs[i])
  pl[[1]] <- ModLUmap

  ObsLU <- raster(paste0("Data/ObservedLCmaps/PlantedArea_brazillc_",cl,"_",sim_yrs[i],".asc"))

  ObsLUmap <- makeObsLUmap(ObsLU, sim_yrs[i], maskpath)
  lul[[1]] <- ObsLUmap
  lul[[2]] <- ModLUmap

  #ras_pal <- colorRampPalette(brewer.pal(9,"YlOrBr"))(100)
  ras_pal <- viridis(100)

  rl <- list(Agri, Nat, Infra, OAg, Aces, Lprice, Spro, GrowS)
  rl_names <- c("Agriculture C", "Nature C", "Port Access C", "Other Agri C", "Accessibility C", "Land Price", "Soy Protection", "Growing Season")

  for(j in seq_along(rl)){

    #create the plot
    p <- levelplot(rl[[j]],
    col.regions=ras_pal,
    at=seq(from=0,to=1,by=0.01),
    contour=F,
    margin=F,
    main = (rl_names[j]))

    #add it to the list
    pl[[j+1]] <- p    #+1 because LU is in first slot
  }

  mps[[i]] <- marrangeGrob(pl, nrow = 3, ncol = 3, top = paste0(sim_yrs[i]))
  lus[[i]] <- marrangeGrob(lul, nrow = 1, ncol = 2, top = paste0(sim_yrs[i]))

  #lus[[i]] <- LUmap

  #if we want this year saved as an image
  if(sim_yrs[i] %in% fig_yrs) {
  ggsave(paste0("Data/",scenario,"/",runID,"/",scenario,"_RasterOutput_AllMaps",sim_yrs[i],".png"), plot = mps[[i]], width=25, height=25, units="cm", dpi = 200)

  ggsave(paste0("Data/",scenario,"/",runID,"/",scenario,"_RasterOutput_LUMap",sim_yrs[i],".png"), plot = lus[[i]], width=20, height=12.5, units="cm", dpi = 300)
  }

}

if(comp_matrices)
{

  mat_yrs <- head(sim_yrs, -1) #drop last element of the list

  output_name <- paste0("Data/",scenario,"/",runID,"/",scenario,"_MapTransitions.pdf")

  pdf(file = output_name)

  #next create the comparison matrices for each pair of maps
  for(i in seq_along(mat_yrs)){

    #set labels for error matrix (No SNat in yr 2000)
    if(mat_yrs[i] == sim_yrs[1]) {  LCnames <- c("Soy", "Mze", "Dblc", "PNat", "OAgri","Oth","Pas","SNat")}
    else { LCnames <- c("Soy", "Mze", "Dblc", "SNat", "PNat", "OAgri","Oth","Pas") }

    xtab <- crosstabm(s[[i]], s[[i+1]])
    colnames(xtab) <- LCnames
    rownames(xtab) <- LCnames

    grid.arrange(top = paste0("Transitions ",sim_yrs[i],"-",sim_yrs[i+1]), tableGrob(xtab))
  }

  #close pdf device
  dev.off()

}

#make videos here by looping through list
if(video_output)
{
  saveVideo(
    for(i in seq_along(lus)){
      print(lus[[i]])
    },
    video.name = paste0("Data/",scenario,"/",runID,"/",scenario,"_RasterOutput_LandUse_",scenario,".mp4"))

  saveVideo(
    for(i in seq_along(mps)){
      print(mps[[i]])
    },
    video.name = paste0("Data/",scenario,"/",runID,"/",scenario,"_RasterOutput_Capitals_",scenario,".mp4"))
}


library(tidyverse)
library(data.table)
library(proxy)
library(stringr)
library(textreuse)
library(parallel)

#Subset of annotated clusters
args=(commandArgs(TRUE))

cluster_annot <- fread(args[1], stringsAsFactors = F, header = F) %>%
  setNames(c("rep","memb","pf","acc","clan","partial")) %>%
  dplyr::select(rep,memb,partial,pf,clan)

# Pfam terminal (C, N) domains of same proteins
pfam_shared_term <- read.table("data/DBs/pfam_files/Pfam-31_names_mod_01122019.tsv",
                               stringsAsFactors = F, header = F, fill=T, na.strings=c("","NA")) %>%
                                setNames(c("com_name","n_term","c_term","m_term"))
# Cluster lists
cluster.list <- split(cluster_annot, list(cluster_annot$rep), drop=TRUE)

rm(cluster_annot)
gc()

# Main function
# Main function
shingl.jacc <- function(clstr, pfam){
  # functional annotation data per cluster
  test_multi <- as.data.frame(clstr) %>% setNames(c("rep","memb","partial","annot","clan"))
  # cluster size
  size <- dim(test_multi)[1]
  # remove not annotated memeber
  clstrnoNA <- test_multi %>% tidyr::drop_na()
  # number of annotated members (cluster size)
  annotated <- dim(clstrnoNA)[1]
  prop.annot <- annotated/size
  #select members and annotations (pfam domains and clans)
  m1 <- clstrnoNA %>% dplyr::select(memb,annot,clan)
  ma <- max(str_count(m1$annot, "\\|")) + 1 # max number of multiple domains on the same orfs
  mc <- max(str_count(m1$clan, "\\|")) + 1 # max number of multiple clans on the same orfs

  # Homog_pf: all members annotated to the same Pfam domain
  if(length(unique(m1$annot))==1){
      m1 <- m1 %>% dplyr::select(memb,annot) %>% mutate(pres=1)
      ds <- Jaccard(m1)
      if(dim(m1)[1]==1){  #Only one annotated member
        median <- 1
      }else {
        median <- median(as.matrix(ds)[lower.tri(as.matrix(ds))])
      }
      rep <- clstrnoNA$rep[1]
      median.sc <- median*prop.annot
      type="Homog_pf"
      prop.type = prop.annot
      partial.prop <- dim(merge(m1, clstrnoNA, by="memb") %>% filter(partial!="00"))[1]/annotated
      res <- data.frame(rep=rep,
                        jacc_median_raw=median,
                        jacc_median_sc=median.sc,
                        type=type,
                        prop_type=prop.type,
                        prop_partial=partial.prop,
                        stringsAsFactors =F)
  }
  # Homog_clan: all members annotated to the same Pfam clan
  else if(length(unique(m1$clan))==1 & any(m1$clan!="no_clan")==T){
      m1 <- m1 %>% dplyr::select(memb,clan) %>% mutate(pres=1)
      ds <- Jaccard(m1)
      median <- median(as.matrix(ds)[lower.tri(as.matrix(ds))])
      rep <- clstrnoNA$rep[1]
      median.sc <- median*prop.annot
      type="Homog_clan"
      prop.type = prop.annot
      partial.prop <- dim(merge(m1, clstrnoNA,by="memb") %>% filter(partial!="00"))[1]/annotated
      res <- data.frame(rep=rep,
                        jacc_median_raw=median,
                        jacc_median_sc=median.sc,
                        type=type,
                        prop_type=prop.type,
                        prop_partial=partial.prop,
                        stringsAsFactors =F)
      }
  # Not homog, check for Pfam different terminal domains of the same protein
  else{
        pfam_term <- pfam
        domain_list_term <- tidyr::gather(pfam_term,com_term,term,n_term:m_term, na.rm=T)[,-2]
        # if the cluster contains any member with multiple annotation
        # split the annotation in multiple rows
        if(ma>1){
          multi_annot <- strsplit(m1$annot, split = "\\|")
          m1 <- data.frame(memb = rep(m1$memb, sapply(multi_annot, length)), annot = unlist(multi_annot), clan=rep(m1$clan, sapply(multi_annot, length)), stringsAsFactors = F)
        }
        # annotation metches with the list of Pfam terminal domains of same proteins
        term <- m1 %>% filter(grepl(paste(pfam_term$com_name,collapse="|"),annot))
        # if there is a correspondance, replace terminal-domain names with the common ones
        if(dim(term)[1]>0){
        m1 <- m1 %>% mutate(annot=plyr::mapvalues(as.vector(.$annot), from = domain_list_term$term, to = domain_list_term$com_name))
        }
        # Homog_pf_term: using the common name, do we have homogeneous annotations?
        if(length(unique(m1$annot))==1){
            m1 <- m1 %>% dplyr::select(memb,annot) %>% mutate(pres=1) %>% distinct
            ds <- Jaccard(m1)
            median <- median(as.matrix(ds)[lower.tri(as.matrix(ds))])
            rep <- clstrnoNA$rep[1]
            median.sc <- median*prop.annot
            type="Homog_pf_term"
            prop.type = prop.annot
            partial.prop <- dim(merge(m1, clstrnoNA,by="memb") %>% filter(partial!="00"))[1]/annotated
            res <- data.frame(rep=rep,
                              jacc_median_raw=median,
                              jacc_median_sc=median.sc,
                              type=type,
                              prop_type=prop.type,
                              prop_partial=partial.prop,
                              stringsAsFactors =F)
        }
        # Still not homogeneous annotations..
        else{
          # Only mono annotations
            if(ma==1 & mc==1){
              m1.a <- m1 %>% dplyr::select(memb,annot) %>% mutate(pres=1) %>% distinct
              ds <- Jaccard(m1.a)
              median.a <- median(as.matrix(ds)[lower.tri(as.matrix(ds))])
              rep <- clstrnoNA$rep[1]
              median.sc.a <- median.a*prop.annot
              m1.c <- m1 %>% dplyr::select(memb,clan) %>% mutate(pres=1) %>% distinct
              ds <- Jaccard(m1.c)
              median.c <- median(as.matrix(ds)[lower.tri(as.matrix(ds))])
              rep <- clstrnoNA$rep[1]
              median.sc.c <- median.c*prop.annot
               if(median.sc.a >= median.sc.c){
                type="Mono_pf"
                prop.type = prop.annot
                partial.prop <- dim(merge(m1, clstrnoNA,by="memb") %>% filter(partial!="00"))[1]/annotated
                res <- data.frame(rep=rep,
                                  jacc_median_raw=median.a,
                                  jacc_median_sc=median.sc.a,
                                  type=type,
                                  prop_type=prop.type,
                                  prop_partial=partial.prop,
                                  stringsAsFactors =F)
               }else{
                type="Mono_clan"
                prop.type = prop.annot
                partial.prop <- dim(merge(m1, clstrnoNA,by="memb") %>% filter(partial!="00"))[1]/annotated
                res <- data.frame(rep=rep,
                                  jacc_median_raw=median.c,
                                  jacc_median_sc=median.sc.c,
                                  type=type,
                                  prop_type=prop.type,
                                  prop_partial=partial.prop,
                                  stringsAsFactors =F)
               }
              }else{ # The cluster presents also multiple annotations
                # split multiple annotations (in many columns), fill empty cells with NAs
                m1.c <- m1 %>% dplyr::select(memb,clan) %>% mutate(pres=1) %>% distinct
                m2.c <- cbind(m1.c,str_split_fixed(m1.c$clan, "\\|", mc))
                m2.c[,2] <- NULL
                empty_as_na <- function(x){
                  if("factor" %in% class(x)) x <- as.character(x) ## since ifelse wont work with factors
                  ifelse(as.character(x)!="", x, NA)
                }
                m2.c <- m2.c %>% mutate_all(funs(empty_as_na))
                #evaluate 2-grams (or K-shingling with k=2)
                #remove doc with one word-domain (n_domain==1), keep them separated as Singl_pf/clan
                res.c <- MultiAnnot(m2.c,"clan", clstrnoNA=clstrnoNA, size=size)
                #with annot
                m1.a <- m1 %>% dplyr::select(memb,annot) %>% group_by(memb) %>%
                  mutate(annot=paste(annot,collapse = "|")) %>% mutate(pres=1) %>%
                  distinct %>% ungroup()
                m2.a <- cbind(m1.a,str_split_fixed(m1.a$annot, "\\|", ma))
                m2.a[,2] <- NULL
                empty_as_na <- function(x){
                  if("factor" %in% class(x)) x <- as.character(x) ## since ifelse wont work with factors
                  ifelse(as.character(x)!="", x, NA)
                }
                m2.a <- m2.a %>% mutate_all(funs(empty_as_na))
                #evaluate 2-grams (or K-shingling with k=2)
                #remove doc with one word (n_domain==1)..keep them separated
                res.a <- MultiAnnot(m2.c,"pf",clstrnoNA=clstrnoNA, size=size)
                # Choose the best results between domain-annot and clans
                if(any(!grepl("no_clan",m1$clan))==T && any(as.numeric(res.a$jacc_median_sc)< as.numeric(res.c$jacc_median_sc))==T){
                  res <- res.c
                }else{
                  res <- res.a
                }
              }
        }
  }
  return(res)
}

source("scripts/Cluster_validation/functional/shingl_jacc_functions.R")
res.list <- mclapply(cluster.list, shingl.jacc, pfam=pfam_shared_term, mc.cores = getOption("mc.cores",28))
results <- plyr::ldply(res.list, data.frame)
res.parsed.1 <- results %>% select(rep,jacc_median_raw,jacc_median_sc,type,prop_type,prop_partial) %>% group_by(rep) %>%
  mutate(count = n_distinct(type)) %>% filter(count==1)
res.parsed.2 <- results %>% select(rep,jacc_median_raw,jacc_median_sc,type,prop_type,prop_partial) %>% group_by(rep) %>%
  mutate(count = n_distinct(type)) %>% filter(count==2) %>%
  filter(prop_type==max(prop_type)) %>%
  filter(prop_partial==min(prop_partial)) %>%
  filter(jacc_median_sc==max(jacc_median_sc)) %>%
  filter(jacc_median_raw==max(jacc_median_raw)) %>% group_by(rep) %>% slice(1)

shingl_jacc.res <- rbind(res.parsed.1,res.parsed.2) %>% select(-count)
write.table(shingl_jacc.res, args[2],col.names=T,row.names=F,sep="\t",quote=F)


#Stat

# Notes: overriding y is not effective for absolute positions, unless statIdentity is used.
# If user wants to place bars at specific points with StatSidebar, use yintercept aesthetic.
# using statidentity or yintercept aesthetics causes location assignments to be ignored.
# y in the context of geom_xsidebar is only used to determine an appropriate location for
# sidebars such that they do not overlap points in top layer. Passing a scalar value or vector
# whose unique length equals 1 to y will force yintercept behavior. Note, if both y and yintercept
# are passed, yintercept takes precidence over y in StatSidebar and StatSummarise.

#' @rdname stat_summarise
#' @aliases stat_summarize
#' @title Summarise by grouping variable
#' @description Applies a function to a specified grouping variable
#' @inheritParams ggplot2::layer
#' @param fun Summarising function to use. If no function provided
#' it will default to \link[base]{length}.
#' @param args List of additional arguments passed to the function.
#' @param ... additional arguments to pass to \link[ggplot2]{layer}.
#' @section Aesthetics:
#' Using stat_summarise requires that you use `domain` as an aesthetic
#' mapping. This allows you to summarise other data instead of assuming
#' that `x` is the function's `domain`.
#' @examples
#' library(tidyr)
#' i <- gather(iris,"key","value",-Species)
#' ggplot(i, aes(Species, fill = key, domain = value)) +
#'    geom_bar(aes(y = after_stat(summarise)), stat = "summarise", fun = mean) +
#'    stat_summarise(aes(y = after_stat(summarise),
#'                   label = after_stat(summarise)),
#'                   position = position_stack(vjust = .5), geom = "text", fun = mean)
#' @return A Layer object to be added to a ggplot
#' @export
stat_summarise <- function(mapping = NULL, data = NULL, geom = "bar", position = "identity",
                          ..., fun = NULL, args = list(), show.legend = NA,
                          inherit.aes = TRUE){
  layer(geom = geom, stat = StatSummarise, data = data, mapping = mapping, position = position,
        params = list(fun = fun, args = args, ...), inherit.aes = inherit.aes,
        show.legend = show.legend)
}

#' @rdname stat_summarise
#' @export
stat_summarize <- stat_summarise

#' @rdname stat_summarise
#' @usage NULL
#' @export
StatSummarise <- ggplot2::ggproto("StatSummarise",
                                Stat,
                                required_aes = c("domain"),
                                compute_panel = function(self, data, scales, domain = NULL,
                                                         fun = NULL, args = list()) {
                                  #
                                  if (empty(data)) return(new_data_frame())
                                  #browser()

                                  if(is.null(fun)) {
                                    warn("fun is NULL, using length as default")
                                    fun <- length
                                  }

                                  groups <- split(data, data$group)
                                  stats <- lapply(groups, function(group){
                                    self$compute_group(data = group, fun = fun, args = args)
                                  })

                                  rbind_dfs(stats)
                                },
                                compute_group = function(self, data, scales,  fun = NULL, args = args){

                                  call_f <- function(fun = fun, x) {
                                    if (is.null(fun)) return(NA_real_)
                                    fun <- as_function(fun)
                                    do.call(fun, c(list(quote(x)), args))
                                  }
                                  data <- unique(transform(data, summarise = call_f(fun, domain), domain = NULL))
                                  data[['summarize']] <- data[['summarise']]
                                  data
                                },
                                compute_layer = function(self, data, params, layout) {
                                  check_required_aesthetics(
                                    self$required_aes,
                                    c(names(data), names(params)),
                                    snake_class(self)
                                  )

                                  # Make sure required_aes consists of the used set of aesthetics in case of
                                  # "|" notation in self$required_aes
                                  required_aes <- intersect(
                                    names(data),
                                    unlist(strsplit(self$required_aes, "|", fixed = TRUE))
                                  )

                                  data <- remove_missing(data, params$na.rm,
                                                         c(required_aes, self$non_missing_aes),
                                                         snake_class(self),
                                                         finite = FALSE
                                  )

                                  # Trim off extra parameters
                                  params <- params[intersect(names(params), self$parameters())]

                                  args <- c(list(data = quote(data), scales = quote(scales)), params)
                                  dapply(data, "PANEL", function(data) {
                                    scales <- layout$get_scales(data$PANEL[1])
                                    tryCatch(do.call(self$compute_panel, args), error = function(e) {
                                      warn(glue("Computation failed in `{snake_class(self)}()`:\n{e$message}"))
                                      new_data_frame()
                                    })
                                  })
                                })

#' @rdname stat_summarise
#' @usage NULL
#' @export
StatSummarize <- ggplot2::ggproto("StatSummarize",
                                  Stat,
                                  required_aes = c("domain"),
                                  compute_panel = function(self, data, scales, domain = NULL,
                                                           fun = NULL, args = list()) {
                                    #
                                    if (empty(data)) return(new_data_frame())
                                    #browser()

                                    if(is.null(fun)) {
                                      warn("fun is NULL, using length as default")
                                      fun <- length
                                    }

                                    groups <- split(data, data$group)
                                    stats <- lapply(groups, function(group){
                                      self$compute_group(data = group, fun = fun, args = args)
                                    })

                                    rbind_dfs(stats)
                                  },
                                  compute_group = function(self, data, scales,  fun = NULL, args = args){

                                    call_f <- function(fun = fun, x) {
                                      if (is.null(fun)) return(NA_real_)
                                      fun <- as_function(fun)
                                      do.call(fun, c(list(quote(x)), args))
                                    }
                                    data <- unique(transform(data, summarise = call_f(fun, domain), domain = NULL))
                                    data[['summarize']] <- data[['summarise']]
                                    data
                                  },
                                  compute_layer = function(self, data, params, layout) {
                                    check_required_aesthetics(
                                      self$required_aes,
                                      c(names(data), names(params)),
                                      snake_class(self)
                                    )

                                    # Make sure required_aes consists of the used set of aesthetics in case of
                                    # "|" notation in self$required_aes
                                    required_aes <- intersect(
                                      names(data),
                                      unlist(strsplit(self$required_aes, "|", fixed = TRUE))
                                    )

                                    data <- remove_missing(data, params$na.rm,
                                                           c(required_aes, self$non_missing_aes),
                                                           snake_class(self),
                                                           finite = FALSE
                                    )

                                    # Trim off extra parameters
                                    params <- params[intersect(names(params), self$parameters())]

                                    args <- c(list(data = quote(data), scales = quote(scales)), params)
                                    dapply(data, "PANEL", function(data) {
                                      scales <- layout$get_scales(data$PANEL[1])
                                      tryCatch(do.call(self$compute_panel, args), error = function(e) {
                                        warn(glue("Computation failed in `{snake_class(self)}()`:\n{e$message}"))
                                        new_data_frame()
                                      })
                                    })
                                  })


suppressPackageStartupMessages(library(optparse, warn.conflicts=F, quietly=T))

option_list <- list(
  make_option(c("-f", "--file"),
              type="character",
              default=NA,
              help="Path of BAM file to process"),
  make_option(c("-e", "--extension"),
              type="character",
              default="native",
              help="Extension length ('native' for no extension, 'auto' to estimate fragment size)")
  )

readBAM <- function(filepath) {
  bam.gr <- granges(readGAlignments(filepath))
  bam.gr
}

write_bigwig <- function(cov, filename) {
  message(id, "Writing bigWig...")
  export(cov, filename)
}

filter_chrs <- function(gr) {
  exclude.chrs <- grep("H|M|U", seqlevels(gr))
  if(length(exclude.chrs) > 0) {seqlevels(gr, pruning.mode="coarse")<- seqlevels(gr)[-exclude.chrs]}
  gr
}

pn <- function(value) {
  prettyNum(value, big.mark=",")
}

# ------------------------------------------------------------------------------
opt <- parse_args(OptionParser(option_list=option_list))

if(is.na(opt$file)) {
  message("No BAM file specified. Use --help to list available options.")
  q(status=1)
}

suppressPackageStartupMessages(library(Rsamtools, warn.conflicts=F, quietly=T))
suppressPackageStartupMessages(library(chipseq, warn.conflicts=F))
suppressPackageStartupMessages(library(rtracklayer, warn.conflicts=F))
suppressPackageStartupMessages(library(GenomicAlignments))

# used as a prefix for all output messages
id <- "[unknown] "

bam_file      <- opt$file
ext_length    <- opt$extension

var_name <- gsub("\\.bam$", "", bam_file)

id <- paste("[", var_name, "] ", sep="")

bigwig_file   <- paste0(var_name, ".bw")
granges_file <- paste0(var_name, ".granges.rds")

message(id, "Converting BAM to GRanges object:")
message(id, "Input BAM: ", bam_file)
message(id, "Output: ", granges_file)

if(!file.exists(bam_file)) {
	stop("Could not open BAM file: ", bam_file)
}

bam.gr <- readBAM(bam_file)

message(id, "Estimating fragment length...")
estimates <- estimate.mean.fraglen(filter_chrs(bam.gr), method="coverage")
counts <- table(seqnames(bam.gr))
est.frag.size <- as.integer(weighted.mean(estimates, counts[names(estimates)]))

if(ext_length == "native") {
	ext_length <- NULL
} else {
	if(ext_length == "auto")
	  ext_length <- est.frag.size
	else
	  ext_length <- as.integer(ext_length)
}

message(id, "Extension length: ", ifelse(is.null(ext_length), "native", ext_length))

if(!is.null(ext_length)) bam.gr <- trim(resize(bam.gr, ext_length))

message(id, "Saving GRanges object...")
bam.gr <- bam.gr[order(bam.gr)]
saveRDS(bam.gr, file=granges_file)

nothing <- write_bigwig(coverage(bam.gr), bigwig_file)


library(wordcloud)
#Let’s create a list of words (Random words concerning my work)
#I give a frequency to each word of this list
b=sample(seq(0,1,0.01) , length(a) , replace=TRUE) The package will automatically make the wordcloud !
a=c("Cereal","WSSMV","SBCMV","Experimentation","Talk","Conference","Writing", "Publication","Analysis","Bioinformatics","Science","Statistics","Data", "Programming","Wheat","Virus","Genotyping","Work","Fun","Surfing","R", "R","Data-Viz","Python","Linux","Programming","Graph Gallery","Biologie", "Resistance","Computing","Data-Science","Reproductible","GitHub","Script")
par(bg="black")
wordcloud(a , b , col=terrain.colors(length(a) , alpha=0.9) , rot.per=0.3 )


#!/usr/bin/env Rscript
#	preliminary analysis of data collected from 3D models from Piceance basin
#	Eric Barefoot
#	Oct 2019

# import libraries

library(tidyverse)
library(here)
library(broom)
library(purrr)
library(rsample)

# load data (3D model, field, and combined)

model = readRDS(file = here('data','derived_data','piceance_3d_model_data_reinterpreted.rds'))
field = readRDS(file = here('data','derived_data','piceance_field_data.rds'))
combined = readRDS(file = here('data', 'derived_data', 'piceance_field_model_data.rds'))

# first, lets just look at the bars, and calculate the relative abundance of fully preserved barforms.

just_bars_models = model %>% filter(interpretations %in% c('full','partial','truncated'))

model_boots = just_bars_models %>% nest(-formation) %>% mutate(boots = map(data, ~ bootstraps(., times = 100))) %>% unnest(boots)

calcFullFrac = function(split)
{
  analysis(split) %>% group_by(interpretations) %>% summarize(count = n())
}

boot_counts = model_boots %>% mutate(stats = map(splits, calcFullFrac))

percent_preserved = boot_counts %>% unnest(stats) %>% group_by(id, formation) %>% summarize(perc_full = count[interpretations == 'full'] / sum(count))

saveRDS(percent_preserved, file = here('data', 'derived_data', 'piceance_bar_preservation.rds'))

# percent_preserved %>% ggplot() + geom_step(aes(x = perc_full, y = ..density.., color = formation), stat = 'bin')

# geom_histogram(aes(x = perc_full, fill = formation)) + facet_wrap(vars(formation), ncol = 1)


source("R/header.r")
myPalette <- colorRampPalette((brewer.pal(9, "YlOrRd")), space="Lab")
myPalette<-brewer.pal(9, "YlOrRd")

theme_opts <- list(theme(
			panel.grid.minor = element_blank(),
                        panel.grid.major = element_blank(),
                       # panel.background=element_blank(),
                        panel.background = element_rect(color = "black",fill=NA,  size = .5, linetype = "solid"),
                        #panel.border=element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        plot.background = element_blank(),
                        plot.background=element_blank(),
                        panel.border=element_rect(color = "black",fill=NA,  size = .5, linetype = "solid"),
                        legend.position="right",
                        #panel.border = element_blank(),
                        #axis.line = element_blank(),
                        #axis.text.x = element_blank(),
                        #axis.text.y = element_blank(),
                        #axis.ticks = element_blank(),
                        #panel.margin = unit(5,"lines"),
                        #panel.margin = unit(0,"null"),
                        #plot.margin = rep(unit(0,"null"),4),
                        axis.title.x = element_blank(),
                        axis.title.y = element_blank(),
                        plot.title = element_text()))

 nc<-new("mapncdf", filename="data/Climate_CX_v2_2000.nc",
 		varname="TmaxdegC",start_ind=c(1,1,180),count_ind=c(-1,-1,1))
 #nc<-new("mapncdf", filename="data/tas_A1_2.nc",
# 		varname="tas",start_ind=c(1,1,1),count_ind=c(-1,-1,1))

 kkk1<-mapConvert(nc)
 kkk1$dataframe$lat<- kkk1$dataframe$lat-0.25/2
 kkk1$dataframe$lon<- kkk1$dataframe$lon-0.25/2

 kkk<-kkk1
 from<-"+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"
to<-"NA"
 to<-"+proj=laea +lat_0=52   +lon_0=10      +x_0=3 210 000    +y_0=4 321 000"
 #to<-"+proj=robin"
  coordinates(kkk1$dataframe)<- ~lon+lat
  kkk1<-kkk1$dataframe
  projection(kkk1)<-from
  lines_proj<-graticules(10,5,proj=to)

   lines<-lines2dataframe(lines_proj)
    kkk<-mapProjection(kkk,from,to)

 knn<-kkk[!is.na(kkk$val),]

classifyMap<-function(map,class,prec=1){
	len<-length(map[[1]])
	ind<-sort(rep(seq(1,class),length.out=len))
	map<-map[order(map$val),]
	map<-data.frame(map,"class"=ind)

	text<-vector()
	for(i in 1:class){
		minval<-map$val[min(which(map$class==i))]
		maxval<-map$val[max(which(map$class==i))]
		text[i]<-paste(round(minval,digits=prec)," - ",round(maxval,digits=prec),sep="")
	}
	out<-list()
	out[["map"]]<-map
	out[["range"]]<-text
	return(out)
}
map<-classifyMap(knn,9,prec=0)
knn<-map$map
labels<-map$range

 knn<-cutWindow(knn,proj=to,window=c(-10,45,25,46))
 boundary<-c(min(knn$lon),max(knn$lon),min(knn$lat),max(knn$lat))

 plot.title = paste("LPJmL 0.25 Degree NCDF Climate Inputs")
 plot.subtitle = "Parameter: daily average tas - Time: 2006-07-01"
p<-gratText(lines_proj,boundary)
 g<-ggplot(knn,aes(lon,lat))+geom_raster(aes(fill=class))+
# scale_fill_manual(values=myPalette(12))+
# scale_fill_gradient(low = "pink", high = "green")+
     scale_fill_gradientn(colours=myPalette, na.value="white",breaks=c(9:1),labels=rev(labels),
 		      guide= guide_legend(title=expression(degree~C), title.position="top",#guide_legend
 			          barwidth = 1, barheight = 10, direction="vertical",
 			     draw.ulim = T, draw.llim =T ))+
#   scale_colour_brewer() +
 		      theme_opts+
 		      coord_equal()+
 		      ggtitle(bquote(atop(.(plot.title), atop(italic(.(plot.subtitle)), ""))))+
 		      scale_x_continuous(limits = c(min(knn$lon), max(knn$lon)), expand = c(0, 0),
			    breaks=as.vector(p$x[,1]),
			    labels=bquote(.(as.vector(p$x$txt))))+
 		      scale_y_continuous(limits = c(min(knn$lat), max(knn$lat)), expand = c(0, 0),
			    breaks=as.vector(p$y[,1]), labels=p$y[,2])+
 		      geom_path(data=lines,aes(lon,as.numeric(lat),group=group),color="grey",size=0.25)#graticules

#  		      annotation_custom(a, xmin=0, xmax=Inf, ymin=0, ymax=Inf)

 country<-new("shapefile",dir="data/admin_countries/10m/",layer="ne_10m_admin_0_countries",
 	     proj_to= to)

d<-addLines(country,gg=g,size=0.35)
#
saveMap(paste("std_window_discrete.jpeg",sep=""),d, LOGO=TRUE,width=7,height=4)


#' Visualization of Empirical Analysis of RCTs
#'
#' @description This is an S3 generic function for visualizing RCT analysis.
#' RCTtoolbox provides a method for t_test (generated by the ttest function).
#'
#' @param \dots Specify the arguments to pass to this function.
#' The first argument must be a dataframe
#' with a class supported by rct_plot (t_test).
#' You can check the arguments that can be passed in
#' the t_test class with [rct_plot.t_test()].
#'
#' @export
#'
rct_plot <- function(...) {
  UseMethod("rct_plot")
}

#' Visualization of T-test Result
#'
#' @description This is a function that visualizes
#' the result of the t-test executed by the `ttest` function with {ggplot2}.
#'
#' @param data tibble or data.frame with "t_test" class.
#' @param confint logical.
#' Specify whether error bars represent 95% confidence intervals.
#' @param label character. See details.
#' @param label_digits numeric. See details.
#' @param xlab character. Specify title of x-axis.
#' Default is "Treatments".
#' @param ylab character. Specify title of y-axis.
#' Default is NULL.
#' If NULL, the title of y-axis is "Average (+/- Std.Err)" or
#' "Average (+/- 95%CI)".
#' @param title character. Specify title of plot.
#' Default is NULL.
#' If NULL, the label of outcome variable is plot title.
#' @param caption character. Specify caption of plot.
#' @param text_size numeric. Sepecify font size of label.
#' Default is 5.
#' @param text_adjust numeric.
#' Specify a value that corrects the label position along the y-axis.
#' @param font_family character. Specify font family. Default is NULL.
#' @param ylim a numeric vector of bounds of y-axis.
#' @param flip logical. Specify whether to swap the x-axis and y-axis.
#' Default is FALSE.
#' @param facet_wrap logical. Whether to use `ggplot2::facet_wrap`
#' @param \dots other arugments passing `simplegg`.
#'
#' @details By using the `label` argument,
#' the result of the t-test can be embedded in the plot as text.
#' The result of the t-test can be specified by \{\{type\}\}.
#' If \{\{mean\}\}, the mean value of each group is embedded.
#' If \{\{se\}\}, the standard error of the mean of each group is embedded.
#' If \{\{effect\}\}, the effect of each group is embedded.
#' If \{\{pvalue\}\}, the p-value of each group effect is embedded.
#' If \{\{star\}\}, the p-value star of each group effect is embedded.
#' Combining these four, you specify the output of the text.
#' For example, if the mean is 0.5 and its standard error is 0.1,
#' then specifying "\{\{mean\}\}(\{\{se\}\})" will embed "0.5(0.1)" in the plot.
#' You can use the `label_digits` argument to specify
#' the number of decimal places to display (Default is 3).
#' The font size of label can by specified by `text_size` argument.
#' The default is 5.
#'
#' @method rct_plot t_test
#' @importFrom ggplot2 aes
#' @importFrom ggplot2 ggplot
#' @importFrom ggplot2 geom_bar
#' @importFrom ggplot2 geom_errorbar
#' @importFrom ggplot2 geom_hline
#' @importFrom ggplot2 geom_text
#' @importFrom ggplot2 labs
#' @importFrom ggplot2 coord_flip
#' @importFrom ggplot2 facet_wrap
#' @importFrom ggplot2 ylim
#' @importFrom forcats fct_rev
#' @export
#'
#' @examples
#' # DGP
#' set.seed(120511)
#' n <- 1000
#' x1 <- rnorm(n); x2 <- rnorm(n)
#' d1 <- sample(c("A", "B", "C"), size = n, replace = TRUE)
#' d2 <- ifelse(d1 == "A", "control", "treat")
#' ya <- 0.2 + 0.5 * x1 + 0.01 * x2
#' yb <- 1.2 + 0.3 * x2
#' yc <- 0.2 * x1 + 0.5 * x2
#' y1 <- ifelse(d1 == "A", ya, ifelse(d1 == "B", yb, yc))
#' y2 <- ifelse(y1 > 1, 1, 0)
#' dt <- data.frame(
#'   outcome = y1,
#'   bin_outcome = y2,
#'   treat = d1,
#'   bin_treat = d2,
#'   x1,
#'   x2
#' )
#'
#' # t-test
#' set_optRCTtool(outcome ~ treat, ~ x1 + x2, dt, "A")
#' est <- mean_diff_test(data = dt)
#'
#' # visualization
#' rct_plot(
#'   est,
#'   label = "{{mean}} [{{effect}}{{star}}]",
#'   title = "Simulated Outcome"
#' )
#'
rct_plot.t_test <- function(
  data, confint = FALSE,
  label = "{{mean}}{{star}}", label_digits = 3,
  xlab = "Treatments", ylab = NULL,
  title = NULL, caption = NULL,
  text_size = 5, text_adjust = 0.2,
  font_family = getOption("RCTtool.plot_family"),
  ylim = NULL, flip = FALSE, facet_wrap = FALSE,
  ...
) {
  treat <- ymin <- ymax <- labpos <- NULL
  # errorbar
  z <- ifelse(confint, 1.96, 1)
  data$ymin <- data$mean - data$se * z
  data$ymax <- data$mean + data$se * z

  # label
  if (!is.null(label)) {
    data$label <- mapply(
      ttest_label_maker,
      data$mean, data$se, data$effect, data$p.value,
      MoreArgs = list(label = label, digits = label_digits)
    )
    data$labpos <- ifelse(
      data$ymax < 0,
      data$ymax - text_adjust,
      data$ymax + text_adjust
    )
  }

  # plot
  if (flip) {
    plot <- ggplot2::ggplot(
      data, ggplot2::aes(x = forcats::fct_rev(treat), y = mean)
    )
  } else {
    plot <- ggplot2::ggplot(data, ggplot2::aes(x = treat, y = mean))
  }

  plot <- plot +
    ggplot2::geom_bar(
      stat = "identity", fill = "grey80", color = "black"
    ) +
    ggplot2::geom_errorbar(
      ggplot2::aes(ymin = ymin, ymax = ymax), width = 0.5
    ) +
    ggplot2::geom_hline(
      ggplot2::aes(yintercept = 0)
    )

  if (!is.null(label)) {
    plot <- plot +
      ggplot2::geom_text(
        ggplot2::aes(y = labpos, label = label),
        size = text_size
      )
  }

  if (facet_wrap) plot <- plot + ggplot2::facet_wrap(~ outcome)
  if (!is.null(ylim)) plot <- plot + ggplot2::ylim(ylim)

  if (is.null(ylab)) {
    ylab <- ifelse(confint, "Average (+/- 95%CI)", "Average (+/- Std.Err)")
  }

  plot <- plot +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      title = title,
      caption = caption
    )

  if (flip) plot <- plot + ggplot2::coord_flip()

  plot + simplegg(flip = flip, font_family = font_family, ...)
}


parse_celltype=function(x,group.by){
	require(stringr)
        do.call("rbind", apply(as.data.frame(x),1,function(x){
                do.call("rbind", lapply(str_extract_all(x[3],"\\w+")[[1]], function(y) c(unlist(x[group.by]),feature=y)))
        }))
}

## example
r0=read_sheet("https://docs.google.com/spreadsheets/d/1r1A1NRPK4muWyhqQOFAzs2dQ_v7d71otYWVuQnhG_cs/edit#gid=0",sheet="used_bulk")
r=parse_celltype( r0,1)
r=data.table(r)[, .(cell_type=paste(cell_type,collapse="|")), by=feature]

myboxplot = function(df,features,group){
	require("tibble")
	require("dplyr")
	require("reshape2")

	fea=match(features,row.names(d))
	features=features[!is.na(fea)]
	df$RNA@data[features,] %>%
        data.frame(check.names=F) %>% rownames_to_column( "feature") %>%
        filter(feature %in% features) %>%
        melt(id.var="feature") %>%
        filter(value > 0) %>%
        mutate(group=df@meta.data[[ group ]][ match(variable,colnames(df))]) %>%
        mutate(feature=factor(feature,levels=features)) %>%
        ggplot(aes(x=feature, y=value,fill=feature)) +
        geom_boxplot() + facet_wrap(~group)
}

# assign cell-types by maximum cell type average
# make this reusable
mycelltype = function(){
i="Global"
m=do.call("rbind",apply(as.data.frame(m0[m0$cell_group==i,]),1,function(x){
        do.call("rbind", lapply(str_extract_all(x[3],"\\w+")[[1]], function(y) c(unlist(x[2]),feature=y)))
}))
m=as.data.frame(m)

i=match(m$feature,row.names(d));i=i[!is.na(i)]
y=d$RNA@data[i,]
y=merge(data.frame(feature=row.names(y),y), m)

## simple cell identification
y1=y[,2:(ncol(y)-1)] %>%
        aggregate.Matrix( groupings = y$cell_type, fun="mean")
d$cell_type= row.names(y1)[ apply(y1,2,function(x) which(x==max(x))[1] ) ]

}

## this draws cell type proportions per sample
## make this reusable
mybarplot = function(){
	x=d@meta.data %>% group_by(orig.ident,cell_type,repairment) %>% summarize(num.cells=n(),cc= min(clonecount_k5cell))
	x$id=factor(x$orig.ident,levels= unique(x$orig.ident[order(x$cc)]))

        ggplot(x, aes(x=id,y=num.cells,fill=cell_type)) + geom_bar(stat="identity")  +
        geom_line(aes(x=id,y=cc*100),col="blue",group=1) +
        scale_y_continuous(sec.axis=sec_axis(~./100,name="clone count/K5"))
}

#
# orig.ident x clusters : cell counts
#
countcell=function(seurat.obj){
	require(reshape2)
	require(tibble)

	seurat.obj@meta.data %>%
	group_by(orig.ident,seurat_clusters) %>% count %>%
	dcast(orig.ident ~ seurat_clusters,fill=0) %>%
	column_to_rownames("orig.ident")
}

#
# avgexp
#
# note: set active ident before runing d = SetIdent(d, value= "..")
# usage: avg=avgexp(d)

avgexp = function(seuratobj){
        require(Matrix.utils)
        require(tibble)
        require(dplyr)
        avg = t(seuratobj$RNA@data) %>%
                aggregate.Matrix( groupings=Idents(seuratobj), fun = "mean") %>%
                t() %>% data.frame(check.names=F) %>% rownames_to_column(var="feature")
}

#
# Heatmap of markers
#  markers: (feautre, type) columns

myheatmap=function(avgexp, markers){
	require(ComplexHeatmap)
	avg1=merge(avgexp,markers,by="feature")
	avg.m=avg1[,2:(ncol(avg))]
	row.names(avg.m) = make.names(avg1$feature,unique=TRUE)
	ha=rowAnnotation( type=avg1$type )
	Heatmap((avg.m), row_split=avg1$type,row_title_rot=0,
		row_names_gp = gpar(fontsize = 8)) # right_annotation=ha)
}