library(raster)
library(sp)
library(dplyr)
library(rgdal)
library(rgeos)
library(maptools)
library(countrycode)
library(ggmap)

# Increase memory size
memory.limit(size = 1e9)

# set working drive
setwd( 'P:/is-wel/indus/message_indus' )

# Set basin name
basin = 'Indus'

######################################
# Get basin units from Hydrobasins DB
######################################

# Mapping of names of the basins to be included (from FAO basin naming convention)
hydrobasins_names_mapping.df = data.frame(read.csv('input/hydrosheds/hydrobasins/hydroBASINS_names.csv', header = TRUE, stringsAsFactors = FALSE))
hydrobasins_1.spdf = readOGR('input/hydrosheds/hydrobasins/delineated_basins', 'hydrobasins_level_1', verbose=FALSE, stringsAsFactors = FALSE)
hydrobasins_2.spdf = readOGR('input/hydrosheds/hydrobasins/delineated_basins', 'hydrobasins_level_2', verbose=FALSE, stringsAsFactors = FALSE)
hydrobasins_3.spdf = readOGR('input/hydrosheds/hydrobasins/delineated_basins', 'hydrobasins_level_3', verbose=FALSE, stringsAsFactors = FALSE)
hydrobasins_4.spdf = readOGR('input/hydrosheds/hydrobasins/delineated_basins', 'hydrobasins_level_4', verbose=FALSE, stringsAsFactors = FALSE)

# Get the basin spdf using the name mapping.
hybas_ids = hydrobasins_names_mapping.df$HYBAS_ID[which(hydrobasins_names_mapping.df$NAME == basin)]
pfaf_ids = hydrobasins_1.spdf@data$PFAF_ID[hydrobasins_1.spdf@data$HYBAS_ID == hybas_ids]
basin.spdf = hydrobasins_1.spdf[which(floor(as.numeric(hydrobasins_1.spdf@data$PFAF_ID)) %in% pfaf_ids),]
basin.sp = spTransform( as( basin.spdf, 'SpatialPolygons' ), crs( basin.spdf ) )

# Get lower level catchments
basin2.spdf = hydrobasins_2.spdf[ which( !is.na( over( gCentroid( hydrobasins_2.spdf, byid=TRUE ), basin.sp ) ) ), ]
basin3.spdf = hydrobasins_3.spdf[ which( !is.na( over( gCentroid( hydrobasins_3.spdf, byid=TRUE ), basin.sp ) ) ), ]
basin4.spdf = hydrobasins_4.spdf[ which( !is.na( over( gCentroid( hydrobasins_4.spdf, byid=TRUE ), basin.sp ) ) ), ]

# Indus specifics
if( basin == 'Indus' )
	{

	# Manually checked
	bsn_lo.spdf = basin2.spdf[ which( as.numeric( basin2.spdf@data$HYBAS_ID ) == 4040794730 ) , ]
	bsn_lo.sp = spTransform( as( bsn_lo.spdf, 'SpatialPolygons' ), crs( bsn_lo.spdf ) )

	# Remaining units
	bsn_lo2.spdf = basin2.spdf[ which( as.numeric( basin2.spdf@data$HYBAS_ID ) != 4040794730 ) , ]
	bsn_lo2.sp = spTransform( as( bsn_lo2.spdf, 'SpatialPolygons' ), crs( bsn_lo2.spdf ) )

	# Manually checked
	bsn_md.spdf = basin3.spdf[ which( as.numeric( basin3.spdf@data$HYBAS_ID ) == 4050786190 ) , ]
	bsn_md.sp = spTransform( as( bsn_md.spdf, 'SpatialPolygons' ), crs( bsn_md.spdf ) )

	# Join other units
	bsn_md2.spdf = basin3.spdf[ which( 	as.numeric( basin3.spdf@data$HYBAS_ID ) != c( 4050786190 ) &
										!is.na( over( gCentroid( basin3.spdf, byid=TRUE ), bsn_lo.sp ) ) ), ]
	bsn_md2.sp = spTransform( gUnaryUnion( as( bsn_md2.spdf, 'SpatialPolygons' ) ), crs( bsn_md2.spdf ) )

	# Manually checked units to include
	bsn_hi.spdf = basin4.spdf[ which( as.numeric( basin4.spdf@data$HYBAS_ID ) %in% c( 4060746720,4060729320, 4060729330 ) ), ]
	bsn_hi.sp = spTransform( as( bsn_hi.spdf, 'SpatialPolygons' ), crs( bsn_hi.spdf ) )

	# Join other units
	bsn_hi2.spdf = basin4.spdf[ which( 	!( as.numeric( basin4.spdf@data$HYBAS_ID ) %in% c( 4060746720,4060729320, 4060729330 ) ) &
										!is.na( over( gCentroid( basin4.spdf, byid=TRUE ), bsn_md.sp ) ) ), ]
	bsn_hi2.sp = spTransform( gUnaryUnion( as( bsn_hi2.spdf, 'SpatialPolygons' ) ), crs( bsn_hi2.spdf ) )

	# windows()
	# plot(bsn_lo2.sp)
	# plot(bsn_md2.sp,add=TRUE,col='green')
	# plot(bsn_hi.sp,add=TRUE,col='red')
	# plot(bsn_hi2.sp,add=TRUE,col='blue')

	# Combine into basin units
	basin_units.sp = rbind( bsn_hi.sp, bsn_hi2.sp, bsn_md2.sp, bsn_lo2.sp, makeUniqueIDs=TRUE )
	row.names(basin_units.sp) = paste( basin, seq(1,length(basin_units.sp),by=1), sep = '|' )

	}else{

	# Use level 2
	basin_units.sp = spTransform( as( basin2.spdf, 'SpatialPolygons' ), crs( basin2.spdf ) )
	row.names(basin_units.sp) = paste( basin, seq(1,length(basin_units.sp),by=1), sep = '|' )

	}

###########################
# Get the riparian nations
############################

gadm.spdf = readOGR('input/country_delineation/gadm/output_data', 'gadm_country_boundaries', verbose=FALSE)

# First filter using extents
riparian_nations.spdf = gadm.spdf[ 	which( !is.na( unlist( lapply( 1:length( gadm.spdf ), function( iii ){ if( !is.null( intersect( extent( gadm.spdf[iii,] ), extent( basin.sp ) ) ) ){ return( iii ) }else{ return(NA) } } ) ) ) ), ]

# Second filter using gIntersects - much faster than intersecting the whole global map
riparian_nations.spdf = riparian_nations.spdf[ which( gIntersects( riparian_nations.spdf, basin.sp, byid = TRUE ) ), ]

# Indus specifics - remove nepal
if( basin == 'Indus' ){ riparian_nations.spdf = riparian_nations.spdf[ -1*which( riparian_nations.spdf@data$ISO == 'NPL' ), ] }

row.names( riparian_nations.spdf ) = paste( as.character( riparian_nations.spdf@data$ISO ), '1', sep = '_' )

# Get provinces for each country
keep_country = NULL
if( basin == 'Indus' ){ keep_country = c('AFG','CHN') }
country2split = unique( as.character( riparian_nations.spdf@data$ISO ) )[ which( !( unique( as.character( riparian_nations.spdf@data$ISO ) ) %in% keep_country ) ) ]
province.spdf = do.call( rbind, lapply( country2split, function( cnt ){
	cwd = getwd()
	setwd( 'P:/is-wel/indus/message_indus/input' )
	res = getData( 'GADM', country = cnt, level = 1 )
	row.names(res) = paste( res@data$ISO[1], seq( 1, length( res ) ), sep = '_' )
	setwd(cwd)
	return( res )
	} ) )
province.spdf@data = province.spdf@data %>%
						select( ISO, NAME_1 ) %>%
						rename( NAME = NAME_1 ) %>%
						mutate( REGION = riparian_nations.spdf@data$REGION[ match( ISO, riparian_nations.spdf@data$ISO ) ] ) %>%
						mutate( STATUS = riparian_nations.spdf@data$STATUS[ match( ISO, riparian_nations.spdf@data$ISO ) ] ) %>%
						mutate( CONTINENT = riparian_nations.spdf@data$CONTINENT[ match( ISO, riparian_nations.spdf@data$ISO ) ] ) %>%
						select( ISO, NAME, REGION, STATUS, CONTINENT ) %>%
						'rownames<-'( row.names( province.spdf@data ) )

# Combine provinces with countries remaining
admin.spdf = rbind( province.spdf, riparian_nations.spdf[ match( keep_country, as.character( riparian_nations.spdf$ISO ) ), ] )
admin.spdf@data =  admin.spdf@data %>%
					mutate( NAME = unlist( sapply( NAME, function( nnn ){ paste( unlist( strsplit( nnn, '[ ]' ) ), collapse = '_' ) } ) ) ) %>%
					mutate( NAME = unlist( sapply( NAME, function( nnn ){ paste( unlist( strsplit( nnn, '[.]' ) ), collapse = '' ) } ) ) ) %>%
					mutate( PID =  unlist( sapply( 1:length(NAME), function( nnn ){ paste( ISO[nnn], NAME[nnn], sep = '|' ) } ) ) ) %>%
					mutate( PID = sapply( 1:length(PID), function( nnn ){ if( duplicated(PID)[nnn] ){ return( paste(PID[nnn],'b',sep='_') ) }else{ return(PID[nnn]) } } ) ) %>%
					select( PID, ISO, NAME, REGION, STATUS, CONTINENT )
row.names( admin.spdf )	= as.character( admin.spdf@data$PID )

######################################################################################
# Create new polygons representing the intersection between countries and catchments
######################################################################################

# Harmonize and intersect
admin.sp = spTransform( as( admin.spdf, 'SpatialPolygons' ), crs(basin_units.sp) )
bcus.sp = raster::intersect( admin.sp, gBuffer( basin_units.sp , byid=TRUE, width=0 ) )
row.names(bcus.sp) = c( as.matrix( sapply( names(bcus.sp), function( nnn ){ paste( names( admin.sp )[ as.numeric( unlist( strsplit( nnn, '[ ]' ) ) )[1] ], names( basin_units.sp )[ as.numeric( unlist( strsplit( nnn, '[ ]' ) )[2] ) ], sep='__' ) } ) ) )

