# shuffle FST A and B values across sites and calculate windowed FST to get a null distribution of max genome-wide FST from SLiM simulations
# run slim_calcfst_reynolds.sh first to get the *.fst.csv.gz files
# also used by slim_fst_siteshuffle_null.sh
# called as
#	Rscript slim_fst_siteshuffle_null.r infile outfile

# to run on saga

# read command line arguments
args <- commandArgs(trailingOnly = TRUE)
print(args)
infile <- args[1]
outfile <- args[2]

# parameters
winsz <- 50000 # window size
winstp <- 10000 # window step
nrep <- 1000 # number of reshuffles
minloci <- 2 # minimum number of loci per window to consider

# load functions
require(data.table)

#############
# Prep data
#############
# load fst A/B data
dat <- fread(infile)

# create new columns as indices for windows
for(j in 1:(winsz/winstp)){
	dat[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
}

# mark windows with < minloci for removal
rem <- 0 # number of windows removed
for(j in 1:(winsz/winstp)){
	datwin <- dat[, .(nsnps = length(POS)), by = .(win = get(paste0('win', j)))] # calc num snps per window
	rem[1] <- rem[1] + datwin[, sum(nsnps < minloci)] # record number to be removed
	datwin[, (paste0('win', j, 'keep')) := 1] # create col to mark which windows to keep
	datwin[nsnps < minloci, (paste0('win', j, 'keep')) := 0] # mark windows to remove
	datwin[, nsnps := NULL] # drop column
	setnames(datwin, "win", paste0('win', j)) # change col name
	dat <- merge(dat, datwin, by = paste0('win', j), all.x = TRUE) # merge keeper col back to full dataset

}

rem # number of windows removed for each comparison

####################################
# shuffle and recalc windowed FST
####################################
colnms <- c('CHROM', 'POS', paste0('win', 1:(winsz/winstp)), paste0('win', 1:(winsz/winstp), 'keep')) # list of column names we want out of the base data.table

for(i in 1:nrep){
	cat(i); cat(' ')
	# create new dataset
	inds <- sample(1:nrow(dat), nrow(dat), replace = FALSE)
	temp <- cbind(dat[, ..colnms], dat[inds, .(A, B)]) # shuffle FSTs across positions

	# calc fst for each window to keep
	for(j in 1:(winsz/winstp)){
		temp2 <- temp[get(paste0('win', j, 'keep')) == 1, ] # trim to windows to keep. can't combine with next line for some reason.
		if(j ==1) tempfsts <- temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))]
		if(j > 1) tempfsts <- rbind(tempfsts, temp2[, .(fst = sum(A)/sum(B)), by = .(CHROM, POS = get(paste0('win', j)))])
	}

	# save the max windowed fst from the genome
	# exclude windows with negative midpoints
	if(i == 1) maxfst <- tempfsts[POS > 0, max(fst, na.rm = TRUE)]
	if(i > 1) maxfst <- c(maxfst, tempfsts[POS > 0, max(fst, na.rm = TRUE)])
}

print(paste('Max:', max(maxfst, na.rm = TRUE), '; 95th:', quantile(maxfst, prob = 0.95, na.rm = TRUE)))

write.csv(maxfst, gzfile(outfile), row.names = FALSE)