# Dissaggregate non-touching polygons
temp = disaggregate( SpatialPolygonsDataFrame(  bcus.sp, data.frame( ID = row.names( bcus.sp ), row.names = row.names( bcus.sp ) ) ), byid=TRUE )
newid1 = unlist( strsplit( as.character( temp@data$ID ), '__' ) )[seq(1,2*length(temp),by=2)]
newid2 = unlist( strsplit( as.character( temp@data$ID ), '__' ) )[seq(2,2*length(temp),by=2)]
for( j in unique(newid2) ){ newid2[ which( newid2 == j ) ] = paste( j, seq(1,length(which( newid2 == j )),by=1), sep='.' ) }
newid = paste( newid1, newid2, sep = '__' )
temp@data$ID = newid
row.names(temp) = newid
bcus.sp = spTransform( as(temp,'SpatialPolygons'), crs(basin_units.sp) )

# Dissolve smaller
pcheck = names( bcus.sp )[ which( gArea(bcus.sp,byid=TRUE) < 0.1 ) ]
temp = bcus.sp
if( length( pcheck ) > 0 )
	{

	for( j in pcheck )
		{

		# Delete small polygon from spdf
		temp = temp[ -1*which(names(temp)==j) ]

		# Check if small polygon touching another polygon, if touching dissolve, else remove
		if( length( which( gTouches( bcus.sp[ j ], temp, byid = TRUE ) ) ) > 0 )
			{

			# Find  and isolate largest neighbor
			big = temp[ which( gTouches( bcus.sp[ j ], temp, byid = TRUE ) ) ]

			# Keep neighbors from same country if possible
			if( length( which( grepl( strsplit( strsplit( j, '__')[[1]][1], '[|]' )[[1]][1], names(big) ) ) ) > 1 ){ big = big[ which( grepl( strsplit( strsplit( j, '__')[[1]][1], '[|]' )[[1]][1], names(big) ) ) ] }

			# Largest neighbour
			big = big[ which.max( gArea( big ) ) ]

			# Isolate small polygon
			sml = bcus.sp[ j ]

			# Combine small and large polygon maintaining the large polygon attributes
			cmb.sp = gUnaryUnion(rbind(big,sml,makeUniqueIDs=TRUE))
			row.names(cmb.sp) = row.names(big)

			# Remove big and add in the dissolved polygon back into the psdf
			temp = rbind( temp[ -1*which( names(temp) == names(big) ) ], cmb.sp )

			}

		}
	}

# Reset	and rename
newid = unlist( strsplit( names( temp ), '[.]' ) )[seq(1,2*length(temp),by=2)]
for( j in unique(newid) ){ newid[ which( newid == j ) ] = paste( j, seq(1,length(which( newid == j )),by=1), sep='.' ) }
row.names(temp) = newid
df = data.frame( 	t1 = unlist( strsplit( names(temp), '__' ) )[seq(1,2*length(temp),by=2)],
					t2 = unlist( strsplit( names(temp), '__' ) )[seq(2,2*length(temp),by=2)] )
temp = temp[ order(df$t1,df$t2 ) ]
bcus.sp = temp

# Correct any remaining holes from intersection
tmp = gUnaryUnion( bcus.sp )
holes = SpatialPolygons( lapply( 1:length( tmp@polygons[[1]]@Polygons ), function( iii ){ Polygons( list( tmp@polygons[[1]]@Polygons[[iii]] ),ID=iii) } ) )
proj4string(holes) = proj4string( bcus.sp )
holes = spTransform( holes, crs( bcus.sp ))
holes = holes[ which( gArea(holes,byid=TRUE) < 0.5 * gArea( basin.sp ) ) ]

temp = bcus.sp
if( length( holes ) > 0 )
	{

	for( j in 1:length(holes) )
		{

		# Check if small polygon touching another polygon, if touching dissolve, else remove
		if( length( which( gTouches( holes[ j ], temp, byid = TRUE ) ) ) > 0 )
			{

			# Find  and isolate largest neighbor
			big = temp[ which( gTouches( holes[ j ], temp, byid = TRUE ) ) ]

			# Largest neighbour
			big = big[ which.max( gArea( big ) ) ]

			# Isolate small polygon
			sml = holes[ j ]

			# Combine small and large polygon maintaining the large polygon attributes
			cmb.sp = gUnaryUnion(rbind(big,sml,makeUniqueIDs=TRUE))
			row.names(cmb.sp) = row.names(big)

			# Remove big and add in the dissolved polygon back into the psdf
			temp = rbind( temp[ -1*which( names(temp) == names(big) ) ], cmb.sp )

			}

		}
	}

bcus.sp = temp

######################################
# Reduced form flow network
######################################

# Flow accumulation tiles from hydrobasins
wkd_dir2 = c("input/hydrosheds/flow_accumulation/")
tiles = c('af','as','au','ca','eu','na','sa')
cnts = tiles[ which(  sapply( tiles, function(cnt) {

	ext = as( extent( stack( paste( paste( wkd_dir2, c(paste(cnt,'_acc_15s_grid/',paste(cnt,'_acc_15s/',sep=''),paste(cnt, '_acc_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) ) ), 'SpatialPolygons' )
	proj4string(ext) = proj4string( basin.sp )

	if( gIntersects( spTransform( ext, crs(basin.sp) ), basin.sp ) ){ return( TRUE ) }else{ return( FALSE ) }

	} ) ) ]

# Get flow accumulation for tiles and merge (if multiple)
flow_accumulation.raster = do.call( merge, lapply( cnts, function(cnt){

	res = stack( paste( paste( wkd_dir2, c(paste(cnt,'_acc_15s_grid/',paste(cnt,'_acc_15s/',sep=''),paste(cnt, '_acc_15s',sep=''),sep='')),sep='' ),'/', 'w001001.adf', sep='' ) )

	res = mask( x = crop( res, extent( basin.sp ), snap = "out" ), mask = rasterize( spTransform( basin.sp, crs( res ) ), crop( res, extent( basin.sp ), snap="out") ) )

	return( res )

	} ) )

# Find downstream polygon using flow accumulation
downstream.df = do.call( rbind, lapply( names( bcus.sp ), function( ppp ){

	# Mask for bcu
	bcu.raster = rasterize( spTransform( bcus.sp[ ppp ], crs( flow_accumulation.raster ) ), flow_accumulation.raster )
	bcu.raster[ bcu.raster > 0 ] = 1
	bcu.raster[ is.na(bcu.raster) ] = 0

	# Leftover flow accumulation
	mskd = flow_accumulation.raster * bcu.raster

	# Get adjacent cell to max flow accumulation within BCU
	around = matrix( c(	1, 1, 1,
						1, 0, 1,
						1, 1, 1 ), ncol = 3, byrow=TRUE )
	adj = data.frame( adjacent( flow_accumulation.raster, cell = which.max( mskd[] ), directions=around, sorted=TRUE, include = TRUE ) )

	# outlet location
	outlet = data.frame( xyFromCell( flow_accumulation.raster, which.max( mskd[] ) ) )

	# Downstream has mos flow accumulation
	to = SpatialPoints( xyFromCell( flow_accumulation.raster, adj$to[which.max( c( flow_accumulation.raster[ adj$to ] - max( mskd[], na.rm=TRUE ) ) )] ) )
	proj4string(to) = proj4string(bcus.sp)
	to = spTransform( to, crs( bcus.sp ) )
	down = names(bcus.sp)[ over( to, bcus.sp )[ which( over( to, bcus.sp ) != which( names( bcus.sp ) == ppp ) ) ] ]
	if( length(down) == 0 ){ down = NA }

	if( !is.na( down ) )
		{
		windows()
		plot( basin.sp )
		plot( bcus.sp[ppp],add=TRUE,col='red')
		plot( bcus.sp[down],add=TRUE,col='blue')
		legend( 'bottomright', c('upstream','downstream'), fill = c('red','blue'), bty = 'n', cex = 0.9 )
		}else{
		windows()
		plot( basin.sp )
		plot( bcus.sp[ppp],add=TRUE,col='purple')
		legend( 'bottomright', c('outlet'), fill = c('purple'), bty = 'n', cex = 0.9 )
		}

	return(data.frame( down = down, outx = outlet$x, outy = outlet$y ))

	} ) )
row.names( downstream.df ) = names( bcus.sp )

####################################################
# Specific regional aggregation (used for calibration)
#######################################################

# Default to basin name
region = rep( basin, length(bcus.sp) )

# Indus specific - for implementation of Indus Water Treaty Allocations
if( basin == 'Indus' )
	{

	# Grab the basin boundaries identified manually previously
	basint.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'indus_basin_units', verbose = FALSE )
	basint.spdf@data$river = 'pakistan'
	basint.spdf@data$river[which(basint.spdf@data$PID%in%c(2215, 2242, 2244, 2245, 2247))] = 'china'
	basint.spdf@data$river[which(basint.spdf@data$PID%in%c(2216, 2217, 2218, 2219, 2221, 2222, 2223, 2243, 2246))] = 'india_east'
	basint.spdf@data$river[which(basint.spdf@data$PID%in%c(2249, 2254, 2255))] = 'india_west'
	basint.spdf@data$river[which(basint.spdf@data$PID%in%c(2213, 2251))] = 'afghan_south'
	basint.spdf@data$river[which(basint.spdf@data$PID%in%c(2252))] = 'afghan_north'

	region = over( gCentroid( bcus.sp, byid=TRUE ), spTransform( basint.spdf, crs(bcus.sp) ) )$river

	}

##########################################
# Output as spatial polygons data frame
##########################################

bcus.df = data.frame( 	PID = names( bcus.sp ),
						ADMIN = unlist( strsplit( names(bcus.sp), '__' ) )[seq(1,2*length(bcus.sp),by=2)],
						SUBASIN = unlist( strsplit( unlist( strsplit( names(bcus.sp), '__' ) )[seq(2,2*length(bcus.sp),by=2)], '[.]' ) )[ seq(1,2*length(bcus.sp),by=2) ],
						OUTX = downstream.df$outx,
						OUTY = downstream.df$outy,
						DOWN = downstream.df$down,
						REGION = region,
						row.names = names( bcus.sp ) )
bcus.spdf = SpatialPolygonsDataFrame( bcus.sp, bcus.df )

# Write to file
writeOGR(
		bcus.spdf,
		'input',
		paste( basin, 'prov_bcu', sep = '_' ),
		driver="ESRI Shapefile",
		overwrite_layer=TRUE
		)

###########
# Test plot
###########

test.spdf = readOGR( 'input', paste( basin, 'prov_bcu', sep = '_' ), verbose = FALSE )

# Network
cnts = data.frame( test.spdf[,c('OUTX','OUTY')] )
starts = cnts[ which( !is.na( test.spdf@data$DOWN ) ), ]
ends = do.call( rbind, lapply( match( test.spdf@data$DOWN[ which( !is.na( test.spdf@data$DOWN ) ) ], test.spdf@data$PID ), function(iii){ cnts[ iii,  ] } ) )
l = vector("list", nrow(starts))
for (ll in seq_along(l)) {l[[ll]] = Lines(list(Line(rbind(starts[ll,  ], ends[ll,]))), as.character(ll))}
net.sldf = SpatialLinesDataFrame( SpatialLines(l), data.frame( max_flow = rep( 1, length(l)), row.names = row.names(SpatialLines(l)) ) )

# plot
regs = do.call( rbind, lapply( unique(test.spdf@data$REGION), function( rr ){
	res = gUnaryUnion( test.spdf[ which(test.spdf@data$REGION == rr),] )
	row.names(res) = as.character(rr)
	return(res)
	} ) )
#pdf(paste('input/',basin,'_delineation.pdf',sep=''))
windows()
par(mar=c(2,2,2,2), oma = c(2,2,2,2))
plot( basin.sp, border = alpha( c('black'), alpha=0.8 ))
plot( regs, border = NA, col = alpha( c('red','blue','chartreuse','orange','gold','purple'), alpha=0.2 ))
plot(bcus.sp,add=TRUE,col=NA,border='white' )
plot(net.sldf, add=TRUE, lwd = 2, pch = NA, lty = 1 )
plot(SpatialPoints( data.frame( test.spdf[,c('OUTX','OUTY')] ) ),pch =21, bg = 'white', col = 'black', cex= 1.2 , add=TRUE)

admin_basin.sp = gUnaryUnion( test.spdf, test.spdf@data$ADMIN )
require( RColorBrewer )
windows()
par(mar=c(2,2,2,2), oma = c(2,2,2,2))
plot( basin.sp, border = alpha( c('black'), alpha=0.8 ))
plot( admin_basin.sp, border = 'white', col = alpha( rev( brewer.pal(12, 'Set3' ) ), alpha=0.8 ) )
legend( 'bottomright', legend = c(names(admin_basin.sp)), fill = alpha( rev( brewer.pal(12, 'Set3' ) ), alpha=0.8 ), ncol = 1, cex=0.55, bty='n' )

#legend('topleft',legend = c(nms, 'Main outlet'), pch = c(rep( 21, length(nms)), 15), col=c(rep('black',length(nms)),'red'), pt.bg = c(cols,'red'), bty='n', ncol = 2, cex=1.1)
#dev.off()


library(tidyverse)
library(dyngen)
library(anndata)
library(ggplot2)

backbone_linear()

module_info <- tribble(
    ~module_id, ~basal, ~burn, ~independence,
    "Burn1", 1, TRUE, 1,
    "Burn2", 0, TRUE, 1,
    "Burn3", 1, TRUE, 1,
    "Burn4", 0, TRUE, 1,
    "Burn5", 1, TRUE, 1,
    "Burn6", 0, TRUE, 1,
    "A1", 0, TRUE, 1,
    "A2", 0, TRUE, 1,
    "A3", 0, TRUE, 1,
    "A4", 0, TRUE, 1,
    "X1", 0, TRUE, 1,
    "X2", 0, TRUE, 1,
    "X3", 0, TRUE, 1,
    "X4", 0, TRUE, 1,
    "Y1", 0, TRUE, 1,
    "Y2", 0, TRUE, 1,
    "Y3", 0, TRUE, 1,
    "Y4", 0, TRUE, 1
)

source_module_network <- tribble(
    ~from, ~to, ~effect, ~strength, ~hill,
    "Burn1", "Burn2", 1L, 1, 2,
    "Burn2", "A1", 1L, 1, 2,
    "A1", "A2", 1L, 10, 2,
    "A2", "A3", 1L, 10, 2,
    "A3", "A4", 1L, 10, 2,
    "A4", "A1", -1L, 10, 2,
    "Burn3", "Burn4", 1L, 1, 2,
    "Burn4", "X1", 1L, 1, 2,
    "X1", "X2", 1L, 10, 2,
    "X2", "X3", 1L, 10, 2,
    "X3", "X4", 1L, 10, 2,
    "X4", "X1", -1L, 10, 2,
)

source_expression_patterns <- tribble(
  ~from, ~to, ~module_progression, ~start, ~burn, ~time,
    "sBurn", "s1", "+Burn1,+Burn2,+Burn3,+Burn4,+A1,", TRUE, TRUE, 200,
    "s1", "s2", "+A2,-A3", FALSE, FALSE, 200,
    "s2", "s3", "+A3,-A4", FALSE, FALSE, 200,
    "s3", "s1", "+A4,-A1", FALSE,FALSE,200
)

# Create source model
source_backbone <- backbone(
  module_info = module_info,
  module_network = source_module_network,
  expression_patterns = source_expression_patterns
)

source_config <- initialise_model(
  backbone = source_backbone,
  num_cells = 20000,
  num_tfs = nrow(source_backbone$module_info),
  num_targets = 5,
  num_hks = 5,
  simulation_params = simulation_default(
    experiment_params = simulation_type_wild_type(num_simulations = 40),
    total_time = 500,
    census_interval = 1.,
  ),
  verbose = FALSE
)

print("###\n# START SOURCE\n###")
print("TF NETWORK")
source_model <- generate_tf_network(source_config)

print("FEATURE NETWORK")
source_model <- generate_feature_network(source_model)
# Save feature network
saveRDS(source_model$feature_network, file = "../output/source_feature_network_large_targets_5.rds")

print("GENERATE KINETICS")
source_model <- generate_kinetics(source_model)

print("GOLD STANDARD")
source_model <- generate_gold_standard(source_model)

print("CELLS")
source_model <- generate_cells(source_model)

print("EXPERIMENT")
source_model <- generate_experiment(source_model)
experiment_synchronised(
    source_model,
    realcount="regulatorycircuits_32_lung_epithelium_lung_cancer",
    map_reference_ls=TRUE
)

print("SAVE")
souce_ad <- as_anndata(source_model)
souce_ad$write_h5ad("../output/source_dataset_large_targets_5.h5ad")
souce_ad$write_csvs("../output/source_dataset_large_targets_5.csv")
saveRDS(source_model, file = "../output/source_model_large_targets_5.rds")


#!/usr/bin/env Rscript

##################################################################################################################################
############## FUNCTION TO CALCULATE AND PLOT CSI CTI AND CTRI OF communities  function:csi_cti_ctri    ##############################
##################################################################################################################################

#### Based on Romain Lorrillière R script
#### Modified by Alan Amosse and Benjamin Yguel for integrating within Galaxy-E

### made with R version 3.5.1

suppressMessages(library(RODBC))  ##Version: 1.3-15
suppressMessages(library(reshape))  ##Version: 0.8.8
suppressMessages(library(data.table))  ##Version: 1.12.0
suppressMessages(library(rgdal))  ##Version: 1.3-4
suppressMessages(library(lubridate))  ##Version: 1.7.4
suppressMessages(library(RPostgreSQL))  ##Version: 0.6-2
suppressMessages(library(doBy))  ##Version: 4.6-2
suppressMessages(library(arm))  ##Version: 1.10-1
suppressMessages(library(ggplot2))  ##Version: 3.1.0
suppressMessages(library(scales))  ##Version: 1.0.0
suppressMessages(library(mgcv))  ##Version: 1.8-24
suppressMessages(library(visreg))  ##Version: 2.5-0
suppressMessages(library(plyr))  ##Version: 1.8.4
suppressMessages(library(lme4))  ##Version: 1.1-18-1
suppressMessages(library(lmerTest))  ##Version: 3.1-0

###########
#delcaration des arguments et variables/ declaring some variables and load arguments

args = commandArgs(trailingOnly=TRUE)

if (length(args)!=5) {
    stop("At least 5 arguments must be supplied :\n- An input dataset filtered (.tabular). May come from the filter rare species tool.\n- A species detail table (.tabular)\n- A species ssi/sti table.\n- A table with plots coordinates.\n- table with csi calculated before 2001.\n\n", call.=FALSE) #si pas d'arguments -> affiche erreur et quitte / if no args -> error and exit1
} else {
    Datafiltered<-args[1] ###### Nom du fichier avec extension ".typedefichier", peut provenir de la fonction "FiltreEspeceRare" / file name without the file type ".filetype", may result from the function "FiltreEspeceRare"
    tabSpecies<-args[2] ###### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec specialisation à l'habitat des especes et si espece considérée comme indicatrice / file name without the file type ".filetype", file available in Galaxy-E containing habitat specialization for each species and whether or not they are considered as indicator
    tabssi<-args[3] ##### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec degre de specialisation de l espece et affinite thermique /file name without the file type ".filetype", file available in Galaxy-E containing specilalization degree as well as thermic preferences
    coordCarre<-[4] #### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec les coordonnees gps des carres /file name without the file type ".filetype", file available in Galaxy-E containing gps coordinates of the plots
	csibefore2001<-[5] #### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec les calcul de csi avant 2001 sur base de données différentes / file name without the file type ".filetype", file available in Galaxy-E containing csi calculated for years before 2001
}

#Import des données / Import data
tabCLEAN <- read.table(Datafiltered,sep="\t",dec=".",header=TRUE) #### charge le fichier de données d abondance / load abundance of species
tabsp <- read.table(tabSpecies,sep="\t",dec=".",header=TRUE)   #### charge le fichier de donnees sur nom latin, vernaculaire et abbreviation, espece indicatrice ou non / load the file with information on species specialization and if species are indicators

spTrait=read.csv2("tabssi") ############# species_indicateur_fonctionnel.csv  doit posseder au moins une colonne ssi, une colonne thermal_niche_mean  /
coordCarre=read.csv2("coordCarre") ######## carre.csv  charge les coordonnées des carrés qui sont utilisés comme covariable  /
csibefore2001=read.csv2("csibefore2001")##### csi_init.csv

######### Calcul du csi (indice de specialisation à l'habitat) / Calculation of the csi (index of habitat specialization)
tabCLEAN$ssi=spTrait$ssi[match(tabCLEAN$espece,spTrait$pk_species)] ### recupere donnee de ssi par espece calcule a partir des cv entre habitat obtenu a partir des occurences par carre et descriptif des habitats de chaque carre / retrieve ssi data for each species based on their variation coeffficent between habitat described for each plots
tabCLEAN$longitude_grid_wgs84=coordCarre$longitude_grid_wgs84[match(tabCLEAN$carre,coordCarre$pk_carre)] #### recupere les coordonnees carres
tabCLEAN$latitude_grid_wgs84=coordCarre$latitude_grid_wgs84[match(tabCLEAN$carre,coordCarre$pk_carre)]#### recupere les coordonnees carres

ssicarre=aggregate(ssi*abond~annee+carre,tabCLEAN,sum) ### ssi totale par annee et carre pondere par les abondances / ssi total per year and per plots weighted by abundances
abcarre=aggregate(abond~annee+carre,tabCLEAN,sum) ### somme des abondances totales par annee et carre / sum of total abundance per year and plots
csi=ssicarre[,3]/abcarre[,3]  #### le ssi moyen par carre = csi par carre et annee / mean ssi per plots = csi per year and plots

dd1=data.frame(csi,ssicarre$carre,ssicarre$annee)
names(dd1)[2]="carre"
names(dd1)[3]="year"
######### Calcul du cti (indice de preference thermique) / Calculation of the cti (index of thermal preference)
tabCLEAN$sti=spTrait$sti[match(tabCLEAN$espece,spTrait$pk_species)] ### recupere donnee de sti par espece calcule a partir temperature moyenne obtenu a partir des occurences par carre et descriptif des habitats de chaque carre / retrieve sti data for each species based on the temperature mean between habitat described for each plots

sticarre=aggregate(sti*abond~annee+carre,tabCLEAN,sum) ### sti totale par annee et carre pondere par les abondances / ssi total per year and per plots weighted by abundances
abcarre=aggregate(abond~annee+carre,tabCLEAN,sum) ### somme des abondances totales par annee et carre / sum of total abundance per year and plots
cti=sticarre[,3]/abcarre[,3]  #### le sti moyen par carre = cti par carre et annee / mean sti per plots = cti per year and plots

dd2=data.frame(cti,sticarre$carre,sticarre$annee)  #############
names(dd2)[2]="carre"
names(dd2)[3]="year"
dd3=merge(dd1,dd2,by=c("carre","year")) ################

######### Calcul du ctri (indice de niveau trophique) avec utilisation de l'exponentiel du niveau trophique / Calculation of the ctri (index of trophic level) using the exponential of the trophic level (1=herbivorous birds, 2=insectivorous/nematophagous birds, 3=birds predator)
tabCLEAN$stri=spTrait$exp_stri[match(tabCLEAN$espece,spTrait$pk_species)] ### recupere donnee de stri par espece calcule a partir temperature moyenne obtenu a partir des occurences par carre et descriptif des habitats de chaque carre / retrieve sti data for each species based on the temperature mean between habitat described for each plots

stricarre=aggregate(stri*abond~annee+carre,tabCLEAN,sum) ### sti totale par annee et carre pondere par les abondances / ssi total per year and per plots weighted by abundances
abcarre=aggregate(abond~annee+carre,tabCLEAN,sum) ### somme des abondances totales par annee et carre / sum of total abundance per year and plots
ctri=stricarre[,3]/abcarre[,3]  #### le stri moyen par carre = ctri par carre et annee / mean stri per plots = ctri per year and plots

dd4=data.frame(ctri,stricarre$carre,stricarre$annee)  #############
names(dd4)[2]="carre"
names(dd4)[3]="year"
dd=merge(dd3,dd4,by=c("carre","year")) ################

dd$longitude_grid_wgs84=coordCarre$longitude_grid_wgs84[match(dd$carre,coordCarre$pk_carre)] #### recupere coordonnées gps / retrieve gps coordinates
dd$latitude_grid_wgs84=coordCarre$latitude_grid_wgs84[match(dd$carre,coordCarre$pk_carre)]  #### recupere coordonnées gps / retrieve gps coordinates
dd$id_plot=dd$carre  ### id_plot nom données aux carrés dans le script /id_plot is use as the name of the plot in the following script

############################# The function

csi_cti_ctri <- function(dd=dd,ic=TRUE, indic="csi",methode="gam", ####### indic: choisir indicateur "csi" "cti" ou "ctri" ; methode: choisir modele "gam" ou "lmer" ; ic pour calcul de l'interval de confiance plus rapide sans mais moins fiable / indic is the choice of an indicator: "csi", "cti" or "ctri" ; methode is the statistical model use for the analysis "gam" or "lmer" ; ic is for the calculation of confidence interval faster without but less reliable
                          firstYear=NULL,lastYear=NULL,altitude=800,departement=NULL,onf=TRUE,distance_contact=NULL, #### altitude, departement onf, distance de contact = Argument non utilise, se trouvait dans requete sql / altitude, departement onf, distance de contact = not use anymore was in a postgres request
                         spExcluPassage1=c("MOTFLA","SAXRUB","ANTPRA","OENOEN","PHYTRO"),# (Prince et al. 2013 Env. Sc. and Pol.) + "OENOEN","PHYTRO" avis d'expert F. Jiguet, #### Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                         seuilAbondance=.99,init_1989 = FALSE,plot_smooth=TRUE, ###### init_1989 si TRUE, option que pour csi et besoin du fichier des csi calculés sur les données avant 2001 (pas forcement fiable car protocole un peu different) / init_1989 if TRUE, only working for csi, and use calculation of csi based on data before 2001 (protocol was bit different, not totally reliable)
                          champSp = "code_sp", sp=NULL,champsHabitat=FALSE, #### Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                          anglais=FALSE,seuilSignif=0.05,##### #### anglais=FALSE Argument non utilise, se trouvait dans requete sql / not use anymore was in a postgres request
                          couleur="#4444c3",
                          titreY=indic,titreX="Années",titre=indic,
                          savePostgres=FALSE,output=FALSE,   ##### OPTION "output" pour afficher le resultat dans R  / OPTION "output" is only to show the result in the R window
                          operateur=c("Lorrilliere Romain","lorrilliere@mnhn.fr"), encodingSave="ISO-8859-1",fileName="dataCSI",id="France"){ ####### nom des fichiers de sorties et de l'operateur / name of the output files and of the operator

start <- Sys.time()
            dateExport <- format(start,"%Y-%m-%d")

if(is.null(firstYear)) firstYear <- 2001
if(is.null(lastYear)) lastYear <- 9999
if(is.null(altitude)) altitude <- 10000

 annee <- sort(unique(dd$year))
            nban <- length(annee)
            pasdetemps <-nban-1

if(methode == "gam") {

            cat("Methode: gam\n")

####browser()
            ## Utilisation des modèles GAMM pour obtenir les tendances d evolution par an du csi cti ou ctri !!!! Marche pas si peu de données !!!!  / Use of GAMM model for the estimation of the annual variations of the csi cti or ctri  !!! does not work with few data !!!
            cat("\nEstimation de la variation annuelle ",indic,"~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs='sos')\n",sep="")
if (indic=="csi"){
        gammf <- gamm(csi~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year)) #### spline sur les coordonnées, effet aleatoire sur les carres, methode autoregressive sur l'année N-1  / spline on the gps coordinates, random effect on the plots, autoregressive method on the year-1
}
if(indic=="cti"){
        gammf <- gamm(cti~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year)) ####

}
if(indic=="ctri"){
        gammf <- gamm(ctri~ factor(year)+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year)) ####

}

            sgammf<-summary(gammf$gam)
            coefdata=coefficients(gammf$gam) ### recupere les coefficient de regression de la variable "annee" / retrieve the regression coefficient of the variable "year"
            coefannee <- c(0,sgammf$p.coeff[2:nban])  ### meme chose que au dessus / same as before
            erreuran <- c(0,sgammf$se[2:nban])### recupere les erreurs standard des coefficient de regression de la variable "annee" / retrieve the standard errors of the regression coefficient of the variable "year"
            pval <-  c(1,sgammf$p.pv[2:nban])### recupere les p value de la variable "annee" / retrieve the p value of the variable year

			## calcul des intervalles de confiance  / confidence interval calculation

        if(ic) {
            # gammf.sim <- sim(gammf)  ######################  VERSION ROMAIN mais fct sim() ne marche pas avec GAMM / old version using function sim() but did not work with Gamm models
            # ic_inf_sim <- c(0,tail(apply(coef(gammf.sim), 2, quantile,.025),pasdetemps))
            # ic_sup_sim <- c(0,tail(apply(coef(gammf.sim), 2, quantile,.975),pasdetemps))
			icalpha05 <- as.data.frame(confint(gammf$gam))[2:nban,1:2]  ########## VERSION BENJ
			ic_inf_sim <- icalpha05[,1]
			ic_inf_sim <- c("NA",ic_inf_sim[1:nban-1])
			ic_sup_sim <- icalpha05[,2]
			ic_sup_sim <- c("NA",ic_sup_sim[1:nban-1])
        } else
        {
            ic_inf <- "not assessed"
            ic_sup <- "not assessed"
        }

            tabfgamm <- data.frame(model = "gamm factor(year) plot",annee,coef=coefannee,se = erreuran,pval,signif=pval<seuilSignif,Lower_ci=ic_inf_sim,upper_ci=ic_sup_sim) #### recupère les resultats des modèles avec interval de confiance / retrieve results of the models used with confidence interval

if(plot_smooth) {   #### Representation graphique de l'evolution annuelle des indicateurs  / Graphical representation of the annual evolution of the indicators
            cat("\nGam pour la figure ",indic,"~s(year)\n",sep="")
            ## create a sequence of temperature that spans your temperature  #####not use anymore
            ## http://zevross.com/blog/2014/09/15/recreate-the-gam-partial-regression-smooth-plots-from-r-package-mgcv-with-a-little-style/  #### method for the plot

if (indic=="csi"){
            gammgg <- gamm(csi~s(year), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))  #### spline sur l'année, effet aleatoire des carres sur ordonnée à l'origine, methode autoregressive sur l'année N-1  / spline on the year, random effect of the plots on the intercept, autoregressive method on the year-1
}
if (indic=="cti"){
            gammgg <- gamm(cti~s(year), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))  ####
}
if (indic=="ctri"){
            gammgg <- gamm(ctri~s(year), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))  ####
}

            maxyear<-max(dd$year)
            minyear<-min(dd$year)
            year.seq<-sort(unique(c(minyear:maxyear,(seq(minyear, maxyear,length=1000)))))
            year.seq<-data.frame(year=year.seq)

                                        # predict only the temperature term (the sum of the   ########### ???? not use anymore
                                        # term predictions and the intercept gives you the overall########### ???? not use anymore
                                        # prediction)########### ???? not use anymore

            preds<-predict(gammgg$gam, newdata=year.seq, type="terms", se.fit=TRUE)

                                        # set up the temperature, the fit and the upper and lower########### ???? not use anymore
                                        # confidence interval########### ???? not use anymore

            year <-year.seq$year
            realYear <- sort(unique(dd$year))
            fit<-as.vector(preds$fit)
            init <- fit[1]

            # fit.up95<-fit-1.96*as.vector(preds$se.fit)    ###########  not use anymore

            # fit.low95<-fit+1.96*as.vector(preds$se.fit)

           # ggGamData <- data.frame(year=year, csi=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)

        fit <- fit - init
        fit.up95 <- fit.up95 - init
        fit.low95 <- fit.low95 - init

if (indic=="csi"){
        ggGamData <- data.frame(year=year, csi=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)  ####### Recupère les resultats des modèles / retrieve the results of the models
}
if (indic=="cti"){
        ggGamData <- data.frame(year=year, cti=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)
}
if (indic=="ctri"){
        ggGamData <- data.frame(year=year, ctri=fit,ic_low95 = fit.low95, ic_up95 = fit.up95)
}
 ## The ggplot:
if (indic=="csi"){
            gg <- ggplot(data=ggGamData,aes(x=year,y=csi))
           }
if (indic=="cti"){
            gg <- ggplot(data=ggGamData,aes(x=year,y=cti))
           }
if (indic=="ctri"){
            gg <- ggplot(data=ggGamData,aes(x=year,y=ctri))
           }
		   gg <- gg + geom_ribbon(aes(ymin=ic_low95, ymax=ic_up95),fill = couleur,alpha=.2)+ geom_line(size=1,colour=couleur)
            gg <- gg +  geom_point(data = subset(ggGamData,year %in% realYear),size=3,colour=couleur) + geom_point(data = subset(ggGamData,year %in% realYear),size=1.5,colour="white")
            gg <- gg + labs(y=titreY,x=titreX,title=titre)+scale_x_continuous(breaks=pretty_breaks())

            ggsave(paste("Output/fig",indic,"_plot",id,".png",sep=""),gg)
            cat("\n--> Output/fig",indic,"_plot",id,".png\n",sep="")

            tabPredict <- subset(ggGamData,year %in% realYear)########### Tableau des resultats pour ne prendre que les valeurs d'IC pour l'année pas entre les années (spline sur annee) !!!plus utilisé!! / Table of the results not taking confidence interval between year but at each year (because of the spline of year)
            colnames(tabPredict)[1:2] <- c("annee",paste(indic,"_predict",sep=""))
            ##tabgamm <- merge(tabfgamm,tabPredict,by="annee") #### Desactivation car merge sortie de modèles différents (le modèle dont on tire les coef de regression pour année, avec spline sur les coordonnées geo vs celui pour faire la figure avec splin sur année uniquement)  / not use anymore (as before) because use the results of the restricted model with the spline on the year while the better analysis is on full model with the spline on gps coordinates
			tabgamm <-  tabfgamm  #### remplace la ligne au dessus  / replace the line above

} else {
    if(init_1989) { ########### Pour utiliser les données csi avant 2001 / in order to use csi data from before 2001
        histo <- read.csv2("csi_init.csv")  ###############   Csi calculé avant 2001 / Data of the csi calculated before 2001
        init <- subset(histo,annee == 2001)$csi

        tabgamm <-  tabfgamm
        tabgamm$coef <-  tabgamm$coef+init
        histo <- subset(histo,annee<=2001)
        tabgamm <- subset(tabgamm,annee>2001)
        tabHisto <- data.frame(model= tabgamm$model[1],annee = histo$annee,
                               coef = histo$csi,se=histo$se,pval=NA,signif=NA)
        tabgamm <- rbind(tabgamm,tabHisto)
        tabgamm <- tabgamm[order(tabgamm$annee),]

        tabgamm$ic_up95<-tabgamm$coef-1.96*as.vector(tabgamm$se)

           tabgamm$ic_low95<-tabgamm$coef+1.96*as.vector(tabgamm$se)

    }
#    browser()
         ## The ggplot:
            gg <- ggplot(data=tabgamm,aes(x=annee,y=coef))
           gg <- gg + geom_ribbon(aes(ymin=ic_low95, ymax=ic_up95),fill = couleur,alpha=.2)+ geom_line(size=1,colour=couleur)
            gg <- gg +  geom_point(size=3,colour=couleur)
            gg <- gg + labs(y=titreY,x=titreX,title=titre)+scale_x_continuous(breaks=pretty_breaks())

            ggsave(paste("Output/fig",indic,"_plot",id,".png",sep=""),gg)
        cat("\n--> Output/fig",indic,"_plot",id,".png\n",sep="")

    write.csv(tabgamm,paste("Output/",indic,"_gammPlot_",id,".csv",sep=""),row.names=FALSE) ####
        cat("\n  --> Output/",indic,"_gammPlot_",id,".csv\n",sep="")

}

            cat("\nEstimation de la tendence  ",indic,"~ year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs='sos')\n")
if (indic=="csi"){
            gammc <- gamm(csi~year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))### spline sur les coordonnées, effet aleatoire des carres sur ordonnée à l'origine, methode autoregressive sur l'année N-1  / spline on the gps coordinates, random effect of the plots on intercept, autoregressive method on the year-1
}
if (indic=="cti"){
            gammc <- gamm(cti~year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))
}
if (indic=="ctri"){
            gammc <- gamm(ctri~year+s(longitude_grid_wgs84,latitude_grid_wgs84,bs="sos"), data=dd,random=reStruct(object = ~ 1| id_plot, pdClass="pdDiag"),correlation=corAR1(form=~year))
}
            sgammc <-summary(gammc$gam)

            coefannee <- sgammc$p.coeff[2]  #### coefficient de regression de la variable année / regression coefficient of the variable "year"
            ## erreur standard / standard error
            erreuran <- sgammc$se[2]
            ## p value
            pval <-  sgammc$p.pv[2]

			#### Calcul des intervalles de confiances / calculation of the confidence intervals

        if(ic) {
            # gammc.sim <- sim(gammc)######################  VERSION ROMAIN mais fct sim() marche pas avec Gamm / old version using function sim() but did not work with Gamm models
            # ic_inf_sim <- c(0,tail(apply(coef(gammc.sim), 2, quantile,.025),pasdetemps))
            # ic_sup_sim <- c(0,tail(apply(coef(gammc.sim), 2, quantile,.975),pasdetemps))
			icalpha05 <- as.data.frame(confint(gammc$gam))[2,1:2]  ########## VERSION BENJ
			ic_inf_sim <- icalpha05[,1]
			ic_sup_sim <- icalpha05[,2]
        } else
        {
            ic_inf_sim <- "not assessed"
            ic_sup_sim <- "not assessed"
        }
if (indic=="csi"){
            tabcgamm <- data.frame(model = "gamm numeric(year) plot",annee = NA,coef = coefannee,se = erreuran,pval,signif = pval<seuilSignif, csi_predict= NA , ic_low95 = ic_inf_sim, ic_up95 = ic_sup_sim)#### recupère les resultats des modèles avec interval de confiance / retrieve results of the models used with confidence interval
}
if (indic=="cti"){
            tabcgamm <- data.frame(model = "gamm numeric(year) plot",annee = NA,coef = coefannee,se = erreuran,pval,signif = pval<seuilSignif, cti_predict= NA , ic_low95 = ic_inf_sim, ic_up95 = ic_sup_sim)####
}
if (indic=="ctri"){
            tabcgamm <- data.frame(model = "gamm numeric(year) plot",annee = NA,coef = coefannee,se = erreuran,pval,signif = pval<seuilSignif, ctri_predict= NA , ic_low95 = ic_inf_sim, ic_up95 = ic_sup_sim)####
}

            tabgamm <- tabgamm[,colnames(tabcgamm)]

            tabgamm <- rbind(tabgamm,tabcgamm)

            write.csv(tabgamm,paste("Output/",indic,"_gammPlot_",id,".csv",sep=""),row.names=FALSE)
        cat("\n  --> Output/",indic,"_gammPlot_",id,".csv\n",sep="")

		}