pipe <- function(){
  noslipwall <- matrix(rep(2, 82*52), nrow = 52)

  waterwall <-  rbind(rep(2,80), matrix(rep(0, 80*50), nrow = 50), rep(2,80))
  waterwall <- cbind(rep(2,52), waterwall, rep(4,52))

  mixed <- waterwall
  mixed[18:35, 1:30] <- 2
  mixed2 <- mixed
  mixed2[51, 10:30] <- 5
  mixed2[51, 9] <-2
  mixed2[51, 31] <- 2

  pipe2 <-mixed2
  pipe2[18, 1:30] <- 2
  pipe2[19:34, 1:30] <- 5
  pipe2[35, 1:30] <- 2

  pipe <- waterwall
  pipe[18, 1:30] <- 2
  pipe[19:34, 1:30] <- 5
  pipe[35, 1:30] <- 2

  array <- matrix(nrow=52*52, ncol=82)
  array[1:52, ] <- noslipwall
  array[53:(17*52), ] <- matrix( rep(t(waterwall), 16), ncol=82 , byrow = TRUE )
  array[(17*52+1):(18*52), ] <- mixed
  array[(18*52+1):(34*52), ] <- matrix( rep(t(pipe) , 16) , ncol=82 , byrow = TRUE )
  array[(34*52+1):(35*52), ] <- mixed
  array[(34*52+1):(35*52), ] <- mixed2  ##added for oral exam, not to be used
  array[(35*52+1):(51*52), ] <- matrix( rep(t(waterwall), 16), ncol=82 , byrow = TRUE )
  array[(51*52+1):(52*52), ] <- noslipwall

  arraybeg = matrix(c("P2", "82 2704", "6"))
  write.table(arraybeg, file="pipeinflow.pgm", sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(array, file="pipeinflow.pgm", append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#########################################################
##pipe outflow, into air/half water:
pipeAir <- function(x,y,z, piplen, fill, fz, outfl){ #outlf=1 or0, whther we have outflow on the right or not.
  noslipwall <- matrix(rep(2, (x+2)*(y+2)), nrow = y+2)

  waterwall <-  rbind(rep(2,x), matrix(rep(0, x*y), nrow = y), rep(2,x))
  waterwall <- cbind(rep(2,y+2), waterwall, rep(2*(1+outfl),y+2))
  airwall <- waterwall
  airwall[2:(y+1), 2:(x+1)] <- 1 #make it air

  fy <- floor(y/3)
  mixed <- airwall
  mixed[(fy):(2*fy+1), 1:(piplen+1)] <- 2

  mixed2 <- mixed
  mixed2[(fy+1):(2*fy), 1:(piplen+1)] <- 5
  #mixed2[fy, 1:(piplen+1)] <-2
  #mixed2[2*fy+1, 1:(piplen+1)] <- 2
  #pipe2 <-mixed2
  #pipe2[18, 1:30] <- 2
  #pipe2[19:34, 1:30] <- 5
  #pipe2[35, 1:30] <- 2
  #pipe <- waterwall
  #pipe[18, 1:30] <- 2
  #pipe[19:34, 1:30] <- 5
  #pipe[35, 1:30] <- 2

  #fz = floor(z/3)  #fz=where the pipe starts, with regrard to z coordinate. has to be higher then fill(=water level in pipe)
  fz2 = floor(z/3) #how 'wide' the pipe is in z dimension
  array <- matrix(nrow=(y+2)*(z+2), ncol=x+2)
  array[1:(y+2), ] <- noslipwall
  array[(y+3):((fill+1)*(y+2)), ] <- matrix( rep(t(waterwall), fill), ncol=x+2 , byrow = TRUE )
  array[((fill+1)*(y+2)+1):((fz+1)*(y+2)), ] <- matrix( rep(t(airwall), fz-fill), ncol=x+2 , byrow = TRUE )
  array[((fz+1)*(y+2)+1):((fz+2)*(y+2)), ] <- mixed
  array[((fz+2)*(y+2)+1):((fz+fz2+2)*(y+2)), ] <- matrix( rep(t(mixed2) , fz2) , ncol=x+2 , byrow = TRUE )
  array[((fz+fz2+2)*(y+2)+1):((fz+fz2+3)*(y+2)), ] <- mixed

  array[((fz+fz2+3)*(y+2)+1):((z+1)*(y+2)), ] <- matrix( rep(t(airwall), z-2-fz-fz2), ncol=x+2 , byrow = TRUE )
  array[((z+1)*(y+2)+1):((z+2)*(y+2)), ] <- noslipwall

  arraybeg = matrix(c("P2", paste( x+2, (y+2)*(z+2),sep= " "), "6"))
  write.table(arraybeg, file=paste("pipeinflow2", x,y,z,"-", fill, ".pgm",sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(array, file=paste("pipeinflow2", x,y,z,"-", fill, ".pgm",sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#pipeAir(x,y,z, piplen, fill, fz, outfl)
pipeAir(60,30,30, 20, 5, 15, 0)
#pipeAir(60,30,30, 20, 5, 10, 1)

###---------------------------------------------------###
buildCavity <- function(x, y, z){
  noslp <- matrix(rep(2, (x+2)*(y+2)), nrow=y+2);
  wall <- matrix(rep(6, (x+2)*(y+2)), nrow=y+2);
  middle <- noslp
  middle[2:(y+1), 2:(x+1)] <- 0
  simpleCavity <- noslp
  for (i in 2:(z+1)){
    simpleCavity <- rbind(simpleCavity, middle)
  }
  simpleCavity <- rbind(simpleCavity, wall)

  arraybeg2 = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybeg2, file=paste("cavity", x,y,z, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(simpleCavity, file=paste("cavity", x,y,z, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}
buildCavity2 <- function(x, y, z){
  noslp <- matrix(rep(2, (x+2)*(y+2)), nrow=y+2);
  wall <- matrix(rep(6, (x+2)*(y+2)), nrow=y+2);
  middle <- noslp
  middle[5:(y-2), 5:(x-2)] <- 0
  simpleCavity <- noslp
  for (i in 2:(z+1)){
    simpleCavity <- rbind(simpleCavity, middle)
  }
  simpleCavity <- rbind(simpleCavity, wall)

  arraybeg2 = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybeg2, file=paste("cavity", x,y,z, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(simpleCavity, file=paste("cavity", x,y,z, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}
#buildCavity(30, 30, 30)
#buildCavity(30, 20, 20)
#buildCavity(20, 30, 20)
#buildCavity(20, 20, 30)
#buildCavity2(20,20,2)

tum <- function(x,y,z, xdom, ydom, zdom, kjex, outpt){
  #create the TUM slice in yz, of size x*y*z. Whole domain pipe is of size xdom x ydom x zdom.
  #assumed, that y>=20 is multiple of 10, and z is multiple of 3.
  hy <- y/10
  hz <- z/3
  ostZ <- (zdom-z)/2
  ostY <- floor((ydom-y)/2)+1

  noslp <- matrix(rep(2, (xdom+2)*(ydom+2)), nrow=ydom+2);
  bckgrd <- noslp
  bckgrd[2:(ydom+1), 2:(xdom+1)] <- 0
  bckgrd[2:(ydom+1), 1] <- 5
  bckgrd[2:(ydom+1), xdom+2] <- 4

  TUM1 <- bckgrd
  TUM1[(ostY+1):(ostY+hy), kjex:(kjex-1+x)] <- 2
  TUM1[(ostY+hy*2+1):(ostY+3*hy), kjex:(kjex-1+x)] <- 2
  TUM1[(ostY+hy*4+1):(ostY+hy*7), kjex:(kjex-1+x)] <- 2
  TUM1[(ostY+hy*8+1):(ostY+hy*9), kjex:(kjex-1+x)] <- 2

  TUM2 <- TUM1
  TUM2[(ostY+hy*5+1):(ostY+hy*6), kjex:(kjex-1+x)] <- 0

  TUM3 <- bckgrd
  TUM3[(ostY+1):(ostY+hy*5), kjex:(kjex-1+x)] <- 2
  TUM3[(ostY+hy*6+1):(ostY+hy*10), kjex:(kjex-1+x)] <- 2

  TUM <- rbind(TUM1, TUM2, TUM3)
  matrika <- noslp
  if (ostZ>=1){
    for (i in 1:floor(ostZ)) {
      matrika <- rbind(matrika, bckgrd)
    }
  }
  for (i in 0:2) {
    for (j in 1:hz) {
      matrika <- rbind(matrika, TUM[((ydom+2)*i+1):((ydom+2)*(i+1)), ])
    }
  }
  if (ostZ>0){
    for (i in 1:ceiling(ostZ)) {
      matrika <- rbind(matrika, bckgrd)
    }
  }
  matrika <- rbind(matrika, noslp)

  if(outpt){
    return(matrika)
  } else {
    arraybg = matrix(c("P2", paste(xdom+2, (ydom+2)*(zdom+2), sep=" "), "6"))
    write.table(arraybg, file=paste("tum",y,z,":",kjex,"-",xdom,ydom,zdom,".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
    write.table(matrika, file=paste("tum",y,z,":",kjex,"-",xdom,ydom,zdom,".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
  }
}

#tum(x,y,z, xdom,ydom,zdom, kjex)
#tum(6, 20, 9, 24, 24, 20, 6)
#tum(10, 20, 20, 80, 20, 20, 30)

#        //sprintf( szFileName, "/media/norbert/940CB6150CB5F27A/Documents/simulation/%s.%i.vtk", szProblem, timeStepNumber );

twopipes <- function(x,y,z){
  noslipwall <- matrix(rep(2, (y+2)*(x+2)), nrow = y+2)

  waterwall <-  rbind(rep(2,x), matrix(rep(0, x*y), nrow = y), rep(2,x))
  waterwall <- cbind(rep(2,(y+2)), waterwall, rep(2,(y+2)))

  mixed <- waterwall
  mixed[floor(y/3):floor(2*y/3), floor(3/5*x):floor(4/5*x)] <- 2

  mixedend <- mixed
  mixedend[(floor(y/3)+1):(floor(2*y/3)-1), (floor(3/5*x)+1):(floor(4/5*x)-1)] <- 4 #outflow

  end <- noslipwall
  end2 <- waterwall
  end2[1:floor(y/3), floor(1/5*x):floor(2/5*x)] <- 2
  end2[2:(floor(y/3)-1), (floor(1/5*x)+1):(floor(2/5*x)-1)] <-  5 #inflow

  mixed2 <- mixed
  mixed2[61, 10:30] <- 5
  mixed2[61, 9] <-2
  mixed2[61, 31] <- 2

  mixed3 <- mixed
  mixed3[61, 9:31] <- 2

  matr <- noslipwall
  for (i in 1:ceiling(z/3)){
    matr <- rbind(matr, waterwall)
  }
  matr <- rbind(matr, mixedend)
  for (i in 1:(z-ceiling(z/3)-2)) {
    if (i ==1 ){
      matr <- rbind(matr, mixed3)
    }
    else if(i==21){
      matr <- rbind(matr, mixed3)
    }
    else if (i < 21){
      matr<- rbind(matr, mixed2)
    }

    else {matr <- rbind(matr, mixed)}
  }
  #
  matr <- rbind(matr, end2)
  #
  matr <- rbind(matr, end)

  arraybg = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybg, file=paste("twopipes",x,y,z,".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(matr, file=paste("twopipes",x,y,z,".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#twopipes(50,30,30)
#twopipes(100,60,60)

####################################################################################################3
breakingDam <- function(x,y,z, damx, outpt) {
  noslipwall <- matrix(rep(2, (y+2)*(x+2)), nrow = y+2)

  #make inner cells air
  airwall <-  rbind(rep(2,x), matrix(rep(1, x*y), nrow = y), rep(2,x))
  airwall <- cbind(rep(2,(y+2)), airwall, rep(2,(y+2)))

  #make some of it water:
  airwall[2:(y+1), 2:(damx+1)] <- 0

 matrik <- noslipwall
 for (i in 1:z) {
   matrik <- rbind(matrik, airwall)
 }
 matrik <- rbind(matrik, noslipwall)

 if (outpt==1) {
   return(matrik)
 } else {
   arraybg = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
   write.table(arraybg, file=paste("simpleDam",x,y,z,".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
   write.table(matrik, file=paste("simpleDam",x,y,z,".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
 }
}

#breakingDam(60,40,40,20)

######################################################################3
BeerDam <- function(x,y,z, damx, beer, beerheight, fill, size) {
  noslipwall <- matrix(rep(2, (y+2)*(x+2)), nrow = y+2)

  #make inner cells air
  airwall <-  rbind(rep(2,x), matrix(rep(1, x*y), nrow = y), rep(2,x))
  airwall <- cbind(rep(2,(y+2)), airwall, rep(2,(y+2)))

  #make some of it water:
  airwall[2:(y+1), 2:(damx+1)] <- 0

  #beer. sirok bo size=14 cells
#  size <- 14
  beery = (y-size)/2             #y mora biti SOD!

  #beer bottom #once
  beer0 <- airwall
  beer0[(beery+1):(beery+size), (beer+4):(beer+size-5)] <- 2
  beer0[(beery+2):(beery+size-1), (beer+3):(beer+size-4)] <- 2
  beer0[(beery+3):(beery+size-2), (beer+2):(beer+size-3)] <- 2
  beer0[(beery+4):(beery+size-3), (beer+1):(beer+size-2)] <- 2
  beer0[(beery+5):(beery+size-4), beer:(beer+size-1)] <- 2
  #beer middle    #z/4-1 times lower, same upper
  beer1 <- beer0
  beer1[(beery+3):(beery+size-2), (beer+4):(beer+size-5)] <- fill
  beer1[(beery+4):(beery+size-3), (beer+3):(beer+size-4)] <- fill
  beer1[(beery+5):(beery+size-4), (beer+2):(beer+size-3)] <-fill

  #beer handle beginning #twice lower, twice upper
  beerH0 <- beer1
  beerH0[(beery+size/2):(beery+size/2+1), (beer+size):(beer+size-1+size/2)] <- 2

  #beer handle middle   #z/2-2
  beerH1 <- beer1
  beerH1[(beery+size/2):(beery+size/2+1), (beer+size-2+size/2):(beer+size-1+size/2)] <- 2

  #binding it together
  how <- beerheight/4-1
  matrik <- rbind(noslipwall, beer0)
  for (i in 1:(how-1)) {
    matrik <- rbind(matrik, beer1)
  }
  #handle:
  matrik <- rbind(matrik, beerH0, beerH0)
  for (i in 1:(how*2)) {
    matrik <- rbind(matrik, beerH1)
  }
  matrik <- rbind(matrik, beerH0, beerH0)
  #rest of the glass
  for (i in 1:how) {
    matrik <- rbind(matrik, beer1)
  }

  #emptyspace
  for (i in 1:(z-beerheight)) {
    matrik <- rbind(matrik, airwall)
  }
  #end wall
  matrik <- rbind(matrik, noslipwall)

  arraybg = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybg, file=paste("beerDam",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(matrik,  file=paste("beerDam",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#BeerDam(x,y,z, damx, beer, beerheight, fill, size)
#BeerDam(100,60,60, 40, 51, 24, 0, 14)
#BeerDam(100,60,60, 40, 51, 24, 1, 14)
#BeerDam(100,60,60, 40, 51, 24, 2, 14)
#BeerDam(60,40,40, 20, 31, 12, 1, 12)

#this one, as a change from previous one, writes the handle perpendicularly to x axis.
BeerDam2 <- function(x,y,z, damx, beer, beerheight, fill, size) {
  noslipwall <- matrix(rep(2, (y+2)*(x+2)), nrow = y+2)

  #make inner cells air
  airwall <-  rbind(rep(2,x), matrix(rep(1, x*y), nrow = y), rep(2,x))
  airwall <- cbind(rep(2,(y+2)), airwall, rep(2,(y+2)))

  #make some of it water:
  airwall[2:(y+1), 2:(damx+1)] <- 0

  #beer. sirok bo size=14 cells
  #  size <- 14
  beery = (y-size)/2             #y mora biti SOD!

  #beer bottom #once
  beer0 <- airwall
  beer0[(beery+1):(beery+size), (beer+4):(beer+size-5)] <- 2
  beer0[(beery+2):(beery+size-1), (beer+3):(beer+size-4)] <- 2
  beer0[(beery+3):(beery+size-2), (beer+2):(beer+size-3)] <- 2
  beer0[(beery+4):(beery+size-3), (beer+1):(beer+size-2)] <- 2
  beer0[(beery+5):(beery+size-4), beer:(beer+size-1)] <- 2
  #beer middle    #z/4-1 times lower, same upper
  beer1 <- beer0
  beer1[(beery+3):(beery+size-2), (beer+4):(beer+size-5)] <- fill
  beer1[(beery+4):(beery+size-3), (beer+3):(beer+size-4)] <- fill
  beer1[(beery+5):(beery+size-4), (beer+2):(beer+size-3)] <-fill

  #beer handle beginning #twice lower, twice upper
  beerH0 <- beer1
  beerH0[(beery+size+1):(beery+size+size/2), (beer+size/2-1):(beer+size/2)] <- 2

  #beer handle middle   #z/2-2
  beerH1 <- beer1
  beerH1[(beery+size+size/2-1):(beery+size+size/2), (beer+size/2-1):(beer+size/2)] <- 2

  #binding it together
  how <- beerheight/4-1
  matrik <- rbind(noslipwall, beer0)
  for (i in 1:(how-1)) {
    matrik <- rbind(matrik, beer1)
  }
  #handle:
  matrik <- rbind(matrik, beerH0, beerH0)
  for (i in 1:(how*2)) {
    matrik <- rbind(matrik, beerH1)
  }
  matrik <- rbind(matrik, beerH0, beerH0)
  #rest of the glass
  for (i in 1:how) {
    matrik <- rbind(matrik, beer1)
  }

  #emptyspace
  for (i in 1:(z-beerheight)) {
    matrik <- rbind(matrik, airwall)
  }
  #end wall
  matrik <- rbind(matrik, noslipwall)

  arraybg = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybg, file=paste("beerDam2-",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(matrik,  file=paste("beerDam2-",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#BeerDam2(60,40,40, 20, 31, 12, 1, 12)
#BeerDam2(100,60,60, 40, 51, 24, 0, 14)
#BeerDam2(100,60,60, 40, 51, 24, 1, 14)
#BeerDam2(100,60,60, 40, 51, 24, 2, 14)

#the usual pipe scenario, but with the beer
BeerPipe2 <- function(x,y,z, beer, beerheight, fill, size) {
  noslipwall <- matrix(rep(2, (y+2)*(x+2)), nrow = y+2)

  #make inner cells water
  airwall <-  rbind(rep(2,x), matrix(rep(0, x*y), nrow = y), rep(2,x))
  airwall <- cbind(rep(5,(y+2)), airwall, rep(4,(y+2)))

  #beer. sirok bo size=14 cells
  #  size <- 14
  beery = (y-size)/2             #y mora biti SOD!

  #beer bottom #once
  beer0 <- airwall
  beer0[(beery+1):(beery+size), (beer+4):(beer+size-5)] <- 2
  beer0[(beery+2):(beery+size-1), (beer+3):(beer+size-4)] <- 2
  beer0[(beery+3):(beery+size-2), (beer+2):(beer+size-3)] <- 2
  beer0[(beery+4):(beery+size-3), (beer+1):(beer+size-2)] <- 2
  beer0[(beery+5):(beery+size-4), beer:(beer+size-1)] <- 2
  #beer middle    #z/4-1 times lower, same upper
  beer1 <- beer0
  beer1[(beery+3):(beery+size-2), (beer+4):(beer+size-5)] <- fill
  beer1[(beery+4):(beery+size-3), (beer+3):(beer+size-4)] <- fill
  beer1[(beery+5):(beery+size-4), (beer+2):(beer+size-3)] <-fill

  #beer handle beginning #twice lower, twice upper
  beerH0 <- beer1
  beerH0[(beery+size+1):(beery+size+size/2), (beer+size/2-1):(beer+size/2)] <- 2

  #beer handle middle   #z/2-2
  beerH1 <- beer1
  beerH1[(beery+size+size/2-1):(beery+size+size/2), (beer+size/2-1):(beer+size/2)] <- 2

  #binding it together
  how <- beerheight/4-1
  matrik <- rbind(noslipwall, beer0)
  for (i in 1:(how-1)) {
    matrik <- rbind(matrik, beer1)
  }
  #handle:
  matrik <- rbind(matrik, beerH0, beerH0)
  for (i in 1:(how*2)) {
    matrik <- rbind(matrik, beerH1)
  }
  matrik <- rbind(matrik, beerH0, beerH0)
  #rest of the glass
  for (i in 1:how) {
    matrik <- rbind(matrik, beer1)
  }

  #emptyspace
  for (i in 1:(z-beerheight)) {
    matrik <- rbind(matrik, airwall)
  }
  #end wall
  matrik <- rbind(matrik, noslipwall)

  arraybg = matrix(c("P2", paste(x+2, (y+2)*(z+2), sep=" "), "6"))
  write.table(arraybg, file=paste("beerPipe2-",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(matrik,  file=paste("beerPipe2-",x,y,z,"-", beer, beerheight, "-", fill, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#BeerPipe2(100,60,60, 51, 24, 0, 14)

#xdom <-30; ydom <- 20; zdom <- 10
#damx <- 10; tumx <- 21; x<-5;y<-20;z<-9
#outflw<-0
tumDam <- function(xdom, ydom, zdom, damx, tumx, x,y,z, outflw){
  tumi <- tum(x,y,z, xdom,ydom,zdom, tumx, 1)
  dam <- breakingDam(xdom,ydom,zdom, damx, 1)

  #tumi[tumi==0] <- 1 #instead of water, have air
  sum <- tumi+dam
  sum[sum==4] <- 2
  sum[sum==7] <- 2
  sum[sum==6] <- 2*(1+outflw)

  arraybg = matrix(c("P2", paste(xdom+2, (ydom+2)*(zdom+2), sep=" "), "6"))
  write.table(arraybg, file=paste("tumDam-",xdom,ydom,zdom,"-", damx, tumx, "-", outflw, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(sum,  file=paste("tumDam-",xdom,ydom,zdom,"-", damx, tumx, "-", outflw, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)
}

#debug tryouts:
#tumDam(30,30,30, 10, 21, 10, 30, 30, 0)
#actual cases:
#tumDam(100,60,60, 40, 61, 10, 60, 60, 0)
#tumDam(100,60,60, 40, 61, 10, 60, 60, 1)

cityDam <- function(xd, yd, zd, damx, out){ #, obst){
  noslipwall <- matrix(rep(0, (xd+2)*(yd+2)), nrow = yd+2)
  #waterwall <-  rbind(rep(2,xd), matrix(rep(0, xd*yd), nrow = yd), rep(2,xd))
  #waterwall <- cbind(rep(2,yd+2), waterwall, rep(2*(1+out), yd+2))
  waterwall <- noslipwall; waterwall[1:(yd+2), xd+2] <- 2*out

  gemuse <- breakingDam(xd,yd,zd, damx, 1)

  #####house on a hill obstacle. assumed: all of it is in air.
  #make the hill
  hrib <- ceiling((xd-damx)/3)+damx
  apfel <- waterwall; apfel[2:(yd-1), hrib:(xd+2)] <- 1
  strudel <- apfel; strudel[2:(yd-1), hrib] <- 0
  ofen <- strudel; ofen[2:(yd-1), hrib+1] <- 0
  teller <- ofen; teller[2:(yd-1), hrib+2] <- 0
  mund <- teller; mund[2:(yd-1), hrib+3] <- 0

  #make the haus
  hswidth <- floor((xd-hrib-3)/3)
  hs <- hswidth + hrib + 3
  haus <- waterwall; haus[2:floor(3/2*hswidth), (hs+1):(hs+hswidth)] <- 1   ##haus walls are no slip too
  dach1 <- haus; dach1[2:floor(3/2*hswidth), (hs-1):(hs+hswidth+2)] <- 1
  dach2 <- haus; dach2[2:floor(3/2*hswidth), (hs):(hs+hswidth+1)] <- 1
  dach3 <- haus;
  dach4 <- waterwall; dach4[2:floor(3/2*hswidth), (hs+2):(hs+hswidth-1)] <- 1
  dach5 <- waterwall; dach5[2:floor(3/2*hswidth), (hs+4):(hs+hswidth-3)] <- 1

  haushei <- ceiling((zd-8-6)*3/7)
  obst <- rbind(noslipwall, apfel, apfel, apfel, strudel, strudel, ofen, teller, mund) #noslip + 8lines of hill
  for (i in 1:haushei){
    obst <- rbind(obst, haus)
  }
  obst <- rbind(obst, dach1, dach1, dach2, dach3, dach4, dach5)
  rem <- zd-haushei-6-8
  for (i in 1:rem){
    obst <- rbind(obst, waterwall)
  }
  obst <- rbind(obst, noslipwall)
  #######################################################
  ####Tree on same hill obstacle
  #hill ends and tree starts at z=10
  tree <- rbind(noslipwall, noslipwall, noslipwall); tree <- rbind(tree, tree, tree);
  #tree(till leaves) height:
  trehig <- haushei+4
  roots1 <- noslipwall; roots1[(yd-6):(yd-5),(xd-7):(xd-4)] <-1; roots1[(yd-7):(yd-4),(xd-6):(xd-5)] <-1
  for (i in 1:trehig){
    tree <- rbind(tree, roots1)
  }
  roots2 <- noslipwall; roots2[(yd-7):(yd-4),(xd-8):(xd-3)] <-1; roots2[(yd-8):(yd-3),(xd-7):(xd-4)] <-1
  roots3 <- roots2; roots3[(yd-6):(yd-5),(xd-9):(xd-2)] <-1; roots3[(yd-9):(yd-2),(xd-6):(xd-5)] <-1
  endtree <- noslipwall; endtree[(yd-6):(yd-5), (xd-6):(xd-5)] <- 1
  tree <- rbind(tree, roots2, roots2, roots3, roots3, roots3, roots3, roots2, roots1, endtree)

  rem <- zd-10-trehig-8
  for (i in 1:(rem+2)){
    tree <- rbind(tree, noslipwall)
  }
  ########################################################
  print(dim(tree)); print(dim(obst)); print(dim(gemuse))
  sum <- obst+gemuse+tree

  arraybg = matrix(c("P2", paste(xd+2, (yd+2)*(zd+2), sep=" "), "6"))
  write.table(arraybg, file=paste("cityDam-",xd,yd,zd,"-", damx,"-", out, ".pgm", sep=""), sep=" ", quote=FALSE, row.names=FALSE, col.names=FALSE)
  write.table(sum,  file=paste("cityDam-",xd,yd,zd,"-", damx,"-", out, ".pgm", sep=""), append=TRUE, sep=" ", row.names=FALSE, col.names=FALSE)

}

#cityDam(x,y,z, damx, outflow)
cityDam(100, 60, 60, 40, 0)


args <- commandArgs(TRUE)

#inputs for the script:

#data input
tab <- as.character(args[1])

#the size (number of bins!) of the smoothing window
window  <- as.numeric(args[2])

#plot limits
mincoord <- as.numeric(args[3])
maxcoord <- as.numeric(args[4])
abs_max_y = as.numeric(args[5])

#ids of experiments (should be present in the table!)
foc_ids <- eval(parse(text=paste('list(', args[6], ')')))

do_plot = 0
do_table = 1

#output name
tab_nm = as.character(args[7])

#if this is 1, only non-unique fragends will be used, otherwise only unique are considered
multi = as.numeric(args[8])

quants = c(0.05,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,0.95)

#For reference
beta_ids=c(498,499,477,524,525,546,489,490,510,511,530,550,493,513,532,533,553,554)
alpha_ids=c(487,488,508,509,529,549,491,492,512,531,551,552)
satb_ids = c(514,515,534,535,555,556)

bd = read.table(tab, header=T)

#to save time, the moving quantile jumps in steps (but we set the step so that our window will have about 40 steps - ensuring high enough resolution
step = round(window/40)

have_ref = 0

rpt_n = length(foc_ids)
nplts = length(foc_ids)*3+1

combined = c()
combined_ord = c()

mat = data.frame()

for(exp_id in foc_ids) {

#extract only the columns of the relevant experiment
	bd_id = bd[,grep(paste(exp_id,"_", sep=""), names(bd))]

#change column names for simplicity
	names(bd_id) = sub(paste("e", exp_id,"_",sep=""), "e", names(bd_id))

#extract 3 and 5 frag end data, unique, non-blind
	uni_cut_3 = bd_id$e3
	uni_cut_3[bd_id$efe3 > bd_id$efl] = NA

	uni_cut_5 = bd_id$e5
	uni_cut_5[bd_id$efe5 > bd_id$efl] = NA
	if(multi == 1) {
		uni_cut_3[bd_id$e3m == 1] = NA
		uni_cut_5[bd_id$e5m == 1] = NA
	} else {
		uni_cut_3[bd_id$e3m != 1] = NA
		uni_cut_5[bd_id$e5m != 1] = NA
	}

#complete missing data with approx (to ensure quantile normalization is not affected by variable density of blind/non_blind or different cutters)
	uni_cut3_full = approx(bd$start, uni_cut_3, n=length(bd$start))
	uni_cut5_full = approx(bd$start, uni_cut_5, n=length(bd$start))

#currenty our reference for the normalization is the first exp in the list
	if(have_ref == 0) {
		reference = c(uni_cut3_full$y, uni_cut5_full$y)
		have_ref = 1
	}

#copmute coumulative density function
	uni_cut3_ecdf = ecdf(uni_cut3_full$y)
	uni_cut5_ecdf = ecdf(uni_cut5_full$y)
#quant normalize given the reference. Not that we put the NA's back (ecdf(uni_cut_3) and not ecdf(uni_cut3_full), but the ecdf is normalized for fragend density

	uni_cut3_norm = quantile(reference, uni_cut3_ecdf(uni_cut_3))
	uni_cut5_norm = quantile(reference, uni_cut5_ecdf(uni_cut_5))

#combining the 3 and 5 ends

	uni_bli_3 = bd_id$e3
	uni_bli_3[bd_id$efe3 < bd_id$efl] = NA

	uni_bli_5 = bd_id$e5
	uni_bli_5[bd_id$efe5 < bd_id$efl] = NA

	if(multi == 1) {
		uni_bli_3[bd_id$e3m == 1] = NA
		uni_bli_5[bd_id$e5m == 1] = NA
	} else {
		uni_bli_3[bd_id$e3m != 1] = NA
		uni_bli_5[bd_id$e5m != 1] = NA
	}

#complete missing data with approx?
	uni_bli3_full = approx(bd$start, uni_bli_3, n=length(bd$start))
	uni_bli5_full = approx(bd$start, uni_bli_5, n=length(bd$start))
#copmute quants
	uni_bli3_ecdf = ecdf(uni_bli3_full$y)
	uni_bli5_ecdf = ecdf(uni_bli5_full$y)
#quant normalize to a reference
	uni_bli3_norm = quantile(reference, uni_bli3_ecdf(uni_bli_3))
	uni_bli5_norm = quantile(reference, uni_bli5_ecdf(uni_bli_5))

	if(do_table == 1) {
		if(dim(mat)[1] == 0) {
			mat = cbind(bd$start, uni_cut3_norm, uni_cut5_norm, uni_bli3_norm, uni_bli5_norm)
		} else {
			mat = cbind(mat, uni_cut3_norm, uni_cut5_norm, uni_bli3_norm, uni_bli5_norm)
		}
	}
}

if(do_table == 1){
	write.table(mat, tab_nm, sep="\t", quote=F,row.names=F,col.names=F)
}


ancom.detect <- function (otu_data, n_otu, alpha, multcorr, ncore)
{
    Group <- otu_data[, ncol(otu_data)]
    if (length(unique(Group)) == 2) {
        tfun <- exactRankTests::wilcox.exact
    }
    else {
        tfun <- stats::kruskal.test
    }
    if (TRUE) {
        registerDoParallel(cores = ncore)
        aa <- bb <- NULL
        logratio.mat <- foreach(bb = 1:n_otu, .combine = "rbind",
            .packages = "foreach") %:% foreach(aa = 1:n_otu,
            .combine = "c", .packages = "foreach") %dopar% {
            if (aa == bb) {
                p_out <- NA
            }
            else {
                data.pair <- otu_data[, c(aa, bb, n_otu + 1)]
                lr <- log((0.001 + as.numeric(data.pair[, 1]))/(0.001 +
                  as.numeric(data.pair[, 2])))
                lr_dat <- data.frame(lr = lr, Group = Group)
                p_out <- tfun(lr ~ Group, data = lr_dat)$p.value
            }
            p_out
        }
        rownames(logratio.mat) <- colnames(logratio.mat) <- NULL
    }
    else {
        logratio.mat <- matrix(NA, nrow = n_otu, ncol = n_otu)
        for (ii in 1:(n_otu - 1)) {
            for (jj in (ii + 1):n_otu) {
                data.pair <- otu_data[, c(ii, jj, n_otu + 1)]
                lr <- log((0.001 + as.numeric(data.pair[, 1]))/(0.001 +
                  as.numeric(data.pair[, 2])))
                lr_dat <- data.frame(lr = lr, Group = Group)
                logratio.mat[ii, jj] <- tfun(lr ~ Group, data = lr_dat)$p.value
            }
        }
        ind <- lower.tri(logratio.mat)
        logratio.mat[ind] <- t(logratio.mat)[ind]
    }
    logratio.mat[which(is.finite(logratio.mat) == FALSE)] <- 1
    mc.pval <- t(apply(logratio.mat, 1, function(x) {
        s <- p.adjust(x, method = "BH")
        return(s)
    }))
    a <- logratio.mat[upper.tri(logratio.mat, diag = FALSE) ==
        TRUE]
    b <- matrix(0, ncol = n_otu, nrow = n_otu)
    b[upper.tri(b) == T] <- p.adjust(a, method = "BH")
    diag(b) <- NA
    ind.1 <- lower.tri(b)
    b[ind.1] <- t(b)[ind.1]
    if (multcorr == 1) {
        W <- apply(b, 1, function(x) {
            subp <- length(which(x < alpha))
        })
    }
    else if (multcorr == 2) {
        W <- apply(mc.pval, 1, function(x) {
            subp <- length(which(x < alpha))
        })
    }
    else if (multcorr == 3) {
        W <- apply(logratio.mat, 1, function(x) {
            subp <- length(which(x < alpha))
        })
    }
    return(W)
}


## Main script for running the model integration examples
library("treeSeedlingMetamodelData")
library("treeSeedlingMetamodel")
library(LaplacesDemon)
data(seedlings, envir = environment())

sp <- seedlings$species[1]

# do the following for each species
	naiveDat <- naive_ld_dat(seedlings$sdm_adults[[sp]])

	# note that this is an EXAMPLE - it is impossible to do this automatically, because fitting LD models
	# is done by trial and error
	naiveMod <- LaplacesDemon::LaplacesDemon(naive_lp, naiveDat, LaplacesDemon::GIV(naive_lp, naiveDat, PGF=TRUE),
		Algorithm = "AM", specs=list(Adaptive = 50, Periodicity = 50), Iterations = 100)

	# for some guidance, use consort()
	Consort(naiveMod)

	# set initial values and re-fit with a non-adaptive algorithm
	Initial.Values <- as.initial.values(naiveMod)
	naiveMod <- LaplacesDemon::LaplacesDemon(naive_lp, naiveDat, Initial.Values, Covar=naiveMod$Covar, Iterations=100000,
		Status=5000, Algorithm="RWM")

	## survival model
	survDat <- survival_ld_dat(seedlings$survival[[sp]])
	survMod <- LaplacesDemon::LaplacesDemon(survival_lp, survDat, LaplacesDemon::GIV(survival_lp, survDat, PGF=TRUE),
		Algorithm = "AM", specs=list(Adaptive = 50, Periodicity = 50), Iterations = 100)

	# set initial values and re-fit with a non-adaptive algorithm
	Initial.Values <- as.initial.values(survMod)
	survMod <- LaplacesDemon::LaplacesDemon(survival_lp, survDat, Initial.Values, Covar=survMod$Covar, Iterations=100000,
		Status=5000, Algorithm="RWM")

	## recruitment model
	popDat <- recruitment_ld_dat(seedlings$population[[sp]])
	popMod <- LaplacesDemon::LaplacesDemon(recruitment_lp, popDat, LaplacesDemon::GIV(recruitment_lp, popDat, PGF=TRUE),
		Algorithm = "AM", specs=list(Adaptive = 50, Periodicity = 50), Iterations = 100, Status=1000)

	# set initial values and re-fit with a non-adaptive algorithm
	Initial.Values <- as.initial.values(popMod)
	popMod <- LaplacesDemon::LaplacesDemon(recruitment_lp, popDat, Initial.Values, Covar=popMod$Covar, Iterations=100000,
		Status=5000, Algorithm="RWM")

	# integrated model
	intDat <- integrated_ld_dat(seedlings$sdm_adults[[sp]], seedlings$survival[[sp]], seedlings$population[[sp]])
	intMod <- LaplacesDemon::LaplacesDemon(integrated_lp, intDat, LaplacesDemon::GIV(integrated_lp, intDat, PGF=TRUE),
		Algorithm = "AM", specs=list(Adaptive = 50, Periodicity = 50), Iterations = 100)

	# set initial values and re-fit with a non-adaptive algorithm
	Initial.Values <- as.initial.values(intMod)
	intMod <- LaplacesDemon::LaplacesDemon(integrated_lp, intDat, Initial.Values, Covar=intMod$Covar, Iterations=100000,
		Status=5000, Algorithm="AFSS", Specs=list(A=Inf, B=Null, m=100, n=0, w=1))


library(nimble)

#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Link function corresponding to a discretized mixture density function
#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
if(!file.exists("skew_cdf.o")){
if(!fPIC){
	system("g++ -c -Wall -I ./ skew_cdf.cpp")
} else {
	system("g++ -c -Wall -fPIC -I ./ skew_cdf.cpp") # under some architectures
}
}

diffc <- nimbleExternalCall( function(out = double(1),  # output
				     x = double(1), # input
				n = integer(0)
				){},
			    Cfun =  'diffc',
		    headerFile = file.path(getwd(),"./skew_cdf.hpp"),
			    returnType = void(),
			    oFile = file.path(getwd(),"./skew_cdf.o"))

diffc_vec = nimbleFunction(run = function(x = double(1)) {
				   val <- numeric(length(x))
				   diffc(val,x,length(x))
				   return(val)
				            returnType(double(1))

})

psnc <- nimbleExternalCall( function(out = double(1),  # output
				     x = double(1), # input
				      xi = double(0),
				      omega = double(0),
				      alpha = double(0),
				n = integer(0)
				){},
			    Cfun =  'psnc',
		    headerFile = file.path(getwd(),"./skew_cdf.hpp"),
			    returnType = void(),
			    oFile = file.path(getwd(),"./skew_cdf.o"))

psnc_vec = nimbleFunction(run = function(x = double(1),
					 xi = double(0),
					 omega = double(0),
					 alpha = double(0) ) {
				   val <- numeric(length(x))
				   psnc(val,x, xi,omega,alpha,length(x))
				   return(val)
				            returnType(double(1))
})

link_func = nimbleFunction(
			   run = function(x=double(1),
					  w = double(1,3),

					  mu = double(0),
					  lsigma = double(0),

					  xi = double(0),
					  lomega = double(0),
					  alpha = double(0)
					  ){
				   returnType(double(1))

				   # Skek normal cdf (check for positive contraints)
				   tmp3 <- psnc_vec(x, xi,exp(lomega),alpha)
				   tmp2 <- pnorm(x, mu, sd = exp(lsigma))
				   tmp <- w[2] * diffc_vec(tmp2) + w[3] * diffc_vec(tmp3)
				   tmp[1] <- w[1]

				   #return(tmp)
				   return(tmp/sum(tmp))
			   }
)


install.packages("BiocManager")
install.packages("gRbase")
install.packages("Hmisc")
install.packages("ggm")
install.packages("igraph")
install.packages("kableExtra")
install.packages("bnlearn")


#' ---
#' author: "Jenny Bryan"
#' output:
#'   html_document:
#'     keep_md: TRUE
#' ---

#+ setup, include = FALSE
library(knitr)
opts_chunk$set(fig.path = 'figure/shock-awe-', error = TRUE)

#' Note: this HTML is made by applying `knitr::spin()` to an R script. So the
#' narrative is very minimal.

library(ggplot2)

#' pick a way to load the data
#gdURL <- "http://tiny.cc/gapminder"
#gapminder <- read.delim(file = gdURL)
#gapminder <- read.delim("gapminderDataFiveYear.tsv")
library(gapminder)
str(gapminder)

#' drop Oceania
gapminder <- droplevels(subset(gapminder, continent != "Oceania"))

#' Note that the gapminder package ships with color schemes for countries and continents.
head(country_colors)

jYear <- 2007 # this can obviously be changed
jPch <- 21
jDarkGray <- 'grey20'
jXlim <- c(150, 115000)
jYlim <- c(16, 100)

ggplot(subset(gapminder, year == jYear),
       aes(x = gdpPercap, y = lifeExp)) +
  scale_x_log10(limits = jXlim) + ylim(jYlim) +
  geom_point(aes(size = sqrt(pop/pi)), pch = jPch, color = jDarkGray,
             show_guide = FALSE) +
  scale_size_continuous(range=c(1,40)) +
  facet_wrap(~ continent) + coord_fixed(ratio = 1/43) +
  aes(fill = country) + scale_fill_manual(values = country_colors) +
  theme_bw() + theme(strip.text = element_text(size = rel(1.1)))

ggplot(gapminder, aes(x = year, y = lifeExp, group = country)) +
  geom_line(lwd = 1, show_guide = FALSE) + facet_wrap(~ continent) +
  aes(color = country) + scale_color_manual(values = country_colors) +
  theme_bw() + theme(strip.text = element_text(size = rel(1.1)))


### R code from vignette source 'SPIA.Rnw'

###################################################
### code chunk number 1: SPIA.Rnw:75-79
###################################################
library(SPIA)
data(colorectalcancer)
options(digits=3)
head(top)

###################################################
### code chunk number 2: SPIA.Rnw:99-108
###################################################
library(hgu133plus2.db)
x <- hgu133plus2ENTREZID
top$ENTREZ<-unlist(as.list(x[top$ID]))
top<-top[!is.na(top$ENTREZ),]
top<-top[!duplicated(top$ENTREZ),]
tg1<-top[top$adj.P.Val<0.1,]
DE_Colorectal=tg1$logFC
names(DE_Colorectal)<-as.vector(tg1$ENTREZ)
ALL_Colorectal=top$ENTREZ

###################################################
### code chunk number 3: SPIA.Rnw:118-120
###################################################
DE_Colorectal[1:10]
ALL_Colorectal[1:10]

###################################################
### code chunk number 4: SPIA.Rnw:127-133
###################################################
# pathway analysis based on combined evidence; # use nB=2000 or more for more accurate results
res=spia(de=DE_Colorectal,all=ALL_Colorectal,organism="hsa",nB=2000,plots=FALSE,beta=NULL,combine="fisher",verbose=FALSE)
#make the output fit this screen
res$Name=substr(res$Name,1,10)
#show first 15 pathways, omit KEGG links
res[1:20,-12]

###################################################
### code chunk number 5: SPIA.Rnw:156-159
###################################################
plotP(res,threshold=0.05)
points(I(-log(pPERT))~I(-log(pNDE)),data=res[res$ID=="05210",],col="green",pch=19,cex=1.5)

###################################################
### code chunk number 6: SPIA.Rnw:186-193
###################################################
res$pG=combfunc(res$pNDE,res$pPERT,combine="norminv")
res$pGFdr=p.adjust(res$pG,"fdr")
res$pGFWER=p.adjust(res$pG,"bonferroni")

plotP(res,threshold=0.05)
points(I(-log(pPERT))~I(-log(pNDE)),data=res[res$ID=="05210",],col="green",pch=19,cex=1.5)

###################################################
### code chunk number 7: SPIA.Rnw:209-216
###################################################
data(Vessels)
# pathway analysis based on combined evidence; # use nB=2000 or more for more accurate results
res<-spia(de=DE_Vessels,all=ALL_Vessels,organism="hsa",nB=500,plots=FALSE,beta=NULL,verbose=FALSE)
#make the output fit this screen
res$Name=substr(res$Name,1,10)
#show first 15 pathways, omit KEGG links
res[1:15,-12]

###################################################
### code chunk number 8: SPIA.Rnw:222-223
###################################################
res[,"KEGGLINK"][20]

###################################################
### code chunk number 9: SPIA.Rnw:235-246
###################################################
  rel<-c("activation","compound","binding/association","expression","inhibition",
"activation_phosphorylation","phosphorylation","inhibition_phosphorylation",
"inhibition_dephosphorylation","dissociation","dephosphorylation",
"activation_dephosphorylation","state change","activation_indirect effect",
"inhibition_ubiquination","ubiquination", "expression_indirect effect",
"inhibition_indirect effect","repression","dissociation_phosphorylation",
"indirect effect_phosphorylation","activation_binding/association",
"indirect effect","activation_compound","activation_ubiquination")
beta=c(1,0,0,1,-1,1,0,-1,-1,0,0,1,0,1,-1,0,1,-1,-1,0,0,1,0,1,1)
names(beta)<-rel
cbind(beta)

###################################################
### code chunk number 10: SPIA.Rnw:255-258
###################################################
load(file=paste(system.file("extdata/hsaSPIA.RData",package="SPIA")))
names(path.info[["05210"]])
path.info[["05210"]][["activation"]][25:35,30:40]

###################################################
### code chunk number 11: SPIA.Rnw:267-286
###################################################
library(graph)
library(Rgraphviz)

plotG<-function(B){
 nnms<-NULL;colls<-NULL
 mynodes<-colnames(B)
 L<-list();
 n<-dim(B)[1]
 for (i in 1:n){
 L[i]<-list(edges=rownames(B)[abs(B[,i])>0])
 if(sum(B[,i]!=0)>0){
 nnms<-c(nnms,paste(colnames(B)[i],rownames(B)[B[,i]!=0],sep="~"))
 }
 }
 names(L)<-rownames(B)
 g<-new("graphNEL",nodes=mynodes,edgeL=L,edgemode="directed")
 plot(g)
}

###################################################
### code chunk number 12: SPIA.Rnw:295-296
###################################################
plotG(path.info[["04012"]][["activation"]])

###################################################
### code chunk number 13: SPIA.Rnw:312-317
###################################################
mydir=system.file("extdata/keggxml/hsa",package="SPIA")
dir(mydir)
makeSPIAdata(kgml.path=mydir,organism="hsa",out.path="./")
res<-spia(de=DE_Colorectal, all=ALL_Colorectal, organism="hsa",data.dir="./")
res[,-12]


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Sun Jan 24 19:33:22 2010
########################################################
#Choropleths of the homicide rate by county according to the INEGI
#data source: Estadísticas Vitales INEGI

#Clean data file with all homicides *registered* by county and sex
cleanHomicide <- function(filename, sex) {
  df <- read.csv(bzfile(filename), skip = 4)
  names(df)[1:4] <- c("Code","County","Year.of.Murder","Sex")
  df <- df[-grep("=CONCATENAR", df$Code),]
  #df <- df[-grep("FUENTE: INEGI. Estadísticas de mortalidad.", df$Code),]
  df <- df[-grep("Total", df$County),]
  df <- df[-grep("No especificado", df$County),]
  df <- df[-grep("Total", df$Year.of.Murder),]
  df <- df[-grep("No especificado", df$Year.of.Murder),]
  if (sex=="Total") {
    df <- df[grep("Total", df$Sex),]
  } else if (sex == "Mujer") {
     df <- df[grep("Mujer", df$Sex),]
  } else if (sex == "Dfbre") {
    df <- df[grep("Dfbre", df$Sex),]
  }

  df$X.4 <- NULL
  df$Year.of.Murder <- as.numeric(gsub('[[:alpha:]]', '',
                                   df$Year.of.Murder))
  df <- subset(df, Year.of.Murder >= 1990)
  col2cvt <- 5:ncol(df)
  df[,col2cvt] <- lapply(df[,col2cvt],
                          function(x){
                              as.numeric(gsub(",", "", x))})
  df[is.na(df)] <- 0
  df$tot <- apply(df[ , col2cvt], 1, sum)
  df$CLAVE <- as.numeric(gsub(" ", "", df$Code))
  df
}

#population from the CONAPO
cleanPopCONAPO <- function(filename) {
  pop <- read.csv(bzfile(filename))
  pop <- na.omit(pop)
  col2cvt <- 3:ncol(pop)
  pop[,col2cvt] <- lapply(pop[ ,col2cvt],
                          function(x){
                              as.numeric(gsub(" ", "", x))})
  popm <- melt(pop, id = c("Clave", "Entidad.federativa.o.municipio"))
  #The CONAPO adds a "0" to the county codes, remove it
  popm$variable <- substring(popm$variable, 2)
  names(popm) <- c("Clave", "County", "Year", "Population")
  popm
}

#population from the inegi
cleanPopINEGI <- function(filename, year, type = "Total") {
  pop <- read.csv(filename)
  pop <- na.omit(pop)
  pop <- subset(pop, County != "Total" &
                     Code != "#NAME?")
  pop$Clave <- as.numeric(gsub(" ", "", pop$Code))
  pop$Code <- NULL
  if (type == "Total") {
    pop$Hombres <- NULL
    pop$Mujeres <- NULL
  } else if (type == "Mujer"){
    pop$Total <- NULL
    pop$Hombres <- NULL
  }
  pop$Year <- year
  names(pop)[2] <- "Population"
  pop
}

#Plot a map of the murder rate
drawMap <- function(vector, title, breaks, text = NA) {
  plotvar<- unlist(vector)
  nclr <- 9
  plotclr <- brewer.pal(nclr,"Reds")
  fillRed <- colorRampPalette(plotclr)
  plotvar[plotvar >= maxh] <- maxh -1
  colcode <- fillRed(maxh)[round(plotvar) + 1]
  plot(mexico.ct.shp, col = colcode, lty = 0, border = "gray")
  plot(mexico.st.shp, add = TRUE, lwd=1, border = "gray30")
  title(main = title)
  colorlegend(posy = c(0.05,0.9), posx = c(0.9,0.92),
              col = fillRed(maxh),
              zlim=c(0, maxh), zval = breaks,
              main = "homicides per\n100,000")
  par(bg='white')
}

#As always it's a pain to make sure the counties line up
#with the correct data
mergeMap <- function(df, year){
  hom.popmX <- subset(df, Year.of.Murder == year)
  mun.complete<-data.frame(CLAVE = mexico.ct.shp$CLAVE,
                           CVE_ENT = mexico.ct.shp$CVE_ENT,
                           CVE_MUN = mexico.ct.shp$CVE_MUN)
  hom.popmX$CLAVE <- gsub(" ", "", hom.popmX$Code)
  map<-merge(mun.complete, hom.popmX, by = "CLAVE", all.x = TRUE)
  map$rate[is.na(map$rate)] <- 0
  map
}

savePlot <- function(df, year, text, breaks){
    name <- config$titles.ch
    map <- mergeMap(df, year)
    write.csv(map, paste("choropleths/output/map",
              year, ".csv", sep = ""))
    filename <- paste("choropleths/output/", name, ", ",
                      as.character(year), ".png", sep ="")
    title <- paste(name, ", ", as.character(year), sep ="")
    Cairo(file = filename,
          width=960, height=600, type="png", bg="white")
    print(drawMap(map$rate, title, breaks, text))
    dev.off()
}

#read the file with population data from 2006-2008
#read the files with population data from the censuses
readPop <- function(type){
  if(type=="Total") {
    popm <- cleanPopCONAPO("timelines/data/pop.csv.bz2")
  } else{
    popm <- cleanPopCONAPO("choropleths/data/pop-w.csv.bz2")
  }
  pop90 <- cleanPopINEGI("choropleths/data/inegi1990.csv", 1990, type)
  pop95 <- cleanPopINEGI("choropleths/data/inegi1995.csv", 1995, type)
  pop00 <- cleanPopINEGI("choropleths/data/inegi2000.csv", 2000, type)

  rbind(popm, pop90, pop95, pop00)
}

mergeHomPop <- function(hom, popm){
  hom.popm <- merge(hom, popm, by.x = c("CLAVE", "Year.of.Murder"),
                    by.y = c("Clave", "Year"))
  hom.popm$rate<- (hom.popm$tot / hom.popm$Population) *
                          100000
  hom.popm <- hom.popm[order(-hom.popm$rate),]
  hom.popm$CLAVE <- as.character(hom.popm$CLAVE)
  #The municpalities in Oaxaca have changed since the CONAPO
  #released its population database, we have to merge them
  #by name. Hopefully their boundaries haven't changed much
  changed <- setdiff(hom$CLAVE, popm$Clave)
  hom.ch <- subset(hom, CLAVE %in% changed)
  hom.popm.ch <- merge(hom.ch, popm, by.x = c("County",
                                             "Year.of.Murder"),
                    by.y = c("County", "Year"))
  hom.popm.ch$CLAVE <- NULL
  hom.popm.ch$rate<- (hom.popm.ch$tot / hom.popm.ch$Population) *
                          100000
  hom.popm.ch$County.y <- hom.popm.ch$County
  names(hom.popm.ch)[1] <- "County.x"
  names(hom.popm.ch)[25] <- "CLAVE"
  hom.popm.ch$Code <- as.character(hom.popm.ch$CLAVE)
  rbind(hom.popm, hom.popm.ch)
}

ftext <- c(NA, NA, NA, NA, NA, NA)
mtext <- c(NA,
#1995
"1. Back in 1995 the southwest was the most violent area in Mexico.
Michoacan had a higher homicide rate in 1995 than in 2006
2. The Golden Triangle has always had a high homicide rate. Most
cartel leaders have come from Badiraguato (dark red). This has
probably been the most violent municipality over the last 20 years.",

#2000
"Violence has significantly decreased in the southwest. The urban
areas bordering the US are more violent.",

#2005
"1. The Sinaloa Cartel is battling the Gulf Cartel and the Zetas for
control of Nuevo Laredo. The fiercest fighting takes place in 2005
and the first half of 2006.
2. A mysterious new cartel preaching Muscular Christianity and
chopping heads off starts operating in Michoacan.",

#2006
"1. The Sinaloa Cartel fails to defeat the Zetas in Nuevo Laredo.
2. In the home state of the President of Mexico, Michoacan, a new
cartel called La Familia officially splinters off from the Zetas
sparking a surge in homicides. Starting December 11, soon after a
contentious election, the President sends in the army.",

#2007
"There seems to be some success in fighting La Familia in Michoacan
and the Beltran Leyvas in Guerrero. Although the number and violence
involved in executions has increased, Mexico has the lowest homicide
rate on record.",

#2008
"1. Arturo Beltran Leyva is captured. The remaining Beltran Leyvas
accuse the leader of the Sinaloa Cartel of tipping off the government,
sparking an inter-cartel war in Guerrero and Michoacan.
2. The Sinaloa Cartel starts a turf war to defeat the Juarez Cartel.
3. Eduardo Arellano Felix of the Tijuana Cartel is captured.")

#2009
"The war between the sinaloa and juarez cartels intensifies"

#2010
"Though it hasn't completly defeated the Juarez Cartel, the Sinaloa
Cartel is now firmly established in Juarez. Seeing the writing on the
wall the Gulf Cartel allies itself with the Sinaloa Cartel and La
Familia to take out the Zetas, sparking a surge in violence in Nuevo
León and Tamaulipas"

#2011?
"After having defeated the Zetas and the Juarez Cartel, the Sinaloa
Cartel goes after the only remaining cartel in Tijuana"
#Not needed after all. Easier in Inkscape
mtext <- c(NA, NA, NA, NA, NA, NA)

#For memory reasons these are global variables
#County map
mexico.ct.shp <- readShapePoly(map.inegi.ct,
                               IDvar = "CLAVE",
                               proj4string = CRS("+proj=aea"))
#State map
mexico.st.shp <- readShapePoly(map.inegi.st,
                               proj4string = CRS("+proj=aea"))

if(config$sex == "Female"){
  type <- "Mujer"
  config$titles.ch <- config$choropleths$ftitle.ch
  breaks <- c(0,5,10,Inf)
  maxh <- 17
  text <- ftext
} else {
  type <- "Total"
  config$titles.ch <- config$choropleths$mtitle.ch
  breaks <- c(0,10,20,40,60,80,Inf)
  maxh <- 100
  text <- mtext
}

#################################################################
#Read the files with the data and population, then merge them
################################################################
hom <- cleanHomicide("states/data/homicide-mun-2008.csv.bz2", type)
popm <- readPop(type)
hom.popm <- mergeHomPop(hom, popm)

########################################################
#Draw choropleths of Mexico
########################################################
mapply(savePlot, c(1990,1995,2000, 2005:2008), text,
       MoreArgs = list(breaks = breaks, df = hom.popm))
#draw.circle(0,0,100,col="#ffccff50")
#text(20,20,"1")


# カンマ区切りやタブ区切りテキストを扱うためのユーティリティ
install.packages('data.table')

# MySQL Connector
installed.packages('RMySQL')

# long format <-> wide format
install.packages('dplyr')
install.packages('tidyr')

# draw graph
install.packages('ggplot2')

# clustering
install.packages('cluster')

# 重回帰分析した結果の回帰係数のplot
install.packages('coefplot')

# 多変量連関図を描画する用
install.packages('GGally')

# 相関行列の表示用
install.packages('corrplot')

# ロジスティック回帰sample用のデータセット
install.packages('kernlab')

# C5.0アルゴリズム用のパッケージ
install.packages('C50')

# ROC曲線描画用
install.packages('pROC')


#' Tests if a numeric vector is completely consisting of integers
#'
#' This function can be used to distinguish e.g. dummy variables (only 0 and 1)
#' from other numeric columns. Applying to non numeric columns will fail. It also
#' allows for negative whole numbers and decimals with no rest e.g. 3.0, as this
#' can be a matter of print formatting rather of type
#'
#' @param x the vector to be tested, use `sapply(x, is.wholenumber)` for a data frame
#' @param tolerance numerical specifying the tolerance for rounding a value.
#'   defaults to `.Machine$double.eps^0.5` with `.Machine$double.eps` being
#'   the smallest positive floating-point number x such that 1 + x != 1
#'
#' @return A logical vector returning TRUE for column(s) that are completely integers
#'
#'
is.wholenumber <- function(x, tolerance = .Machine$double.eps^0.5)  {
  all(abs(x - round(x)) < tolerance)
}

#' Tests if a vector is a dummy column
#'
#' This function identifies specifically columns with dummy variables (only 0 and 1)
#' from all other column types. 1.0 as single value returns TRUE, which is a
#' matter of print formatting rather of type.
#'
#' @param x the vector to be tested, use `sapply(x, is.wholenumber)` for a data
#'   frame. Strict testing using 'vapply(x, FUN = is.dummy, FUN.VALUE = logical(1)`
#'
#' @return A logical vector returning TRUE for column(s) that only contain 0 and/or 1
#'
#'
is.dummy <- function(x) {
  all(sort(unique(x)) %in% c(0, 1)) == TRUE
}


library(ggplot2)

qplot(msg_lambda, data=s23, geom="histogram") + facet_grid(learning_rate ~ population_size)
qplot(log(autgroupsize), data=s23, geom="histogram") + facet_grid(learning_rate ~ population_size)
qplot(orbit_number, data=s23, geom="histogram") + facet_grid(learning_rate ~ population_size)

s2.bigspace866 <- subset(s2, size_trait_space == 447896)
qplot(msg_lambda, data=s2.bigspace866, geom="histogram") + facet_grid(learning_rate ~ .)
qplot(mem_beta, data=s2.bigspace866, geom="histogram") + facet_grid(learning_rate ~ .)
qplot(radius_frac, data=s2.bigspace866, geom="histogram") + facet_grid(learning_rate ~ .)

s2.smallspace433 <- subset(s2, size_trait_space == 160)
qplot(msg_lambda, data=s2.smallspace433, geom="histogram") + facet_grid(learning_rate ~ .)
qplot(mem_beta, data=s2.smallspace433, geom="histogram") + facet_grid(learning_rate ~ .)

# seems like no real dependence of msg_lamba on convergence time,
# but weak differentiation of histograms by learning rate
qplot(convergence_time, msg_lambda, data=s2, geom="point") + facet_grid(learning_rate ~ .)
qplot(msg_lambda, data=s2, geom="histogram") + facet_grid(learning_rate ~ .)


library(reshape2)
library(ggplot2)
library(viridis)
library(dplyr)

# Load data
clades <- read.csv("year_data.csv", na.strings = 0)
clades[is.na(clades)] <- 0

# Convert to long format
longClades <- melt(clades, id = c("year"))

ggplot(data = longClades, aes(x=year, y=value, color=variable, fill=variable))+
  #geom_smooth(se = FALSE)
  geom_line(size=1.5)

ggplot(data = longClades, aes(x=year, y=value, color=variable, fill=variable, ymin=0, ymax=value, alpha=0.7))+
  geom_ribbon() +
  geom_line()

ggplot(data = longClades, aes(x=year, y=value, color=variable, fill=variable))+
  geom_area()

#normalize
normClades <- clades/rowSums(clades[2:11])
normClades[1] <- clades[1]
normLongClades <- melt(normClades, id = c("year"))

############
# Figure 2 #
############
tiff('figure2.tiff', units="in", width=13.5, height=6.75, res=300, compression = 'lzw')

ggplot(data = normLongClades, aes(x=year, y=value, color=variable, fill=variable))+
  geom_area(alpha=1, size=.5, colour="white") +
  scale_fill_viridis(discrete = T, option="inferno", name="HA-NA clade pair") +
  labs(y = "Percent of N2 detection", x = "Year", color="test") +
  scale_x_continuous(limits = c(2009,2018), expand = c(0, 0.2)) +
  scale_y_continuous(limits = c(0,1), expand = c(0, 0)) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        axis.title = element_text(size=12,face="bold"),
        axis.text = element_text(size=11,face="bold"),
        axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5),
        legend.title = element_text(size=12,),
        legend.text = element_text(size=12),
  )

dev.off()

########################
###State based Graphs###
########################
states <- read.csv("state_data.csv")

#Drop out clades not in top 10
topClades <- list("H1.delta1b-N2.2002A","H3.cluster_iva-N2.2002B","H1.delta1a-N2.2002B","H1.delta2-N2.1998B","H3.cluster_ivb-N2.2002B","H1.delta1a-N2.2002A","H3.2010.1-N2.2002B","H3.cluster_iva-N2.2002A","H3.2010.1-N2.2002A","H1.alpha-N2.2002B")
topStates <- list("Iowa","Illinois","North Carolina","Minnesota","Indiana","Nebraska")
states <-states [states$merged_clade %in% topClades,]
states <-states [states$State.Province %in% topStates,]

#State facet
stateList <- dcast(states, State.Province + collection_date ~ merged_clade)
stateItem <- melt(stateList, id = c("collection_date","State.Province"))

ggplot(data = stateItem, aes(x=collection_date, y=value, color=variable, fill=variable))+
  geom_area(alpha=1, size=.5, colour="white") +
  scale_fill_viridis(discrete = T, option="inferno", name="HA-NA clade pair") +
  labs(y = "Percent of N2 detection", x = "Year", color="test") +
  #scale_x_continuous(limits = c(2009,2018), expand = c(0, 0.2)) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        axis.title = element_text(size=12,face="bold"),
        axis.text = element_text(size=11,face="bold"),
        axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5),
        legend.title = element_text(size=12,),
        legend.text = element_text(size=12),
  ) +
  facet_wrap(~State.Province, ncol = 2)

ggplot(data = stateItem, aes(x=collection_date, y=value, color=variable, fill=variable))+
  geom_line(size = 1.5) +
  scale_fill_viridis(discrete = T, option="inferno", name="HA-NA clade pair") +
  labs(y = "Percent of N2 detection", x = "Year", color="test") +
  #scale_x_continuous(limits = c(2009,2018), expand = c(0, 0.2)) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        axis.title = element_text(size=12,face="bold"),
        axis.text = element_text(size=11,face="bold"),
        axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5),
        legend.title = element_text(size=12,),
        legend.text = element_text(size=12),
  ) +
  facet_wrap(~State.Province, ncol = 2)

data <- stateItem  %>%
  group_by(State.Province, collection_date, variable) %>%
  summarise(n = sum(value)) %>%
  mutate(percentage = n / sum(n))

#############
# Figure S2 #
#############
tiff('figures2.tiff', units="in", width=13.5, height=10, res=300, compression = 'lzw')

ggplot(data = data, aes(x=collection_date, y=percentage, color=variable, fill=variable))+
  geom_area(alpha=1, size=.5, colour="white") +
  scale_fill_viridis(discrete = T, option="inferno", name="HA-NA clade pair") +
  labs(y = "Percent of N2 detection", x = "Year", color="test") +
  #scale_x_continuous(limits = c(2009,2018), expand = c(0, 0.2)) +
  theme(legend.position = "bottom",
        panel.background = element_rect(fill = "white"),
        axis.title = element_text(size=12,face="bold"),
        axis.text = element_text(size=11,face="bold"),
        axis.text.x = element_text(angle = 90, hjust = 1, vjust=0.5),
        legend.title = element_text(size=12,),
        legend.text = element_text(size=12),
  ) +
  facet_wrap(~State.Province, ncol = 2)

dev.off()


[1, 0 -> 1 (10)]
[2, 1 -> 2 (3)]
[3, 2 -> 3 (2)]
[5, 2 -> 5 (8)]
[6, 5 -> 6 (6)]
[7, 5 -> 7 (9)]
[4, 1 -> 4 (0)]


4 -> 3: 1 -> 4
3 -> 5: 4 -> 3
5 -> 1: 3 -> 5
1 -> 2: 5 -> 1
2 -> 3: 1 -> 2
3 -> 1: 2 -> 3