if (methode == "lmer") {
            cat("Method : lmer \n")

###################
# browser()
   ### Utilisation des modèles mixtes pour obtenir les tendances d evolution par an du csi cti ou ctri / Use of mixte model for the estimation of the annual variations of the csi cti or ctri
            cat("\nEstimation de la variation annuelle lmer(",indic,"~ factor(year)+(1|id_plot)\n",sep="")
if (indic=="csi"){
			md.f <- lmer(csi~ factor(year)+(1|id_plot),data=dd)  ##### effet aleatoire liés aux carrés sur l'ordonnée à l'origine / random effects of plots on intercept
}
if (indic=="cti"){
			md.f <- lmer(cti~ factor(year)+(1|id_plot),data=dd)
}
if (indic=="ctri"){
			md.f <- lmer(ctri~ factor(year)+(1|id_plot),data=dd)
}
            smd.f<-summary(md.f)
            coefdata.f <-  as.data.frame(smd.f$coefficients)
            coefdata.f <- data.frame(model="Annual fluctuation", variable = rownames(coefdata.f),coefdata.f)

            ggdata <<- data.frame(year=c(1989,as.numeric(substr(coefdata.f$variable[-1],13,16))),
                                 estimate=c(0,coefdata.f$Estimate[-1]),
                                 se=c(0,coefdata.f$Std..Error[-1]))   #####################  resultat du modèle / results of the models
            #ggdata$estimate <-  ggdata$estimate
             #ggdata$se.supR <- ggdata$estimate +  ggdata$se ############################################################################## METHODE ROMAIN
             #ggdata$se.infR <- ggdata$estimate -  ggdata$se
            # ggdata$estimate2 <- c(coefdata.f$Estimate[1],coefdata.f$Estimate[1] + coefdata.f$Estimate[-1])
			# ggdata$se.sup2 <- ggdata$estimate2 +  ggdata$se
            # ggdata$se.inf2 <- ggdata$estimate2 -  ggdata$se

		prof <- profile(md.f)  #### Nouvel interval de confiance avec utilisation du logarithme des ecarts types / logarithms of standard deviations are used, while varianceProf converts from the standard-deviation to the variance scale
		MODconfint <- confint(prof) #### plus rapide de passer par la fonction profile mais pas indispensable fonctionne aussi directement sur modele mixte md.f  / more rapid using both function profile and confint but works also directly on output of the model
		se.sup <- MODconfint[2:nban+2,2]
		ggdata$se.sup <- c(0,se.sup)
		se.inf <- MODconfint[2:nban+2,1]
        ggdata$se.inf <- c(0,se.inf)
coefdata.f$se.inf <- ggdata$se.inf
coefdata.f$se.sup <- ggdata$se.sup
browser()
            #gg <<- ggplot(ggdata,aes(x=year,y=estimate))+ geom_ribbon(ymin=ggdata$se.infR,ymax=ggdata$se.supR,alpha=.25)+geom_errorbar(ymin=ggdata$se.infR,ymax=ggdata$se.supR,width=0,alpha=.25)+ geom_point() + geom_line() + ylim(min(ggdata$se.infR),max(ggdata$se.supR)) + labs(x="Years",y=paste(indic," variation",sep="")) #####  AVEC INTERVAL ROMAIN
			gg <<- ggplot(ggdata,aes(x=year,y=estimate))+ geom_ribbon(ymin=ggdata$se.inf,ymax=ggdata$se.sup,alpha=.25)+geom_errorbar(ymin=ggdata$se.inf,ymax=ggdata$se.sup,width=0,alpha=.25)+ geom_point() + geom_line() + ylim(min(ggdata$se.inf),max(ggdata$se.sup)) + labs(x="Years",y=paste(indic," variation",sep="")) #####

            ggfile <- paste("output/",indic,id,".png",sep="")
            ggsave(ggfile,gg)

############ Estimation de la tendance sur la periode étudiée  / Trends estimation on the time period studied
			cat("\nEstimation de la tendance lmer(",indic,"~ factor(year)+(1|id_plot)\n",sep="")
if (indic=="csi"){
			md.c <- lmer(csi~ year+(1|id_plot),data=dd)##### effet aleatoire liés aux carrés sur l'ordonnée à l'origine / random effects of plots on intercept
}
if (indic=="cti"){
			md.c <- lmer(cti~ year+(1|id_plot),data=dd)
}
if (indic=="ctri"){
			md.c <- lmer(ctri~ year+(1|id_plot),data=dd)
}
            smd.c<-summary(md.c)

            coefdata.c <-  as.data.frame(smd.c$coefficients)
profc=profile(md.c) ######### Ajout des intervalles de confiances / addition of the confidence intervals
MODconfint=confint(profc)
se.inf=MODconfint[4,1]
se.sup=MODconfint[4,2]
			coefdata.c <- data.frame(model = "Linear trend", variable = rownames(coefdata.c),coefdata.c,se.inf,se.sup)

            coefdata <- rbind(coefdata.c,coefdata.f)

write.csv(coefdata,paste("Output/lmer_coefficient_",indic,id,".csv",sep=""),row.names=FALSE)
write.csv(ggdata,paste("Output/ggdata_",indic,id,".csv",sep=""),row.names=FALSE)

            smd.file <- paste("output/summary_lmer_",indic,"_",id,".txt",sep="")

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

        }

		}

##################
###  Do your analysis

csi_cti_ctri(dd=dd,indic="csi",ic=TRUE,plot_smooth = TRUE,methode="lmer")  ##### exemple pour l'indicateur csi avec interval de confiance et utilisant modele mixte / example for the csi index with confidence interval using the mixte model

raw_scripts/STOC_bird_temporal_tendency/2019/csi cti ctri 1er jet.r


getClusterTypes <- function( seuratObj){

# This funciton takes a seurat objects, takes its @ident field and identifies clusters with M and I control cell types as cell types containing
# the maximal number of control cells
# written by Vsevolod J. Makeev 2017 - 2021

source("R/calcTargetClusterQuals.r")

clFactor     <- seuratObj@ident

cellClusters <- sapply( levels( clFactor), function(x) WhichCells( seuratObj, ident = x))
nClust	     <- length( levels( clFactor))

cl_IP	<- which.max( calcTargetClusterQuals( seuratObj, "I"))
cl_MC	<- which.max( calcTargetClusterQuals( seuratObj, "M"))

clusterTypes 			<- levels( clFactor)
if (length(unique(c(cl_IP, cl_MC))) < 2) {cat( "Some reference clusters conincide \n")
							 attr(clusterTypes, which = "success") <- FALSE
							 return( clusterTypes)}
names( clusterTypes)		<- levels( clFactor)
names( clusterTypes)[ which( names(cl_IP) == levels(clFactor))]		<- "I"
names( clusterTypes)[ which( names(cl_MC) == levels(clFactor))]		<- "M"
attr(clusterTypes, which = "success") <- TRUE

return(clusterTypes)
}


library(data.table)
five_concat <- as.data.frame(fread("Aconcat_output.csv"))
idx <- 1:(31*5)

cat_indices_rolling <- function(i) (1:31)+31*(i-1)

degenerate_trajectories <- lapply(1:5, function(i) {
	task_i <- five_concat[,cat_indices_rolling(i)]
	task_i$point_id <- 1:nrow(task_i)
	melted_task <- melt(task_i,id.vars="point_id")
	if (i>1){
		melted_task$task_i <- as.integer(sub("^[^_]*_", "", melted_task$variable))
		melted_task$muscle <- as.factor(gsub("_.*","",melted_task$variable))
	} else {
		#when there is no _# at end of muscle name
		melted_task$task_i <- 0
		melted_task$muscle <- melted_task$variable
	}
	return(melted_task)
	}) %>% rbindlist

# per_muscle_per_task_hists <- ggplot(degenerate_trajectories, aes(y=value)) + geom_histogram() + facet_grid(muscle~task_i)

# animate_hists <- ggplot(degenerate_trajectories%>%as.data.frame, aes(y=value, frame=task_i, col=muscle)) + geom_histogram()
# ggplotly(animate_hists)
# gganimate::gganimate(animate_hists, "animation_bytask.html", ani.width=1200, ani.height=400)


# PURPOSE: Munge and Analysis of COVID Data
# AUTHOR: Ben Kasdan | SI
# LICENSE: MIT
# DATE: 2021-07-01
# NOTES:

# LOCALS & SETUP ============================================================================

  # Libraries
    oha

  # Set paths
    proj_paths

    si_paths

  # Functions
    library(glitr)
    library(glamr)
    library(gisr)
    library(Wavelength)
    library(ICPIutilities)
    library(tidyverse)
    library(scales)
    library(sf)
    library(extrafont)
    library(tidytext)
    library(patchwork)
    library(ggtext)
    library(here)
    library(gt)
    library(googlesheets4)

    up_arrow <- "▲"
    down_arrow <- "▼"

# LOAD DATA ============================================================================

  #Data
    df_data<-read.csv("Data/Potential COVID Mock up.xlsx - dataset.csv")
  #country
    df_country<-read.csv("Data/Potential COVID Mock up.xlsx - country_metadata.csv")

# MUNGE ============================================================================

  #Bind the two
    df<-left_join(df_country,df_data, by="country_id")

    #get just vaccine data 77573
    df<-df%>%
      dplyr::filter(series_id=="79713")
    #interpolating
    library(zoo)
    df  %>% mutate(interpolated_indicator = na.approx(value, na.rm = FALSE))

    df<-df%>%
            dplyr::filter(country_name %in% LMICS)

    #filter by max date
    df5<-df %>%
     # group_by(country_name) %>%
      slice(which.max(as.Date(date, '%Y/%M/%D')))

    #loop over some dates I chose two
    library(lubridate)

    df<-df%>%
      filter(!is.na(state_region))

    #mutate find vax per total pop
    df<-df%>%
      dplyr::mutate("Vaccine Percentage"=value /population_total)%>%
      mutate_at(vars(`Vaccine Percentage`),~replace_na(.,0))%>%
     mutate(`date`= as.character(`date`, format="%X"))
   # df<-df%>%
      #pivot_wider(names_from = date,
       #                  values_from = `Vaccine Percentage`)

    df<- df%>%
      dplyr::mutate(`metric` = `series_id`)%>%
      mutate(`metric` = ifelse(`metric` == "79713", "Percentage of Population Fully Vaccinated",
                               "Other"))
#messing around with count tables
    df<- df%>%
      dplyr::mutate(`Goal` = `Vaccine Percentage`)%>%
      mutate(`Goal` = ifelse(`Vaccine Percentage` >=.2, "Above 20%",
                               ifelse(`Vaccine Percentage`<.05, "Below 5%",
                               "5-19%")))
   #regional counts and income counts for percentage and total vaxed
    df1<-df%>%
      dplyr::filter(date =="2021-07-01")%>%
      count(state_region,`Goal`)%>%
      group_by(state_region) %>%
      mutate(total_n = sum(n)) %>%
      dplyr::mutate("Percentage"=n /total_n)
    write.csv(df1,"Vaccine chart.csv")

    dfIC<-df%>%
      dplyr::filter(date =="2021-07-01")%>%
      count(income_group,`Goal`)%>%
      group_by(income_group) %>%
      mutate(total_n = sum(n)) %>%
      dplyr::mutate("Percentage"=n /total_n)
    write.csv(dfIC,"IC total vaxed 7.1.21.csv")

    df_vaxr<-df%>%group_by(state_region, date)%>%
      summarise_at(vars(value),              # Specify column
                   list(value= sum))
    write.csv(df_vaxr, "Population vaxed by region.csv")
    df_vaxrIC<-df%>%group_by(income_group, date)%>%
      summarise_at(vars(value),              # Specify column
                   list(value= sum))
    write.csv(df_vaxrIC, "Population vaxed by ic.csv")
    df_global<-df%>%
      group_by(date)%>%
      summarise_at(vars(value),              # Specify column
                   list(value= sum))
      df_global%>%
      group_by(date)
      summarise_at(vars(population_total),
                   list(population_total=sum))
    #the above is different than what is in the chart since I dropped non state_regions

# VIZ ============================================================================

library(gt)

    #view all data in gt for country-in this example I filtered out a region
    df%>%
      gt()
  #put dates on top
 tbl1<- df %>%
    dplyr::filter(state_region=="Europe and Eurasia")%>%
    dplyr::select(-c(country_id, iso_alpha3,usaid_region,data_services_region,classification_value_name
                          ,population_total,pop_2020_thousands,series_id,state_region,value  ))%>%
    pivot_wider(names_from = date, values_from=`Vaccine Percentage`)%>%
    gt()%>%
      #rowname_col = "Date",
  tab_spanner(
    label = "Total Population Vaccinated",
    columns = c("2021-05-31","2021-06-18"))%>%
  fmt_percent(
    columns = vars("2021-05-31","2021-06-18"),
    decimals = 2)%>%
   fmt_missing(columns = everything(),
               missing_text = "-") %>%
   tab_options(
     table.font.names = "Source Sans Pro") %>%
   cols_width(

     everything() ~ px(140)
   ) %>%
   tab_style(
     style = cell_borders(
       sides = "right",
       weight = px(1.5),
     ),
     locations = cells_body(
       columns = everything(),
       rows = everything()
     ))%>%
  cols_label(country_name="Name")%>%
  tab_header(title = "Status of Global Vaccination Campaign in Europe and Eurasia as of June 18, 2021",
             ) %>%
  tab_source_note("Source: CJ's Dataset 2020-06-18")%>%
   tab_footnote(
     footnote = "Percentage is based off of total population, not the population 18+",
     locations = cells_column_labels(
       columns = "2021-06-18"))

  #ignore the below

    tab_style(style = cell_fill(color = pal[4]),      ## defining the what (the 4th value of the pal object)
              locations = cells_body(                 ## telling it where (ie, the body of a cell)
                columns = vars("Vaccine Percentage"),      ## which col this refers to (note `vars()`)
                rows = "Vaccine Percentage" >= .2)) %>%   ## the argument
    tab_style(style = cell_fill(color = pal[3]),
              locations = cells_body(
                columns = vars("Vaccine Percentage"),
                rows = "Vaccine Percentage" < .2 &  "Vaccine Percentage" >= .15)) %>%
    tab_style(style = cell_fill(color = pal[2]),
              locations = cells_body(
                columns = vars("Vaccine Percentage"),
                rows = "Vaccine Percentage" < .15 &   "Vaccine Percentage" >= .05)) %>%
    tab_style(style = cell_fill(color = pal[1]),
              locations = cells_body(
                columns = vars("Vaccine Percentage"),
                rows = "Vaccine Percentage" < .05))

 gtsave(tbl1, "vax_table.png")

 #This one is to focus on one region (old)
 df1<-df%>%
   select(state_region, population_total,value, date)%>%
   group_by(state_region,date)%>%
   summarize(Vaccine_total=sum(value),Population=sum(population_total))%>%
   dplyr::mutate("Vaccine Percentage"=Vaccine_total /Population)%>%
   as.data.frame(df1)
 tbl2<-df1%>%
   dplyr::select(-c("Vaccine_total", "Population"))%>%
   gt(groupname_col = "state_region")%>%
         tab_spanner(
           label = "Total Population Vaccinated",
           columns = c("Vaccine Percentage"))%>%
         fmt_percent(
           columns = vars("Vaccine Percentage"),
           decimals = 2
         )
 gtsave(tbl2, "vax_table_region.png")

 #NEw way to focus on regional data
#grab population data
 df_region<-df_country%>%
   group_by(state_region) %>%                         # Specify group indicator
   summarise_at(vars(population_total),              # Specify column
                list(population_region = sum))
 #grab vax data
 df_vaxr<-df%>%group_by(state_region, date)%>%
   summarise_at(vars(value),              # Specify column
                list(value= sum))
 df_vaxrIC<-df%>%group_by(income_group, date)%>%
   summarise_at(vars(value),              # Specify column
                list(value= sum))

 df3<-left_join(df_vaxr,df_region, by="state_region")%>%
   dplyr::mutate("Vaccine Percentage"=value /population_region)%>%
 dplyr::select(-("date.y"))
 df3<-df3%>%
   dplyr::filter(population_region!="NA")

 #write out regional total (non interpolated)
 write.csv(df3, "regional_vaccine_total.csv")

 df5<-df3%>%
   dplyr::select(-c("value", "population"))%>%
   pivot_wider(names_from = date, values_from="Vaccine Percentage")

tbl4<-df3%>%
  dplyr::select(-c("value", "population"))%>%
  pivot_wider(names_from = date, values_from="Vaccine Percentage")%>%
  gt()%>%

  tab_spanner(
    label = "Total Population Vaccinated",
    columns = c("2021-05-31","2021-06-18"))%>%
  fmt_percent(
    columns = vars("2021-05-31","2021-06-18"),
    decimals = 2)%>%
  fmt_missing(columns = everything(),
              missing_text = "-") %>%
  tab_options(
    table.font.names = "Source Sans Pro") %>%
  cols_width(

    everything() ~ px(140)
  ) %>%
  tab_style(
    style = cell_borders(
      sides = "all",
      weight = px(1.5),
    ),
    locations = cells_body(
      columns = everything(),
      rows = everything()
    ))%>%
  #cols_label(country_name="state_region")%>%
  tab_header(title = "Status of Global Vaccination Campaign  as of June 18, 2021",
  ) %>%
  tab_source_note("Source: CJ's Dataset 2020-06-18")%>%
  tab_footnote(
    footnote = "Percentage is based off of total population, not the population 18+",
    locations = cells_column_labels(
      columns = "2021-06-18"))
#  text_transform(
 #   locations = cells_body(
  #    columns = vars("2021-05-31","2021-06-18"),
   #   rows = "2021-05-31" > "2021-06-18"),
#    fn = function(x) paste(x, up_arrow)
 # ) %>%
  #text_transform(
   # locations = cells_body(
    #  columns = close,
     # rows = "2021-06-18" < "2021-05-31"),
  #  fn = function(x) paste(x, down_arrow)
#  )
 gtsave(tbl4, "vax_table_region_new.png")

# SPINDOWN ============================================================================
df2<-df1%>%
   dplyr::select("Goal","state_region","Percentage")%>%
   dplyr::filter(!is.na("state_region"))
 df2%>%  gt(
     groupname_col = "state_region"
   )%>%
   fmt_percent(
     columns = "Percentage",
     decimals = 0)


library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# ANALYSIS:  Per-locus statistics only, no classification data

# Set up logging
log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "per-locus-only-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda")
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda")
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda", args = clargs)
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda", args = clargs)
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda", args = clargs)
}

load(pop_data_file)
load(sampled_data_file)
load(ta_sampled_data_file)
flog.info("Loaded data file: %s", pop_data_file, name='cl')
flog.info("Loaded data file: %s", sampled_data_file, name='cl')
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-3 data sets for per-locus only predictors", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
# dev = TRUE gets ignored on a Linux server and uses the full set of cores
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (1:10)*25,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# set up combined_results data frames
experiment_names <- c("Per-Locus Population Census", "Per-Locus Sampled 10%", "Per-Locus Sampled 20%")
perlocus_results <- data.frame()
perlocus_results_roc <- NULL
perlocus_results_model <- NULL
perlocus_results_cm <- NULL

###### Population Data ######

flog.info("Starting analysis of population data without per-locus values only", name='cl')

# first row of combined_results
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_pop_df$two_class_label <- factor(ifelse(eq3_pop_df$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "configuration_slatkin", "num_trait_configurations")

#model <- train_randomforest(eq3_pop_df, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_pop_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

perlocus_results_model[["perlocus_pop"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
perlocus_results_cm[["perlocus_pop"]] <- cm

# All other analyses record these
results$sample_size <- 0
results$ta_duration <- 0

# calculate a ROC curve
perlocus_pop_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(perlocus_pop_roc$auc@y.values)
perlocus_results_roc[["perlocus_pop"]] <- perlocus_pop_roc

perlocus_results <- rbind(perlocus_results, results)

###### Sampled Data 10% ######

flog.info("Starting analysis of sampled data without per-locus values only", name='cl')

# first row of combined_results
i <- 2
exp_name <- experiment_names[i]

eq3_sampled_10 <- dplyr::filter(eq3_sampled_df, sample_size == 10)

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_sampled_10$two_class_label <- factor(ifelse(eq3_sampled_10$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "configuration_slatkin", "num_trait_configurations", "sample_size")

#model <- train_randomforest(eq3_sampled_10, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_sampled_10, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

perlocus_results_model[["perlocus_sampled_10"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
perlocus_results_cm[["perlocus_sampled_10"]] <- cm

# All other analyses record these
results$sample_size <- 10
results$ta_duration <- 0

# calculate a ROC curve
perlocus_sampled_10_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(perlocus_sampled_10_roc$auc@y.values)
perlocus_results_roc[["perlocus_sampled_10"]] <- perlocus_sampled_10_roc

perlocus_results <- rbind(perlocus_results, results)

###### Sampled Data 20% ######

flog.info("Starting analysis of sampled data without per-locus values only", name='cl')

# first row of combined_results
i <- 3
exp_name <- experiment_names[i]

eq3_sampled_20 <- dplyr::filter(eq3_sampled_df, sample_size == 10)

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_sampled_20$two_class_label <- factor(ifelse(eq3_sampled_20$model_class_label == 'allneutral', 'neutral', 'biased'))

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate", "configuration_slatkin", "num_trait_configurations", "sample_size")

#model <- train_randomforest(eq3_sampled_20, training_set_fraction, fit_grid, fit_control, exclude_columns)
model <- train_gbm_classifier(eq3_sampled_20, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

perlocus_results_model[["perlocus_sampled_20"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
perlocus_results_cm[["perlocus_sampled_20"]] <- cm

# All other analyses record these
results$sample_size <- 20
results$ta_duration <- 0

# calculate a ROC curve
perlocus_sampled_20_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(perlocus_sampled_20_roc$auc@y.values)
perlocus_results_roc[["perlocus_sampled_20"]] <- perlocus_sampled_10_roc

perlocus_results <- rbind(perlocus_results, results)

############## Complete Processing and Save combined_results ##########3

# save objects from the environment
if(length(clargs) == 0) {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "per-locus-analysis-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "per-locus-analysis-gbm-dfonly.RData")

} else {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "per-locus-analysis-gbm.RData",
                              args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "per-locus-analysis-gbm-dfonly.RData", args = clargs)

}

flog.info("Saving combined_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(perlocus_results, perlocus_results_model, perlocus_results_cm, perlocus_results_roc, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(perlocus_results, file=image_file_results)

# End
flog.info("Analysis complete", name='cl')

plot


#' Recolor a phylopic image
#'
#' Internal function to recolour and change alpha levels of a phylopic image.
#'
#' @param img A png object, e.g, from using [image_data()]
#' @param alpha A value between 0 and 1, specifying the opacity of the silhouette.
#' @param color Color to plot the silhouette in.
recolor_phylopic <- function(img, alpha = 0.2, color = NULL) {

  if (is.null(color)) {
    mat <- matrix(rgb(img[,,1], img[,,2], img[,,3], img[,,4] * alpha),
                  nrow = dim(img)[1])
  } else {
    cols <- grDevices::col2rgb(color)
    imglen <- length(img[,,1])
    mat <- matrix(ifelse(img[,,4] > 0, rgb(rep(cols[1,1], imglen),
                                           rep(cols[2,1], imglen),
                                           rep(cols[3,1], imglen),
                                           img[,,4]*255*alpha, maxColorValue = 255),
                         rgb(rep(1, imglen),
                             rep(1, imglen),
                             rep(1, imglen),
                             img[,,4]*alpha)), ## make background white for devices
                  nrow = dim(img)[1])       ## that do not support alpha channel
  }

  return(mat)
}


###Load R packages
# if you need to load the packages use install.packages("ggplot2")
##Import Step
library(vegan)
library(MASS)
library(ggplot2)
library(plyr)
library(dplyr)
library(magrittr)
#library(mctoolsr)
library(scales)
library(grid)
library(reshape2)
library(phyloseq)
library(randomForest)
library(knitr)
library(ape)
library(lubridate)
library(ggpubr)
#To find the file run file.choose() then paste it in the next line or use FlyDate=read.table(file.choose(),header=TRUE)
file.choose()
FlyData=read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\data10.24.txt",header=TRUE)
FlyData

plot=ggplot(FlyData, aes(SiteLocation,Total,color=SiteLocation))+stat_summary(fun.y=mean,geom="point", size=2)+facet_wrap(~City)
plot+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())+ theme(axis.text.x = element_text(angle = 45, hjust = 1))
theme_set(theme_bw(base_size = 16))

#####Phyloseq import
#file.choose()
otufull=read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\Table10.24.txt",header=TRUE)#For other column add Other to end of name
head(otufull)
metadata=read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\Meta10.24.txt",header=TRUE)
head(metadata)
taxa=as.matrix(read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\SpeciesNames10.24.txt"))#For other column add Other to end of name
head(taxa)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7")
theme_set(theme_bw(base_size = 20)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
)#sets the plotting theme
OTU=otu_table(otufull, taxa_are_rows=TRUE)
OTU
row.names(OTU)#head(OTU) #should be 6 taxa and 40 samples
taxa_names(TAX)
TAX=tax_table(taxa)
TAX
colnames(TAX)=("Species")
sample_variables(physeq)
sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$SampleID
taxa_names(TAX)=row.names(OTU)
physeq=phyloseq(OTU,TAX,sampdat)
sample_data(physeq)
sample_data(physeq)$SiteLocation2=sample_data(physeq)$SiteLocation
sample_data(physeq)$SiteLocation = factor(sample_data(physeq)$SiteLocation, levels = c("North_1km","North_10km","East_1km","East_10km","South_1km","South_10km","West_1km","West_10km"))

RelativeAbu  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
Lansing=subset_samples(physeq, City == "Lansing")

plot_richness(physeq, x="DistanceFromCenter",color="DistanceFromCenter", measures=c("Shannon"))+facet_grid(~Month,scales="free_x")+geom_boxplot(aes(x=DistanceFromCenter, y=value, color=DistanceFromCenter), alpha=0.05)+
  ylab("Shannon Diversity")

plot_bar(physeq, "SiteLocation","Abundance", "Species")+xlab("Location")+ylab("Relative Abundance (%)")+
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+facet_grid("Month~City",scales="free_x")#+scale_fill_manual(values=cbPalette)

ord=ordinate(physeq,"PCoA", "jaccard")
ordplot=plot_ordination(physeq, ord,"samples", color="City",shape="City",label="SiteLocation")+geom_point(size=4)+scale_colour_manual(values=cbPalette)+scale_fill_manual(values=cbPalette)
ordplot+ stat_ellipse(type= "norm",geom = "polygon", alpha = 1/4, aes(fill = City)) #theme(legend.justification=c(1,0), legend.position=c(1,0))+

#PERMANOVA
GPdist=phyloseq::distance(physeq, "jaccard")
adonis(GPdist ~ DistanceFromCenter, as(sample_data(physeq), "data.frame"))

###RandomForest
JuneVAugust=subset_samples(physeq, Month != "July")
ForestData=JuneVAugust#Change this one so you dont have to rewrite all variables
predictors=t(otu_table(ForestData))
dim(predictors)
response <- as.factor(sample_data(ForestData)$Month)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
imp <- data.frame(predictors = rownames(imp), imp)
imp.sort <- arrange(imp, desc(MeanDecreaseGini))
imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.20 <- imp.sort[1:20, ]
ggplot(imp.20, aes(x = predictors, y = MeanDecreaseGini)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +
  ggtitle("Most important Taxa for classifying  samples\n by treatment")#\n in a string tells it to start a new line
otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification

##########################################
###3.16.18
#########################################
file.choose()
FlyData=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\Percentages16Mar2018Other.csv",header =TRUE,check.names=FALSE)
head(FlyData)
FlyData$SiteLocationMonth=paste0(FlyData$City,FlyData$Location,FlyData$Month)
FlyData$Location = factor(FlyData$Location, levels = c("North1km","North10km","East1km","East10km","South1km","South10km","West1km","West10km"))
FlyData$Month = factor(FlyData$Month, levels = c("JUN","JUL","AUG"))
head(FlyData)
head(FlyData$Location)
plot=ggplot(FlyData, aes(Location,P.regina,color=Location,fill=Location))+stat_summary(fun.y=mean,geom="point", size=2)+facet_wrap(City~Month)+geom_bar(stat="identity")
plot+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())+ theme(axis.text.x = element_text(angle = 45, hjust = 1))+ylab("P. regina (% of total collected)")
theme_set(theme_bw(base_size = 16))

av=aov( L.sericata~ City*Distance, data=FlyData)
summary(av)
posthoc <- TukeyHSD(av, 'City', conf.level=0.95)
posthoc

#########
#Phyloseq import
#########
otufull=read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\AbundanceMatrix3.16.18All.txt",header=TRUE)#For other column add Other to end of name
#TaxTable3.16.18 for other
head(otufull)
metadata=read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\Meta3.16.18.txt",header=TRUE)
head(metadata)
taxa=as.matrix(read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\SpeciesNames3.16All.txt"))
#taxa=as.matrix(read.table("C:\\Users\\Joe Receveur\\Documents\\MSU data\\Fly data\\SpeciesNames3.16Other.txt"))

head(taxa)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7")
theme_set(theme_bw(base_size = 20)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
#sets the plotting theme
OTU=otu_table(otufull, taxa_are_rows=TRUE)
OTU
row.names(OTU)#head(OTU) #should be 6 taxa and 40 samples
taxa_names(TAX)
TAX=tax_table(taxa)
TAX
colnames(TAX)=("Species")
sample_variables(physeq)
sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$SampleID
taxa_names(TAX)=row.names(OTU)
physeq=phyloseq(OTU,TAX,sampdat)
sample_data(physeq)
physeq
physeq  = transform_sample_counts(physeq, function(x) x / sum(x)*100 )
physeq = filter_taxa(physeq, function(x) mean(x) > 1e-2, TRUE)
sample_data(physeq)$Location = factor(sample_data(physeq)$Location, levels = c("North1km","North10km","East1km","East10km","South1km","South10km","West1km","West10km"))
sample_data(physeq)$Month = factor(sample_data(physeq)$Month, levels = c("JUN","JUL","AUG"))

plot_richness(physeq, x="LandCover", measures=c("Shannon"))+geom_boxplot(aes(x=LandCover, y=value ), alpha=0.05)+
  ylab("Shannon Diversity")#+facet_grid(Month~City,scales="free_x") color=LandCover

plot_bar(physeq, "Location","Abundance", "Species")+xlab("Location")+ylab("Relative Abundance (%)")+
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+facet_grid("Month~City",scales="free_x")#+scale_fill_manual(values=cbPalette)

ord=ordinate(physeq,"PCoA", "jaccard")
ordplot=plot_ordination(physeq, ord,"samples", color="City",shape="City",label="City")+geom_point(size=4)+scale_colour_manual(values=cbPalette)+scale_fill_manual(values=cbPalette)#+facet_wrap(~City)
ordplot+ stat_ellipse(type= "norm",geom = "polygon", alpha = 1/4, aes(fill = City)) #theme(legend.justification=c(1,0), legend.position=c(1,0))+

df <- psmelt(physeq)
p <- ggbarplot(df, x = "City", y = "Abundance",add = c("mean_se"),#"mean_se"
               color = "black", palette = "cbPalette", facet.by="Species",
               line.color = "gray", line.size = 0.4, short.panel.labs = TRUE, p.adjust.method = "bonferroni", fill= "City") + stat_compare_means(aes(group = City), label = "..p.signif..",label.y = 7)

p+ theme(axis.text.x = element_text(angle = 45, hjust = 1))+ylab("Relative abundance (> 1%)")+ theme(legend.position="none")

Means=compare_means(Abundance ~ City, data = df,
                    group.by = "Species", p.adjust.method = "fdr")
#head(Means)
keeps <- c("Species","group1","group2","p.format","p.adj","method","p.signif")
keeps=Means[keeps]
#keeps

test3 <- list('Species'= keeps$Species,'group1'=keeps$group1,'group2'= keeps$group2 ,'p'=keeps$p.format,'p.adj'=keeps$p.adj,p.signif=keeps$p.signif,'Method'=keeps$method)
test3= as.data.frame(test3)
#test3
FilteredResults<-test3[!(test3$p.adj>0.2),]
FilteredResults

#####################33


stop("do the following first")
## 1 copy the following files to bluecrystalp3
##   pgs.dir/handedness-gwas-summary-stats-STANDARD.txt
##   alspac.dir/genotype/children.{bed,bim,fam}
##   alspac.dir/genotype/mothers.{bed,bim,fam}
##   calculate*-pgs-scores.sh
## 2 run the following on bluecrystalp3
##   bash calculate-handedness-pgs-scores.sh
##    (note that each score requires 26 hours of computation,
##     so might want to run once for children, once for mothers)
## 3 copy output-mothers and output-children to pgs.dir/

mothers.pgs.file <- file.path(pgs.dir, "output-mothers/ldpred-weights_LDpred_p5.0000e-01.sscore")
children.pgs.file <- file.path(pgs.dir, "output-children/ldpred-weights_LDpred_p5.0000e-01.sscore")
stopifnot(file.exists(mothers.pgs.file))
stopifnot(file.exists(children.pgs.file))

## load PGS for mothers and children
mothers.pgs <- read.table(mothers.pgs.file, header=T, sep="\t", comment.char="", stringsAsFactors=F)
children.pgs <- read.table(children.pgs.file, header=T, sep="\t", comment.char="", stringsAsFactors=F)

## add PGS to alspac.table
idx <- match(paste0(alspac.table$aln,"M"), mothers.pgs$IID)
alspac.table$pgs.mom <- mothers.pgs$SCORE1_AVG[idx]
idx <- match(paste0(alspac.table$aln,alspac.table$qlet), children.pgs$IID)
alspac.table$pgs.child <- children.pgs$SCORE1_AVG[idx]