#  James Rekow

changePointComputer = function(x){

  #  ARGS: x - numerical vector
  #
  #  RETURNS: the index of the last nonnegative value of x

  n = length(x)
  changePoint = n

  #  check if x has a positive length
  posLength = n > 0

  #  return NULL if input does not have positive length
  if(!identical(posLength, TRUE)){
    return(NULL)
  } #  end if

  #note that this is different than in the reference paper for DOC analysis
  #in the paper they use <0 (strict) but this leads to problems b/c the last points
  #often have first deriv 0 even in downward sloping smoothed lowess curves

  #  compute the greatest index (changePoint) such that all elements of x with index greater
  #  than the changePoint are negative
  while(x[changePoint] <= 0){

    changePoint = changePoint - 1

    #  break out of loop if changePoint reaches 0
    #  this occurs if the entire DOC curve has a negative slope
    if(changePoint == 0){
      break
    } #  end if

  } #  end while

  #  add 1 to changePoint if it's less than n, because the current value of changePoint
  #  is the maximal index of elements in x that are less than changePoint
  if(changePoint < n){
    changePoint = changePoint + 1
  } #  end if

  return(changePoint)

} #  end changePointComputer function


# required libs
library(shiny)
library(C3)
library(shinyBS)

# FRISS header
FrissHeader <- list(
  singleton(includeScript("www/d3.js")),
  tags$a(href = "http://www.friss.eu/en",
         tags$img(src="friss.svg", id = "FrissLogo")
  ),
  singleton(includeCSS("www/friss.css")),
  singleton(includeScript("www/style.js")),
  singleton(includeCSS("www/app.css"))
)

# helper function to create some fake data: random walk with drift
# see http://stackoverflow.com/questions/24272862/generate-random-walk-with-drift-and-or-trend-in-r

getSeries <- function( n = 100, drift = 0.1, walk = 4, scale = 100){
  y <- scale * cumsum(rnorm(n= n, mean = drift, sd=sqrt(walk)))
  y <- round(y)
  return(y + abs(min(y)))
}


require(ggplot2)
scatter_ggplot <- function(data, X, Y, label_x, label_y)
{
  p2<- (
    # scatter plot main data
    # the data need to be in dataframe format. x and y can refer directly to the variables
    ggplot(data, aes(x=X, y=Y))
    # dot size, color and shape etc.
    + geom_point(shape=19, size = 1, colour="grey50")
    # 95% confidence interval and regression line
    + geom_smooth(method=lm, colour="black", size = 1, fullrange = TRUE)
    # title and axis lable
    # + ggtitle("Blob")
    + xlab(label_x)
    + ylab(label_y)
    # limits of the axises
    + xlim(-4, 4)
    + ylim(-2.5, 2.5)

  )

  # add APA format theme
  p2 + theme_classic() +theme(
    text = element_text(size=18),
    axis.line.x = element_line(colour = "black"),
    axis.line.y = element_line(colour = "black")
  )
}


# Casino winnings from Monday to Friday
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Poker results of Wednesday: poker_wednesday
poker_wednesday <- poker_vector[3]

print(poker_wednesday)

# Roulette results of Friday: roulette_friday
roulette_friday <- roulette_vector[5]
print(roulette_friday)

# Mid-week poker results: poker_midweek
poker_midweek <- poker_vector[c(2,3,4)]
print(poker_midweek)

# End-of-week roulette results: roulette_endweek
roulette_endweek <- roulette_vector[c(4,5)]
print(roulette_endweek)

# Roulette results for Tuesday to Friday inclusive: colon operator
roulette_subset <- roulette_vector[2:5]
print(roulette_subset)

#Accessing by Names
# Select Thursday's roulette gains: roulette_thursday
roulette_thursday <- roulette_vector["Thursday"]
print(roulette_thursday)

# Select Tuesday's poker gains: poker_tuesday
poker_tuesday <- poker_vector["Tuesday"]
print(poker_tuesday)

# Select the first three elements from poker_vector: poker_start
poker_start <- poker_vector[c("Monday","Tuesday","Wednesday")]

# Calculate the average poker gains during the first three days: avg_poker_start
avg_poker_start <- mean(poker_vector[1:3])

# Roulette results for day 1, 3 and 5: roulette_subset
roulette_subset <- roulette_vector[c("Monday","Wednesday","Friday")]

# Poker results for first three days: poker_start Logical subsets
poker_start <- poker_vector[c(TRUE, TRUE, TRUE, FALSE, FALSE)]

print(poker_start)

# Create logical vector corresponding to profitable poker days: selection_vector
selection_vector <- poker_vector >0
print(selection_vector)

# Select amounts for profitable poker days: poker_profits
poker_profits <- poker_vector[selection_vector]
print(poker_profits)

# Select amounts for profitable roulette days: roulette_profits
#roulette_vector > 0 is a selection vector
roulette_profits <- roulette_vector[roulette_vector >0]
print(roulette_profits)

# Sum of the profitable roulette days: roulette_total_profit
roulette_total_profit <- sum(roulette_profits)
print(roulette_total_profit)

# Number of profitable roulette days: num_profitable_days
#sum of the logical vector counts the number of TRUE values and returns the total number
num_profitable_days <- sum(roulette_vector > 0)
print(num_profitable_days)


#localH2O = h2o.init(); demo(h2o.glm)
# http://h2o.ai/
# http://learn.h2o.ai/content/hands-on_training/deep_learning.html

# Start H2O and load the MNIST data
#h2o.shutdown(h2oServer)
h2oServer <- h2o.init(nthreads=-1)

h2o.clusterStatus(h2oServer)

TRAIN = "train.csv"
TEST = "test.csv"
train_hex <- h2o.importFile(h2oServer, path = paste0(input.data.dir,"mnist/",TRAIN), header = F, sep = ',' )
test_hex <- h2o.importFile(h2oServer, path = paste0(input.data.dir,"mnist/",TEST), header = F, sep = ',' )

dlmodel <- h2o.deeplearning(x=1:784, y=785, data=train_hex, validation=test_hex,hidden=c(50,50), epochs=0.1, activation="Tanh")

dlmodel
dlmodel@model$confusion
dlmodel@model$valid_class_error

# confirm that the reported confusion matrix
pred_labels <- h2o.predict(dlmodel, test_hex)[,1]
actual_labels <- test_hex[,785]
cm <- h2o.confusionMatrix(pred_labels, actual_labels)
cm
dlmodel@model$confusion
dlmodel@model$confusion == cm

dlmodel@model$params

# Hyper-parameter Tuning with Grid Search

grid_search <- h2o.deeplearning(x=c(1:784),
                                y=785,
                                training_frame=train_hex,
                                validation_frame=test_hex,
                                hidden=list(c(10,10),c(20,20)),
                                epochs=0.1,
                                activation=c("Tanh", "Rectifier"),
                                l1=c(0,1e-5))

grid_search

best_model <- grid_search@model[[1]]
best_model
best_params <- best_model@model$params
best_params$activation
best_params$hidden
best_params$l1

# Hyper-parameter Tuning with Random Search

models <- c()
for (i in 1:10) {
  rand_activation <- c("TanhWithDropout", "RectifierWithDropout")[sample(1:2,1)]
  rand_numlayers <- sample(2:5,1)
  rand_hidden <- c(sample(10:50,rand_numlayers,T))
  rand_l1 <- runif(1, 0, 1e-3)
  rand_l2 <- runif(1, 0, 1e-3)
  rand_dropout <- c(runif(rand_numlayers, 0, 0.6))
  rand_input_dropout <- runif(1, 0, 0.5)
  dlmodel <- h2o.deeplearning(x=1:784, y=785,
                              data=train_hex,
                              validation=test_hex,
                              epochs=0.1,
                              activation=rand_activation,
                              hidden=rand_hidden,
                              l1=rand_l1,
                              l2=rand_l2,
                              input_dropout_ratio=rand_input_dropout,
                              hidden_dropout_ratios=rand_dropout)
  models <- c(models, dlmodel)
}

#  find the model with the lowest validation error
best_err <- best_model@model$valid_class_error #best model from grid search above
for (i in 1:length(models)) {
  err <- models[[i]]@model$valid_class_error
  if (err < best_err) {
    best_err <- err
    best_model <- models[[i]]
  }
}

best_model
best_params <- best_model@model$params
best_params$activation
best_params$hidden
best_params$l1
best_params$l2
best_params$input_dropout_ratio
best_params$hidden_dropout_ratios

# continue training the best model, for 2 more epochs.
dlmodel_continued <- h2o.deeplearning(x=c(1:784), y=785, data=train_hex, validation=test_hex,
                                      checkpoint = best_model, l1=best_params$l1, l2=best_params$l2, epochs=0.5)

dlmodel_continued@model$valid_class_error

h2o.saveModel(dlmodel_continued, dir=paste0(output.data.dir, "saved-models/"), name="mybest_mnist_model", force=T)


#name: survivalPlot
#language: r
#input: string inputStrata = '1'
#input: string confInt = 0.95
#input: dataframe survivalDf
#output: graphics plot
#output: dataframe diagnostics

require("ggfortify")
require("survival")
require("ggplot2")

diagnostics = as.data.frame(installed.packages()[,c(1,3:4)])

if (inputStrata == '') {
  inputStrata = '1'
}

modform <- as.formula(paste("Surv(time, status)", inputStrata, sep = " ~ "))

km_trt_fit <- survfit(modform, data=survivalDf, conf.int = as.numeric(confInt))

autoplot(km_trt_fit) +
  theme_bw()


library(hdfmat)

f = tempfile()
n = "mydata"
type = "double"

nr = 10
nc = 3
x = matrix(1:(nr*nc), nr, nc)
storage.mode(x) = type

h = tcrossprod_ooc(x, f, name=n)

test = h$read()
truth = tcrossprod(x)

stopifnot(all.equal(test, truth))

h$close()
unlink(f)


rm(list=ls())

file_entire_collection  <- commandArgs()[4]
file_perbatch <- commandArgs()[5]

# FDR index indexes a 0-based array at [10e-1, 10e-2, ...]
# => actual threshold = 10e-(index+1)
FDR_index_remove_variants  <- as.integer(commandArgs()[6]) + 1

# ------------------------------------------- #
# -- SNP QCI: HWE across entire collection -- #
# ------------------------------------------- #

fdr.hwe.allbatches  <- read.table(file=paste(file_entire_collection, sep=""), header=T)

fdr  <- -log10(fdr.hwe.allbatches$FDR)
pval <- -log10(fdr.hwe.allbatches$HWE_pval_worstbatchremoved)

png(file=paste(file_entire_collection, ".png", sep=""), width=720, height=720)

plot(fdr, fdr.hwe.allbatches$Fail_worstbatchremoved/1000, xlim=c(1,10), ylim=c(0,40), xlab="-log10(FDR threshold)", ylab="# SNPs failed (x 1,000)", pch=17, col="black", type="b", xaxt="n", cex=1.5)
lines(fdr, fdr.hwe.allbatches$Fail_allbatches/1000, type="b", pch=20, col="black", cex=1.5)
axis(1, at=seq(1,10,by=1), labels=fdr)
axis(3, at=seq(1,10,by=1), labels=round(pval, digits=1), xlab="")
mtext("-log10(p-value threshold)", side=3, line=2.5)
legend("topright", legend=c("All batches","Worst batch removed"), pch=c(20,17), col=c("black","black"), text.col=rep("black", 2), bty="y", inset=.05, cex=1.5)

# FDR threshold
lines(x=c(FDR_index_remove_variants,FDR_index_remove_variants), y=c(0,25), lty=2, col="red")
text(fdr[FDR_index_remove_variants], fdr.hwe.allbatches$Fail_allbatches[FDR_index_remove_variants]/1000, labels=c(fdr.hwe.allbatches$Fail_allbatches[FDR_index_remove_variants]/1000), pos=4)

dev.off()

# --------------------------------- #
# -- SNP QCI: HWE for each batch -- #
# --------------------------------- #

fdr.hwe.perbatch    <- read.table(file=paste(file_perbatch, sep=""), header=T)

fdr  <- -log10(fdr.hwe.perbatch$FDR)

png(file=paste(file_perbatch, ".png", sep=""), width=720, height=720)

plot(fdr, fdr.hwe.perbatch$Fail_2plusbatches/1000, xlim=c(1,10), ylim=c(0,25), xlab="-log10(FDR threshold)", ylab="# SNPs failed (x 1,000)", pch=17, col="black", type="b", xaxt="n", cex=1.5)
axis(1, at=seq(1,10,by=1), labels=fdr)
legend("topright", legend=c("Fail in 2+ batches"), pch=c(17), col=c("black"), text.col=rep("black"), bty="y", inset=.05, cex=1.5)
mtext("corresponding -log(p-values thresholds) different for any batch", side=3, line=1.5)

# FDR threshold
lines(x=c(FDR_index_remove_variants,FDR_index_remove_variants), y=c(0,25), lty=2, col="red")
text(fdr[FDR_index_remove_variants], fdr.hwe.perbatch$Fail_2plusbatches[FDR_index_remove_variants]/1000, labels=c(fdr.hwe.perbatch$Fail_2plusbatches[FDR_index_remove_variants]/1000), pos=4)

dev.off()


## firescar with mortality

library(compiler)

## Function, compatible with parallell backend, to launch simulation with defined parameters and save results.
launch_sim=function(idx){
  print(idx)
  dim(sim_def_frame)
  this_sim=sim_def_frame[idx,]

  output=scar_sim(this_sim$SIM_ID,this_sim$FIELD_SIZE,this_sim$SIM_LENGTH,this_sim$FIRE_FREQ,this_sim$FIRE_PROB,this_sim$MORTALITY_ON,this_sim$F_MORTALITY_ON,
                  this_sim$MORT_b1,this_sim$MORT_b2,this_sim$MORT_p1,this_sim$MORT_p2,this_sim$MORT_p3,
                  this_sim$MORT_F_b1, this_sim$MORT_F_b2,this_sim$MORT_F_b3, this_sim$MORT_F_p1,this_sim$MORT_F_p2,this_sim$MORT_F_p3, this_sim$MORT_F_p4)
  write.csv(output$tree_frame,paste0(this_sim$output_dir,"/tree_frame_",idx,".csv"))
  this_fire=output$fire_record
  save(this_fire,file=paste0(this_sim$output_dir,"/fire_record_",idx,".Rdata"))
  this_veg_matrix=output$veg_matrix
  save(this_veg_matrix,file=paste0(this_sim$output_dir,"/veg_matrix_",idx,".Rdata"))
}

scar_sim=function(SIM_ID,FIELD_SIZE,SIM_LENGTH,FIRE_FREQ,FIRE_PROB,MORTALITY_ON,F_MORTALITY_ON,
                  MORT_b1,MORT_b2,MORT_p1,MORT_p2, MORT_p3,
                  MORT_F_b1,MORT_F_b2,MORT_F_b3,MORT_F_p1,MORT_F_p2,MORT_F_p3,MORT_F_p4){
  veg_matrix=matrix(0,nrow=FIELD_SIZE,ncol=FIELD_SIZE) # Stores current age of trees
  dead_veg_matrix=matrix(0,nrow=FIELD_SIZE,ncol=FIELD_SIZE) # Stores age of trees at death for dead records
  year_of_death_matrix=matrix(0,nrow=FIELD_SIZE,ncol=FIELD_SIZE) # Stores year dead record trees died
  fire_matrix=matrix(5,nrow=FIELD_SIZE,ncol=FIELD_SIZE) # Stores time since last fire - initialized to 5

  storage_matrix=rep(0,FIELD_SIZE*FIELD_SIZE*SIM_LENGTH) # Stores history of scars
  dim(storage_matrix)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)

  fire_boundary_matrix=rep(0,FIELD_SIZE*FIELD_SIZE*SIM_LENGTH) # Stores history of actual fire areas
  dim(fire_boundary_matrix)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)

  dead_tree_matrix=rep(0,FIELD_SIZE*FIELD_SIZE*SIM_LENGTH) # Dead trees are moved here until another fire comes to destory snag
  dim(dead_tree_matrix)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)

  to_die_block=rep(0,FIELD_SIZE*FIELD_SIZE*SIM_LENGTH)
  dim(to_die_block)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)

  demo_hist=matrix(0,ncol=100,nrow=SIM_LENGTH)

  # Constant for number of cells
  COUNT_TREES=length(veg_matrix)

  # Quadratic helper function
  #  quad=function(a,b,c,x){a*x^2+b*x+c}
  #  qq=function(x){2.50e-07*(x^2) -1.25e-04*x + 2.00e-02}
  # Distribution function for tree age
  # Returns a vector of length x with tree ages from a gamma distribution
  TREE_DIST=function(x){round(rgamma(x,6,.021))+1}

  # Probability function - give a vector containing tree ages
  # It will return whether a burn scar was recorded
  # It's currently a logistic curve with a steep transition around age=5
  # So trees younger than 5 years don't record scar (eg. killed)
  #BURN_SCAR_TSF=function(x){runif(x,0,1)<plogis(x,5,.3)}
  BURN_SCAR_TSF=function(x){runif(x,0,1)<plogis(x,20.7,9.5)*0.75}

  # Function of tree mortality at a given age, independent of fire

  if(MORTALITY_ON){
    #MORTALITY = function(x){runif(x,0,1)<plogis(x,350,35)*.01+0.01} #Logistic curve
    MORTALITY=function(x){
      x[x<MORT_b1]=MORT_p1
      x[x>= MORT_b1 & x <MORT_b2]=MORT_p2
      x[x>=MORT_b2]=MORT_p3
      runif(x,0,1)<x
    }
  }else{
    MORTALITY = function(x){x<0} # Fast way to return a false matrix/vector irregardless of dimension
  }

  # Function of tree mortality at a given age, due to fire
  #MORTALITY_F = function(x){runif(x,0,1)<(1-plogis(x,30,10))}
  #MORTALITY_F = function(x){runif(x,0,1)<(1-plogis(x,30,10)*.8-0.15)}
  if(F_MORTALITY_ON){
    #MORTALITY_F = function(x){runif(x,0,1)<(1-plogis(x,30,10)*.8-0.199)}
    MORTALITY_F=function(x){
      x[x<MORT_F_b1]=MORT_F_p1
      x[x>= MORT_F_b1 & x <MORT_F_b2]=MORT_F_p2
      x[x>= MORT_F_b2 & x <MORT_F_b3]=MORT_F_p3
      x[x>=MORT_F_b3]=MORT_F_p4
      runif(x,0,1)<x
    }
  }else{
    MORTALITY_F = function(x){x<0} # Fast way to return a false matrix/vector irregardless of dimension
  }
  # Probability of a tree without a scar forming an initial scar and starting recording
  INITIAL_SCAR_P = 0.08

  # Initialize the veg matrix with gamma distribution of tree age
  veg_matrix[1:COUNT_TREES]=TREE_DIST(COUNT_TREES)

  # utility function to determine if any drill of the 3D matrix has a scar
  is_one=function(x){sum(x)>1}

  # Function to generate a rectangular burn at random location
  # It then feeds this burn to the burn scar function
  # Based on the age of trees in that burn area it returns
  # A matrix showing which trees a scar was recorded on
  # The fire matrix (time since fire) is updated and set to zero where
  # the burn occured
  burn_veg=function(){
    x=veg_matrix                            # Complete matrix of vegetation age
    y=fire_matrix                           # Complete matrix of time since fire

    prob_burn_field=matrix(runif(COUNT_TREES,0,1)<(FIRE_PROB/100),nrow=FIELD_SIZE,ncol=FIELD_SIZE) #Fire pixels as logic to allow use as cell selector

    scar_map=x                              # Create a copy of the matrix to store the scar map
    fire_map=x                              # Create a copy of the matrix to store the total fire
    scar_map[1:COUNT_TREES]=FALSE           # Set all values of the scar map to false
    fire_map[1:COUNT_TREES]=0               # Set all values of the fire map to false

    this_fire=y[prob_burn_field]        # this_fire contains the matrix subset burnt by the fire of time since burnt
    this_scar=BURN_SCAR_TSF(this_fire)      # For each cell in this, test if they are actually burnt, store in this_scar
    this_any_scar=any_scar[prob_burn_field]  # Grab subset of any_scar to combine with new scar formation

    this_scar=this_scar * this_any_scar          # only allow trees that are "1" in any_scar to form a scar, set rest to zero

    scar_map[prob_burn_field]=this_scar # Put this back in the scar map
    fire_map[prob_burn_field]=1         # Save a mask of the complete fire
    y[prob_burn_field]=0                # For area within the fire boundary, set time since fire to 0
    fire_matrix<<-y                         # Write this updated fire matrix to global variable

    ### Do vegetation mortality due to fire
    rec_veg=x                               # Make a copy of the vegetation age
    this_veg=rec_veg[prob_burn_field]   # Grab a subset where the fire burnt
    trees_to_die=MORTALITY_F(this_veg)      # Make a logical subset matrix to show which trees were killed by fire
    rec_veg[1:COUNT_TREES]=FALSE                # Blank out the overall veg age copy matrix
    rec_veg[prob_burn_field] = trees_to_die   # Put in just the trees that have just been killed, so their record can be wiped

    list(scar_map=scar_map,fire_map=fire_map,to_die=rec_veg)
  }

  # Run simulation for given number of years
  for(idx in 1:SIM_LENGTH){

    any_scar=apply(storage_matrix,MARGIN=c(1,2),FUN=is_one)  # Create a matrix showing if tree has ANY scar already
    new_scar_probability=matrix(sample(c(0,1),COUNT_TREES,replace=TRUE,prob=c(1-INITIAL_SCAR_P,INITIAL_SCAR_P)),nrow=FIELD_SIZE,ncol=FIELD_SIZE) # Probability of recording tree activating
    any_scar = matrix(as.numeric(any_scar | new_scar_probability),nrow=FIELD_SIZE,ncol=FIELD_SIZE)  # Combine this probability with existing scars to produce matrix of trees capable of being scarred
    fire_matrix=fire_matrix+1 # Age the time since fire by 1 year
    veg_matrix=veg_matrix+1 # Age the vegetation by 1 year

    # If it's a "fire year", burn an area
    if(runif(1,0,1) < FIRE_FREQ/100){

      old_tsf=fire_matrix
      burn_it = burn_veg()             # Burn function
      to_die_fire = burn_it$to_die     # Read out the trees to die in the fire
      total_fire_map=burn_it$fire_map

      # Erase the records from the dead_tree_matrix that were just burnt
      inverse_fire_map=!total_fire_map
      inverse_fire_store=rep(inverse_fire_map,SIM_LENGTH)
      dim(inverse_fire_store)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)  # Make it 3D

      # Keep tree with probability base on time since fire
      inverse_fire_keepsome = inverse_fire_map | BURN_SCAR_TSF(old_tsf)
      inverse_fire_keepsome_store=rep(inverse_fire_keepsome,SIM_LENGTH)
      dim(inverse_fire_keepsome_store)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)

      dead_tree_matrix=dead_tree_matrix*inverse_fire_keepsome_store  # Wipe fire scare area in dead tree store
      dead_veg_matrix = dead_veg_matrix*inverse_fire_keepsome  #Set tree age to zero in dead veg matrix
      year_of_death_matrix = year_of_death_matrix*inverse_fire_keepsome # Set year burnt to zero in year died matrix

      storage_matrix[,,idx] = burn_it$scar_map # Store the burn matrix in a 3D matrix - do this now so we get the scar coincident with death

      fire_boundary_matrix[,,idx] = total_fire_map # Store the actual fire matrix in 3D matrix

    } else{
      to_die_fire = veg_matrix              # If there's no fire, we still need a
      to_die_fire[1:COUNT_TREES] = FALSE    # blank died-in-fire matrix
    }
    # Natural mortality
    to_die_naturally = MORTALITY(veg_matrix)        # Natural mortality matrix based on age probability
    #fire_matrix[to_die_naturally]=0                 # If they're dead, there's also no "time since fire"??
    to_die_total = to_die_fire | to_die_naturally    # Trees killed by fire OR natrually

    # the slow way! Copy dead tree records into the dead tree store
    for(x in 1:FIELD_SIZE){
      for(y in 1:FIELD_SIZE){
        if(to_die_total[x,y]==1){
          dead_tree_matrix[x,y,]=storage_matrix[x,y,]
          dead_veg_matrix[x,y]=veg_matrix[x,y]
          year_of_death_matrix[x,y]=idx
        }
      }
    }

    veg_matrix[to_die_total]=0                  # Kill them (again, reset to zero)

    to_die_total= 1-to_die_total                # Make it multipliable eg. x0 = dead, x1 = alive
    to_die_block=rep(to_die_total,SIM_LENGTH)    # Repeat that dead tree multiplier throughout storage matrix
    dim(to_die_block)=c(FIELD_SIZE,FIELD_SIZE,SIM_LENGTH)  # Make it 3D
    storage_matrix=storage_matrix*to_die_block        # Update storage matrix with new dead tree holes
    #demo_hist[idx,]=hist(veg_matrix,breaks=seq(0,SIM_LENGTH,SIM_LENGTH/100),plot=FALSE)$counts # Save a row in the demographic histogram
  }

  # Plot of how many burn scars were recorded
  scar_count=apply(storage_matrix,MARGIN=c(1,2),FUN=sum)
  #image(scar_count)

  dead_scar_count=apply(dead_tree_matrix,MARGIN=c(1,2),FUN=sum)
  #image(dead_scar_count)

  total_count=apply(fire_boundary_matrix,MARGIN=c(1,2),FUN=sum)
  #image(total_count)

  # Put all the still living - note, need a different method if mortality is turned off

  tree_frame=data.frame(ID=0,X=0,Y=0,YBP=0,STATUS=0,START_YEAR=0,END_YEAR=0)
  ID=0

  for(x in 1:FIELD_SIZE){

    for(y in 1:FIELD_SIZE){
      if(scar_count[x,y]>=1){
        ID=ID+1
        this_age=veg_matrix[x,y]
        if(this_age > SIM_LENGTH){
          this_age=SIM_LENGTH       # Just get rid of records past length of simulation
        }
        this_scarvec=storage_matrix[x,y,((SIM_LENGTH-this_age)+1):(SIM_LENGTH)]
        born=SIM_LENGTH - this_age
        this_age_vec=(born+1):SIM_LENGTH
        this_frame=data.frame(ID=rep(ID,this_age),X=rep(x,this_age),Y=rep(y,this_age),SCAR=this_scarvec,YBP=this_age_vec,STATUS=rep(0,this_age),START_YEAR=rep(born,this_age),END_YEAR=rep(SIM_LENGTH,this_age))
        this_frame=subset(this_frame,this_frame$SCAR==1,select=c("ID","X","Y","YBP","STATUS","START_YEAR","END_YEAR"))
        tree_frame=rbind(tree_frame,this_frame)
      }
    }
  }

  tree_frame=subset(tree_frame,ID!=0)
  if(MORTALITY_ON){
    for(x in 1:FIELD_SIZE){

      for(y in 1:FIELD_SIZE){
        if(dead_scar_count[x,y]>=1){
          ID=ID+1
          this_age=dead_veg_matrix[x,y]
          this_year_died=year_of_death_matrix[x,y]
          born=this_year_died - this_age
          if(born < 1){
            born=0

          }
          this_scarvec=dead_tree_matrix[x,y,((born)+1):(this_year_died)]
          this_age_vec=(born+1):this_year_died
          vec_length=length(this_age_vec)
          this_frame=data.frame(ID=rep(ID,vec_length),X=rep(x,vec_length),Y=rep(y,vec_length),SCAR=this_scarvec,YBP=this_age_vec,STATUS=rep(1,vec_length),START_YEAR=rep(born,vec_length),END_YEAR=rep(this_year_died,vec_length))
          this_frame=subset(this_frame,this_frame$SCAR==1,select=c("ID","X","Y","YBP","STATUS","START_YEAR","END_YEAR"))
          tree_frame=rbind(tree_frame,this_frame)
        }
      }
    }
  }

  # Add some extra useful columns to the frame
  tree_frame$AGE=tree_frame$END_YEAR-tree_frame$START_YEAR

  tree_frame$SIM_ID = SIM_ID
  tree_frame$MORT_b1 = MORT_b1
  tree_frame$MORT_b2 = MORT_b2
  tree_frame$MORT_p1 = MORT_p1
  tree_frame$MORT_p2 = MORT_p2
  tree_frame$MORT_p3 = MORT_p2
  tree_frame$MORT_F_b1 = MORT_F_b1
  tree_frame$MORT_F_b2 = MORT_F_b2
  tree_frame$MORT_F_b3 = MORT_F_b3
  tree_frame$MORT_F_p1 = MORT_F_p1
  tree_frame$MORT_F_p2 = MORT_F_p2
  tree_frame$MORT_F_p3 = MORT_F_p3
  tree_frame$MORT_F_p4 = MORT_F_p4
  tree_frame$FIELD_SIZE=FIELD_SIZE
  tree_frame$SIM_LENGTH=SIM_LENGTH
  tree_frame$FIRE_FREQ=FIRE_FREQ
  tree_frame$FIRE_PROB=FIRE_PROB
  tree_frame$MORTALITY_ON=MORTALITY_ON
  tree_frame$F_MORTALITY_ON=F_MORTALITY_ON

  # Return all the output defining this model
  list(tree_frame=tree_frame,
       fire_record=fire_boundary_matrix,
       veg_matrix=veg_matrix)
}

plot_dendro=function(tree_frame){

  sim_end=max(tree_frame$END_YEAR)

  tree_frame$START_YEAR = -(sim_end-tree_frame$START_YEAR)
  tree_frame$END_YEAR = -(sim_end-tree_frame$END_YEAR)
  tree_frame$YBP = -(sim_end-tree_frame$YBP)

  number_of_trees=length(unique(tree_frame$ID))
  plot.new()
  plot.window(xlim=c(-sim_end,0),ylim=c(0,number_of_trees))
  for(idx in 1:number_of_trees){
    this_tree=subset(tree_frame,ID==idx)
    first_scar=min(this_tree$YBP)
    if(this_tree$STATUS[1]==0){
      col_vec=c("grey","black")
    }else{
      col_vec=c("pink","red")
    }
    lines(c(this_tree$START_YEAR[1],first_scar),c(idx,idx),col=col_vec[1])
    lines(c(first_scar,this_tree$END_YEAR[1]),c(idx,idx),col=col_vec[2])
    points(this_tree$YBP,rep(idx,length(this_tree$YBP)),pch="|",col=col_vec[2],cex=0.5)
  }
  axis(1)
}

scar_sim=cmpfun(scar_sim)
plot_dendro=cmpfun(plot_dendro)


f <- function(f0) f0(pi) # calc. the function in pi
tf <- function(x) x^pi   # a func. just to test

print(f(sin))
print(f(cos))
print(f(tf))


# get the clean RNA-seq table
load("data/tiyani_pup_vs_ys.Rdata")
library(ALDEx2)
library(zCompositions)
library(CoDaSeq)
null.set.ty.effect <- lapply(null.set.ty.effect <- vector(mode = 'list',9), function(x) x <- vector(mode='list',100))
null.set.ty.single.effect <- lapply(null.set.ty.effect <- vector(mode = 'list',9), function(x) x <- vector(mode='list',100))

seq.test <- c(2,3,5,10,15,20,30,50,100)

for(i in 1:9){
    for(j in 1:100){
    print(c(i,j))
        # subset d.good by random sampling
        d.samp <- cbind(sample(d[,162:373], seq.test[i]*2))

        conds.i <- c(rep("C", seq.test[i]), rep("E", seq.test[i]))

        # test the actual data
        d.sample <- d.samp[rowSums(d.samp) > 0,]
        d.s.n0 <- cmultRepl(t(d.sample), method="CZM", label=0)
        d.s.clr <- apply(d.s.n0, 1, function(x) log(x) - mean(log(x)))
        null.actual <- codaSeq.effect(d.s.clr, conds.i)
        null.set.ty.single.effect[[i]][[j]] <- null.actual

        x <- aldex.clr(d.sample, conds=conds.i)
        x.e <- aldex.effect(x)
        null.set.ty.effect[[i]][[j]] <- x.e
    }
save(null.set.ty.effect, file="data/null.set.ty.effect.RData")
save(null.set.ty.single.effect, file="data/null.set.ty.single.effect.RData")
}


# 3. faza: Vizualizacija podatkov

#GRAFI

#brezposelnost glede na drzavo in stopnjo izobrazbe
viz1 <- uvoz_1 %>%
  group_by(Leto, Drzava) %>%
  ggplot(aes(y=Drzava, x= Vrednost, col=Izobrazba)) + geom_point() +
  scale_color_discrete(name= "Stopnja izobrazbe",
                       labels=c("Osnovnošolska", "Srednješolska", "Univerzitetna+")) +
  labs(title= "Brezposelnost po državah in stopnji izobrazbe") +
  ylab("Države") +
  xlab("Povprečna vrednost") +
  theme(panel.background = element_rect((fill="white")), axis.text= element_text(size=7),
        text= element_text(size=10), plot.title = element_text(face = "bold"))
viz1

#povprecna vrednost po spolu
povprecna_vrednost <- uvoz_1 %>%
  group_by(Spol,Drzava, Leto) %>%
  summarize(VrednostMediane = round(median(Vrednost, na.rm=TRUE), digits = 1)) %>%
  group_by(Spol, Drzava) %>%
  summarize(Povprecje= round(mean(VrednostMediane, na.rm=TRUE), digits = 1))

viz2 <- povprecna_vrednost %>%
  ggplot(aes(x=Povprecje,y=Drzava, fill=Spol)) +
  geom_bar(stat="identity", position=position_dodge()) +
  labs(title="Povprečna brezposelnost glede na spol") +
  scale_fill_discrete(labels=c("Ženske", "Moški")) +
  theme(panel.background = element_rect((fill="white")), axis.text= element_text(size=7),
        text= element_text(size=12), plot.title = element_text(face = "bold")) +
  xlab("Vrednost") + ylab("Države")

#povprecna vrednost glede na izobrazbo in spol po regijah-slo
tabela2 <- uvoz_2 %>%
  group_by(Izobrazba, Spol, Regija, Leto) %>%
  summarize(povprecje= round(mean(Stopnja_brezposelnosti), digits = 1)) %>% arrange(Leto)

viz3 <- tabela2 %>%
  ggplot(aes(x=Regija,y=povprecje, shape=Spol, col=Spol)) +
  scale_shape_manual(values = c("\u2642", "\u2640")) +
  scale_color_manual(values = c("blue", "red")) +
  scale_x_discrete(labels=c("Vzhodna Slovenija" = "VS", "Zahodna Slovenija" = "ZS"))+
  geom_point(size=3) +
  facet_grid(~factor(Izobrazba, levels= c("OS", "Nizja poklicna", "Srednja,splosna", "Vss"),
                     labels = c("OŠ", "Nižja poklicna", "Srednja, splošna", "VSŠ"), ordered = TRUE)) +
  labs(title="Povprečna stopnja brezposelnosti glede na izobrazbo po regijah") +
  ylab("Povprečna vrednost") +
  theme(panel.background = element_rect((fill="lightyellow")), axis.text= element_text(size=7),
        text= element_text(size=10), strip.background =element_rect(fill="white"),
        plot.title = element_text(face = "bold"))

viz3

#graf stopnje brezposelnosti glede na drzavo:
uvoz_1 %>%
  ggplot(aes(x= Vrednost, y= Drzava, col="Spol"))+
  geom_point(colour= "green") +
  labs(title= "Povprečna stopnja brezposelnosti po državah") +
  ylab("Države") +
  xlab("Stopnja brezposelnosti") +
  theme(panel.background = element_rect((fill="white")),text = element_text(size=9)) +
  theme(plot.title = element_text(face = "bold"))

#ZEMLJEVIDI

zemljevid.slo <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip",
                                 "gadm36_SVN_1", encoding = "UTF-8")

tabela4 <- uvoz_4 %>%
  group_by(regija) %>%
  summarize(povprecje = round(mean(Stopnja_brezposelnosti), digits=2))

zemljevid1 <- tm_shape(merge(zemljevid.slo, tabela4, by.x= "NAME_1", by.y="regija")) +
  tm_style(style="natural") +
  tm_polygons("povprecje", style="quantile", n=5, title="Povprečna stopnja brezposelnosti",
              palette="BuPu") +
  tm_legend(outside = TRUE, outside.position="right") +
  tm_text("NAME_1", size=0.5, col="black") +
  tm_layout(legend.frame = FALSE, legend.bg.color = NA, legend.width = 0.3, bg.color = NA, frame = FALSE)

zemljevid1


setwd("/Users/jackcook/Desktop/statistician/src")

source("bivariate.r")
source("univariate.r")

cat("What type of data would you like to analyze? (1 = univariate, 2 = bivariate, 3 = categorical): ")
data_type <- readLines(con = "stdin", 1)

if (data_type == 1) {
    cat("What is being measured? ")
    name <- readLines(con = "stdin", 1)

    cat("Enter in your data values, separated by spaces: ")
    data_points <- readLines(con = "stdin", 1)

    values <- as.numeric(strsplit(data_points, " ")[[1]])
    analysis <- analyze_univariate_data(values, name)
    print(analysis)
} else if (data_type == 2) {
    cat("What is your explanatory variable measuring? ")
    explanatory_name <- readLines(con = "stdin", 1)

    cat("What is your response variable measuring? ")
    response_name <- readLines(con = "stdin", 1)

    cat("Enter in your explanatory variable values, separated by spaces: ")
    explanatory_variable <- readLines(con = "stdin", 1)

    cat("Enter in your response variable values, separated by spaces: ")
    response_variable <- readLines(con = "stdin", 1)

    explanatory_values <- as.numeric(strsplit(explanatory_variable, " ")[[1]])
    response_values <- as.numeric(strsplit(response_variable, " ")[[1]])

    data <- matrix(cbind(explanatory_values, response_values), ncol = 2)
    analysis <- analyze_bivariate_data(data, explanatory_name, response_name)
    print(analysis)
} else if (data_type == 3) {
    cat("What are your categories? ")
    categories_name <- readLines(con = "stdin", 1)

    cat("Enter in your categories' names, separated by spaces: ")
    categories <- readLines(con = "stdin", 1)

    cat("Enter in your categories' values, separated by spaces: ")
    values <- readLines(con = "stdin", 1)

    category_names <- strsplit(categories, " ")[[1]]
    category_values <- as.numeric(strsplit(values, " ")[[1]])

    percentages <- round(category_values / sum(category_values) * 100)

    lbls <- category_names
    lbls <- paste(lbls, percentages)
    lbls <- paste(lbls, "%", sep = "")

    pie(category_values, labels = lbls, main = categories_name)
}


#summary statistics

churnDataset %>% describe
churnDataset %>% summary

is.na(churnDataset) %>% colSums
MaritalStatus %>% summary
is.na(MaritalStatus) %>% which

plyr::count(Churn)

churnDataset %>% sapply(class)

plyr::count(Education)

with(churnDataset[Dependents==0,] , plot(MaritalStatus,
                                         ylim=c(0,155),
                                         col = "dark blue"))

with(churnDataset[Churn=="No",] , plot(MonthlyIncome,
                                       col = "dark blue"))
with(churnDataset[Churn=="Yes",] , plot(MonthlyIncome,
                                        col = "dark blue"))

#0 anos a trabalhar?
TenureWorking %>% min
# %<>%
which(TenureWorking==0)
churnDataset[which((churnDataset$TenureWorking)==0),'NumberProjectsLastYear']

# EDA | BirthDate & Age & VerifyAge --------------------------------------------

#BirthDate factor w/ 1378 levels out of 1450 obs.
str(BirthDate)
sum(is.na(BirthDate))
head(BirthDate, n=3);tail(BirthDate, n=3)

#Age - TenureWorking
min(churnDataset$Age-churnDataset$TenureWorking)
max(churnDataset$Age-churnDataset$TenureWorking)
which((churnDataset$Age-churnDataset$TenureWorking)==10)
churnDataset[which((churnDataset$Age-churnDataset$TenureWorking)==10),'Age']
churnDataset[which((churnDataset$Age-churnDataset$TenureWorking)==10),'TenureWorking']

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | Gender & isMale ---------------------------------------------------------
plyr::count(Gender)

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | MaritalStatus & isMaritalStatus --------------------------------------------------

levels(MaritalStatus)
plyr::count(MaritalStatus)
round(plyr::count(churnDataset$MaritalStatus)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(MaritalStatus)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(MaritalStatus)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

MaritalStatus %>% summary
is.na(MaritalStatus) %>% which

# Fill missing values with Mode in numerical values
churnDataset$MaritalStatus[is.na(churnDataset$MaritalStatus)] <-
  Mode(churnDataset$MaritalStatus, na.rm = TRUE)

Mode(churnDataset$MaritalStatus, na.rm = TRUE)

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | JobType & JobTypeLevels  --------------------------------------------------------

#is office? enviroment is bad?
JobType %>% levels
round(plyr::count(churnDataset$JobType)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(JobType)$freq/plyr::count(churnDataset$Churn)$freq[2],2))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(JobType)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

df <- fread('Churn Office Office/Remote Remote
             " Global" 18.6 71.4 10.0
              " Yes" 28 67  5
              "No" 16.8 72.2 11.0')

stacked_plot(df)

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | Department & Departments & isDepart -------------------------------------

#Collapse levels of IT and Comercial in a new var
Department %>% levels

churnDataset$Departments %>% levels

#create var isDepartmentComercial?
round(plyr::count(churnDataset$Departments)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(Departments)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(Departments)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

df <- fread('Churn Commercial HR IT
             " Global" 30.3  4.3 65.4
             " Yes" 38.7  5.2 56.1
             "No" 28.7  4.2 67.1')

stacked_plot(df)

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | JobRole & isRole --------------------------------------------------------

#create var isCommercial Representative/IT Technician?
JobRole %>% levels
round(plyr::count(churnDataset$JobRole)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(JobRole)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(JobRole)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

#Only Fixed term on TypeContract
TypeContract %>% levels

# EDA | Education & isEduc ------------------------------------------------------

Education %>% levels
plyr::count(Education)
round(plyr::count(churnDataset$Education)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(Education)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(Education)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | EducationArea & isEducArea ----------------------------------------

EducationArea %>% levels
plyr::count(EducationArea)
round(plyr::count(churnDataset$EducationArea)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(EducationArea)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(EducationArea)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | AfterHours & isAfterHours -----------------------------------------

AfterHours %>% levels
plyr::count(AfterHours)
round(plyr::count(churnDataset$AfterHours)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(AfterHours)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(AfterHours)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | Churn & isChurn ---------------------------------------------------

Churn %>% levels
plyr::count(Churn)

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# EDA | BalanceWorkLife & WorkLifeLevels ------------------------------------------

BalanceWorkLife %>% levels
plyr::count(BalanceWorkLife)
round(plyr::count(churnDataset$BalanceWorkLife)$freq/nrow(churnDataset),3)*100
with(churnDataset[Churn == "Yes",],
     round(plyr::count(BalanceWorkLife)$freq/plyr::count(churnDataset$Churn)$freq[2],3))*100
with(churnDataset[Churn == "No" ,],
     round(plyr::count(BalanceWorkLife)$freq/plyr::count(churnDataset$Churn)$freq[1],3))*100

# attach_set w/ non-overlapping names and clean Global Env from main.r w/ ls()
attach_set(); rm(list = setdiff(ls(.GlobalEnv), c("churnDataset" ,lsf.str())))

# Charts temp. ------------------------------------------------------------

#  PIE CHARTS - three data sets
pie.a <- round(plyr::count(churnDataset$Departments)$freq/1450,2)
pie.b <- with(churnDataset[Churn=="Yes",] , round(plyr::count(Departments)$freq/230,2))
pie.c <- with(churnDataset[Churn=="No",] , round(plyr::count(Departments)$freq/1220,2))

# Changing graphical parameters for a minute
oldpar <- par()   # Stores old graphical parameters
par(mfrow    = c(1, 3),  # Num. rows/cols
    cex.main = 3)   #  Main title 3x bigger
colors <- c("chocolate1", "blue", "chartreuse4")

# Three pie charts side by side
# Is the green slice or blue slice bigger?
pie(pie.a, main = "Global", col = colors)
pie(pie.b, main = "Yes", col = colors)
pie(pie.c, main = "No", col = colors)

par(oldpar)

require(data.table)
require(ggplot2)

levels(Departments)

library(treemap)

plyr::count(JobRole)
# Create data
group=plyr::count(JobRole)$x
value=plyr::count(JobRole)$freq
data=data.frame(group,value)
data

# treemap

png(filename="presentations/tree.png",width=800, height=800)

treemap(data,
        index="group",
        vSize="value",
        type="index",
        fontsize.labels=c(10,1),                # size of labels. Give the size per level of aggregation: size for group, size for subgroup, sub-subgroups...
        fontcolor.labels=c("white"),    # Color of labels
        fontface.labels=c(1,1),                  # Font of labels: 1,2,3,4 for normal, bold, italic, bold-italic...
        bg.labels=c("transparent"),              # Background color of labels
        align.labels=list(
          c("center", "center"),
          c("right", "bottom")
        ),
        palette = "Set2",# Where to place labels in the rectangle?
        overlap.labels=.5,                      # number between 0 and 1 that determines the tolerance of the overlap between labels. 0 means that labels of lower levels are not printed if higher level labels overlap, 1  means that labels are always printed. In-between values, for instance the default value .5, means that lower level labels are printed if other labels do not overlap with more than .5  times their area size.
        inflate.labels=TRUE,
        title="My Treemap",                      # Customize your title
        fontsize.title=12
)

dev.off()

library(ggplot2)
ggplot(churnDataset, aes(x=Departments, fill=Churn)) +
  geom_histogram()

library(plyr)
library(psych)
multi.hist(churnDataset[,sapply(churnDataset, is.numeric)])

display.brewer.pal(3, "Pastel2")

# Put histograms on the diagonal (from "pairs" help)
panel.hist <- function(x, ...)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(usr[1:2], 0, 1.5) )
  h <- hist(x, plot = FALSE)
  breaks <- h$breaks; nB <- length(breaks)
  y <- h$counts; y <- y/max(y)
  rect(breaks[-nB], 0, breaks[-1], y,  ...)
  # Removed "col = "cyan" from code block; original below
  # rect(breaks[-nB], 0, breaks[-1], y, col = "cyan", ...)
}

pairs(churnDataset$JobLevel~MonthlyIncome,
      panel = panel.smooth,  # Optional smoother
      main = "Scatterplot Matrix for ChurnDataset Using pairs Function",
      diag.panel = panel.hist,
      pch = 16,
      col = brewer.pal(2, "Pastel1")[unclass(churnDataset$Churn)])
      # col = "coral3")

names(churnDataset)

# Correlation matrix
numeric_df <- churnDataset[sapply(churnDataset,is.numeric)]
drops <-c("WeekHours", "NumberProjectsLastYear","RoleSatisfaction",
          "Dependents","isSingle" ,"isTogether","isDivorced" ,
          "DistanceHomeOffice", "JobDedication",
          "FacilitiesSatisfaction","HierarchySatisfaction" )
numeric_df <-numeric_df[ , !(names(numeric_df) %in% drops)]
corr <- round(cor(numeric_df), 1)

# Plot
ggcorrplot(corr, hc.order = TRUE,
           type = "lower",
           lab = TRUE,
           lab_size = 3,
           method="circle",
           colors = c("tomato2", "white", "springgreen3"),
           title="Correlogram of mtcars",
           ggtheme=theme_bw)

library(ggplot2)
theme_set(theme_bw())

# Data Prep
data("mtcars")  # load data
mtcars$`car name` <- rownames(mtcars)  # create new column for car names
mtcars$mpg_z <- round((mtcars$mpg - mean(mtcars$mpg))/sd(mtcars$mpg), 2)  # compute normalized mpg
mtcars$mpg_type <- ifelse(mtcars$mpg_z < 0, "below", "above")  # above / below avg flag
mtcars <- mtcars[order(mtcars$mpg_z), ]  # sort
mtcars$`car name` <- factor(mtcars$`car name`, levels = mtcars$`car name`)  # convert to factor to retain sorted order in plot.

churnDataset$mean <-round((churnDataset$MonthlyIncome -
                             mean(churnDataset$MonthlyIncome))/sd(churnDataset$MonthlyIncome), 2)
churnDataset$type <- ifelse(churnDataset$mean < 0, "below", "above")
mtcars <- churnDataset[order(churnDataset$mean), ]
# Diverging Barcharts
ggplot(mtcars, aes(x=JobRole, y=mean, label=mean)) +
  geom_bar(stat='identity', aes(fill=type), width=.5)  +
  scale_fill_manual(name="Mileage",
                    labels = c("Above Average", "Below Average"),
                    values = c("above"="#00ba38", "below"="#f8766d")) +
  labs(subtitle="Normalised salary per xxxx'",
       title= "Diverging Bars") +
  coord_flip()

summary(JobLevel)
ggplot(data=churnDataset)+geom_histogram(aes(x=JobLevel),
                                         color="blue")+
  scale_x_continuous(name="Level", breaks=seq(0,5,1))+
  scale_y_continuous(name="Number of Employees", breaks=seq(0,600,100))+
  ggtitle(label="Job Levels")+ theme_bw()

ggplot(data=churnDataset)+geom_point(aes(x=JobLevel,
                                         y=TenureCompany,
                                         color=as.factor(Gender),
                                         shape=as.factor(Churn)),
                                     size=2,
                                     alpha=0.8)+
  scale_x_continuous(name="Level", breaks=seq(0,5,1))+
  scale_y_continuous(name="Tenure Company", breaks=seq(0,60,10))+
  ggtitle(label="Job Levels")+ theme_bw()

ggplot(data=churnDataset)+geom_bar(aes(x=as.character(AfterHours),fill=as.factor(Gender)))+
  ggtitle(label="Job Levels")+ theme_bw()

ggplot(data=churnDataset)+geom_bar(aes(x=as.character(AfterHours),fill=as.factor(AfterHours)))+
  ggtitle(label="Job Levels")+ theme_bw() + facet_wrap(~Gender)

ggplot(data=churnDataset)+geom_boxplot(aes(x="JobLevel",y=JobLevel))+
  ggtitle(label="Job Levels")+ theme_bw()

ggplot(data=churnDataset)+geom_boxplot(aes(x=JobType,y=MonthlyIncome))+
  ggtitle(label=" MonthlyIncome")+ theme_bw()  + facet_wrap(~Gender)

plot(Education, NumberProjectsLastYear, main="Projects Last Year per Education",
     xlab="Education", ylab="Projects Last Year", pch=1)

plot(Dependents, JobLevel, main="Dependents  per JobLevel",
     xlab="Dependents", ylab="JobLevel", pch=19)

# Add a Normal Curve (Thanks to Peter Dalgaard)

h<-hist(Dependents, breaks=10, col="red", xlab="Job Level",
        main="JobLevel")
xfit<-seq(min(Dependents),max(Dependents),length=30)
yfit<-dnorm(xfit,mean=mean(Dependents),sd=sd(Dependents))
yfit <- yfit*diff(h$mids[1:2])*length(Dependents)
lines(xfit, yfit, col="blue", lwd=2)

ggplot(data = churnDataset) +
  geom_boxplot(mapping = aes(x = Gender, y = Dependents))

# Data cleaning -----------------------------------------------------------
#data cleaning

# dataset_clean<-dataset[!duplicated(dataset),]
# dataset_transpose<-dataset_clean[duplicated(t(dataset_clean)),]
#
#
# #converting dates
# dataset_clean$BirthDate
# library(lubridate)
# dataset_clean$BirthDate<-dmy(dataset_clean$BirthDate)
# dataset_clean$BirthDate
#
# class(dataset_clean$BirthDate)
#
# #sex
# levels(dataset_clean$Sex)
# library(plyr)
# count(dataset_clean, "Sex");
# levels(dataset_clean$Sex)<-tolower(levels(dataset_clean$Sex));levels(dataset_clean$Sex)
# levels(dataset_clean$Sex)[levels(dataset_clean$Sex)=='f']<-"female"
# levels(dataset_clean$Sex)[levels(dataset_clean$Sex)=='m']<-"male";levels(dataset_clean$Sex)
#

# Feature engineering -----------------------------------------------------

# Feature Selection -------------------------------------------------------

# Data Partition ----------------------------------------------------------


library(ggplot2)

dat = read.csv(header=T, 'test.out.gdd')

ggplot(data = dat, aes(x = Count, y=Nodes)) +
  geom_point() +
  labs(x="Graphlet Degree",size=12) +
  labs(y="# of Nodes with degree",size=12) +
  scale_y_log10() +
  scale_x_log10() +
  theme_bw() +
  theme(axis.title = element_text(size=24))

ggsave("out_gdd.png", width=6, height=4.3)


# load libraries
library("tidyverse")
library("psych")
library("gridExtra")
library("scales")
library("limma")
library("edgeR")

# read the grouped protein summary file
paw_raw <- read_tsv("grouped_protein_summary_TMT_8_sorted.txt", skip = 4,
                    n_max = 5427, guess_max = 5427)

# extract protein accession column and TMT data
# need to exclude any rows with an entry in "Filter" column
# there are also 4 unused channels (of 11-plex slots)
paw_tmt <- paw_raw %>%
  filter(., is.na(Filter)) %>%
  select(Accession, starts_with("TotInt_")) %>%
  select(-contains("127N"), -contains("128N"), -contains("130N"), -contains("131C"))

# separate accessions from the data
accession <- paw_tmt$Accession
paw_tmt <- paw_tmt %>% select(-Accession)

# rename the columns and gather the conditions
colnames(paw_tmt) <- c("Media_2.1", "Exo_2.1", "Exo_2.2", "Media_2.2",
                      "Exo_3.1", "Exo_3.2", "Media_3.2")
paw_tmt <- paw_tmt %>% select(contains("Media"), contains("Exo"))

head(paw_tmt)
nrow(paw_tmt)

# define the experimental groups
group <- c(rep("media", 3), rep("exosome", 4))

# define a scale parameter for playing purposes
scale <- 1.0

# load the data in DGEList object
y <- DGEList(counts = paw_tmt/scale, group = group, genes = accession)
y$samples

# run the TMM normalization
y <- calcNormFactors(y)

# set colors for plotting
color <- c(rep("red", 3), rep("blue", 4))

# function to compute the normalized intensities
apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute grand total (library size) scalings
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors
    cat("Overall Factors (lib.size+TMM):\n", sprintf("%-5s -> %f\n",
                                                     colnames(y$counts), norm_facs))

    # compute the normalized data as a new data frame
    tmt_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(tmt_tmm) <- str_c(colnames(y$counts), "_tmm")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(tmt_tmm), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    tmt_tmm
}

# get the normalized data values
paw_tmt_tmm <- apply_tmm_factors(y, color)

# get the cpm matrix and the log2 cpm matrix
cpm_tmt <- cpm(y, log = FALSE)
lcpm <- cpm(y, log = TRUE)

# check lcpm
class(lcpm)
head(lcpm)

# see how media samples correlate
x <- data.frame(log2(rowMeans(paw_tmt_tmm[, 1:3])), log2(rowMeans(cpm_tmt[, 1:3])))
colnames(x) <- c('TMM', 'CPM')
plot(x, main = "Scatter plot of TMM normalized intensities and CPM values")

# we need to get the trended dispersion estimates
y <- estimateDisp(y)
plotBCV(y, main = "Dispersion trends")

collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate <- cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                     labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# compute the exact test models, p-values, FC, etc.
et <- exactTest(y, pair = c("media", "exosome"))

# define variables for the columns in each condition
M <- 1:3
E <- 4:7

# make the results table
tt <- topTags(et, n = Inf, sort.by = "none")$table
med_exo <- collect_results(paw_tmt_tmm, tt, M, "med", E, "exo")

pvalue_plot <- function(results, title) {
    # Makes p-value distribution plots
        # results - results data frame
        # title - plot title
    ggplot(results, aes(PValue)) +
        geom_histogram(bins = 100, fill = "white", color = "black") +
        geom_hline(yintercept = mean(hist(results$PValue, breaks = 100,
                                     plot = FALSE)$counts[26:100])) +
        ggtitle(str_c(title, " p-value distribution"))
}

# check the p-value distrubution
pvalue_plot(med_exo, "Media vs Exosome-dosed")

# see how many up and down candidates (10% FDR)
summary(decideTests(et, p.value = 0.10))

# see which proteins have the smallest p-values
topTags(et)$table

# see how many candidates are in each category
med_exo %>% count(candidate)

log2FC_plots <- function(results, range, title) {
    # Makes faceted log2FC plots by candidate
        # results - results data frame
        # range - plus/minus log2 x-axis limits
        # title - plot title
    ggplot(results, aes(x = logFC, fill = candidate)) +
        geom_histogram(binwidth=0.1, color = "black") +
        facet_wrap(~candidate) +
        ggtitle(title) +
        coord_cartesian(xlim = c(-range, range))
}

# can look at log2FC distributions as a check
log2FC_plots(med_exo, 3, "(edgeR) LogFC by candidate for Media vs Exosome-dosed")

transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")
    df # return the frame
}

MA_plots <- function(results, x, y, title, make_facet = TRUE) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # make_facet - flag to plot facet views
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    if (make_facet == TRUE) {
        ma_facet <- ggplot(temp, aes(x = A, y = M)) +
            geom_point(aes(color = candidate, shape = candidate)) +
            scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
            scale_x_continuous("log10 Ave_intensity") +
            ma_lines +
            facet_wrap(~ candidate) +
            ggtitle(str_c(title, " (separated)"))
    }

    # make the plots visible
    print(ma)
    if (make_facet == TRUE) {
        print(ma_facet)
    }
}

# MA plots of DE candidates
MA_plots(med_exo, "ave_med", "ave_exo", "(edgeR) Media versus exosome-dosed")

scatter_plots <- function(results, x, y, title, make_facet = TRUE) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # make_facet - flag to plot facet views
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    if (make_facet == TRUE) {
        scatter_facet <- ggplot(results, aes_string(x, y)) +
            geom_point(aes(color = candidate, shape = candidate)) +
            scatter_lines +
            facet_wrap(~ candidate) +
            ggtitle(str_c(title, " (separated)"))
    }

    # make the plots visible
    print(scatter)
    if (make_facet == TRUE) {
        print(scatter_facet)
    }
}

#scatter_plots(med_exo, "ave_med", "ave_exo", "(edgeR) Media versus exosome-dosed")

volcano_plot <- function(results, x, y, title, ymax) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # ymax - upper limit for y-axis
        # title - plot title string

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        coord_cartesian(xlim = c(-5, 5), ylim = c(0, ymax)) +
        ggtitle(str_c(title, " Volcano Plot"))
}

# finally, a volcano plot
volcano_plot(med_exo, "ave_med", "ave_exo", "(edgeR) Media versus exosome-dosed", 50)

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_top_tags <- function(results, nleft, nright, top_tags, prefix) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top up-regulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down-regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(prefix, get_identifier(row$Acc),
                       ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}

# plot the top 10 up and 10 down proteins
set_plot_dimensions(7, 4)
plot_top_tags(med_exo, 3, 4, 10, "(edgeR) ")
set_plot_dimensions(7, 7)

# set up the design matrix and the contrast
group <- as.factor(c(rep("media", 3), rep("exosome", 4)))
group <- factor(group, levels(group)[c(2, 1)]) # set the factor order
design <- model.matrix(~ 0 + group)
colnames(design) <- c("media", "exosome")

# see what the desgn matrix looks like
design

# define the comparison contrast
contrast <- makeContrasts(exosome-media, levels = design)
contrast

# run voom to get model weights for each intensity value
v <- voom(y, design, plot = TRUE)

# do the linear model fitting
vfit <- lmFit(v, design)

# get the fit for the contrast of interest
vfit <- contrasts.fit(vfit, contrast)

# do the empirical Bayes moderation of the test f statistic
efit <- eBayes(vfit)

# grab the information in topTable so we can get the data to plot candidates
# the coef parameter has to do with the contrast of interest
# specify no sorting of results and a number that is longer than the data table
tt_limma <- topTable(efit, coef = 1, sort.by = "none", number = Inf)

# let's see how many up and down candidates, and the top tags
summary(decideTests(efit, p.value = 0.10))
topTable(efit)

# get the CPM intensities
limma_PAW <- as.data.frame(cpm_tmt)

# add average ratio columns (non-logged ratios), fold-change column, and row names
limma_PAW$ave_med <- rowMeans(paw_tmt_tmm[M])
limma_PAW$ave_exo  <- rowMeans(paw_tmt_tmm[E])
limma_PAW$logFC <- log2(limma_PAW$ave_exo / limma_PAW$ave_med)
limma_PAW$FC <- ifelse(limma_PAW$ave_exo > limma_PAW$ave_med,
                          (limma_PAW$ave_exo / limma_PAW$ave_med),
                          (-1 * limma_PAW$ave_med / limma_PAW$ave_exo))
limma_PAW$Acc <- accession

# statisticl test results
limma_PAW$PValue <- tt_limma$P.Value
limma_PAW$FDR <- tt_limma$adj.P.Val

# add a DE candidate status column
limma_PAW$candidate <- cut(limma_PAW$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                           labels = c("high", "med", "low", "no"))

# count candidates
print("Candidate Counts:")
summary(limma_PAW$candidate)

# what does the test p-value distribution look like?
pvalue_plot(limma_PAW, "PAW data with limma")

# can look at log2FC distributions as a check
log2FC_plots(med_exo, 3, "(edgeR) LogFC by candidate")
log2FC_plots(limma_PAW, 3, "(limma) LogFC by candidate")

MA_plots(med_exo, "ave_med", "ave_exo", "PAW edgeR results")
MA_plots(limma_PAW, "ave_med", "ave_exo", "PAW limma results")

#scatter_plots(med_exo, "ave_med", "ave_exo", "PAW edgeR results")
#scatter_plots(ttest_PAW, "ave_med", "ave_exo", "PAW t-test results")

# compare volcano plots
volcano_plot(med_exo, "ave_med", "ave_exo", "PAW edgeR results", 40)
volcano_plot(med_exo, "ave_med", "ave_exo", "PAW edgeR results (expanded y-axis)", 6)
volcano_plot(limma_PAW, "ave_med", "ave_exo", "PAW limma results", 6)

set_plot_dimensions(7, 4)
plot_top_tags(limma_PAW, 3, 4, 10, "(limma) ")
set_plot_dimensions(7, 7)

for (cutoff in c(0.10, 0.05, 0.01)) {
    edgeR <- get_identifier(filter(med_exo, FDR < cutoff)$Acc)
    limma <- get_identifier(filter(limma_PAW, FDR < cutoff)$Acc)
    cat("cutoff:", cutoff, "\n")
    cat("number of candidates (edgeR, limma):", length(edgeR), length(limma), "\n")

    x_union <- union(edgeR, limma)
    x_intersect <- intersect(edgeR, limma)
    unique_edgeR <- setdiff(edgeR, limma)
    unique_limma <- setdiff(limma, edgeR)

    cat("union and intersection:", length(x_union), length(x_intersect), "\n")
    cat("intersection out of union:", round(length(x_intersect)/length(x_union), 2), "\n")
    cat("intersection out of edgeR:", round(length(x_intersect)/length(edgeR), 2), "\n")
    cat("intersection out of limma:", round(length(x_intersect)/length(limma), 2), "\n")
    cat("unique to each (edgeR, limma):", length(unique_edgeR),
        length(unique_limma), "\n\n")
}

edgeR_candidates <- get_identifier(filter(med_exo, FDR < 0.10)$Acc)
limma_candidates <- get_identifier(filter(limma_PAW, FDR < 0.10)$Acc)
unique_edgeR_candidates <- setdiff(edgeR_candidates, limma_candidates)
unique_limma_candidates <- setdiff(limma_candidates, edgeR_candidates)

cat("Candidates in limma but not candidate (<0.1) in edgeR")
interesting_limma <- setdiff(unique_limma_candidates, edgeR_candidates)
length(interesting_limma)
cat("Candidates in edgeR but not candidate (<0.1) in limma")
interesting_edgeR <- setdiff(unique_edgeR_candidates, limma_candidates)
length(interesting_edgeR)

# explore high in limma but not high in edgeR (104)
interesting <- setdiff(unique_limma, edgeR_candidates) # high in limma but not a candidate in edgeR
not_interesting <- setdiff(unique_limma, interesting) # high in limma and also a candidate in edgeR
cat(length(interesting), length(not_interesting))

plot_selected <- function(results, nleft, nright, selected, prefix) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # selected is list of identifiers to plot
    proteins <- results
    proteins$ident <- get_identifier(results$Acc)
    proteins <- filter(proteins, ident %in% selected)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(prefix, row$ident, ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}

#set_plot_dimensions(7, 4)
#plot_selected(limma_PAW, 3, 4, sample(not_interesting, 10), "(limma) ")
#set_plot_dimensions(7, 7)

# plot the t-test candidates that were not significant in edgeR
#set_plot_dimensions(7, 4)
#plot_selected(limma_PAW, 3, 4, interesting, "(limma) ")
#set_plot_dimensions(7, 7)

set_plot_dimensions(7, 7)
volcano_plot_facet <- function(results, x, y, other, title, ymax) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # ymax - upper limit for y-axis
        # title - plot title string
        # other - candidate flags from the other test

    # uses transformed data
    temp <- transform(results, x, y)
    temp$other <- other

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate), alpha = 0.5) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        coord_cartesian(xlim = c(-5, 5), ylim = c(0, ymax)) +
        facet_wrap(~ other) +
        ggtitle(str_c(title, " Volcano Plot"))
}

# cross-candidate faceted volcano plots
volcano_plot_facet(med_exo, "ave_med", "ave_exo", str_c("limma_", limma_PAW$candidate),
                   "edgeR faceted by limma candidate", 10)

# with the tests switched
volcano_plot_facet(limma_PAW, "ave_med", "ave_exo", str_c("edgeR_", med_exo$candidate),
                   "limma faceted by edgeR candidate", 5)

# save the testing results
#write.table(med_exo, file = "KUR1502_results_limma-voom.txt", sep = "\t",
#            row.names = FALSE, na = " ")

# log the session
sessionInfo()


root <- "/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/tfinal/"
files <- read.csv("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/tfinal/data_fin.csv")
demoall <- function(left, right) {
    for (value in files[,6]) {
        filename <- paste(root, value, sep="")
        print(filename)

        x = read.table(filename)
        RT1 = x[left:right,8]
        RT2 = x[left:right,9]
        correct = x[left:right,10]==1 & x[left:right,11]==1
        soa = x[left:right,7]
        RT2 = RT2 + RT1 - soa
        soas = sort(unique(soa))
        realdata = x[left:right,1]==2

        rt1 = numeric(4)
        rt2 = numeric(4)

        rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
        rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
        rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
        rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

        rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
        rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
        rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
        rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

        r=c(min(c(rt1,rt2)),max(c(rt1,rt2)))
        print(r)
        png(paste(filename, ".png", sep=""))
        plot( soas, rt1 , col="red", ylim=r, ylab="Response times", xlab = "SOA (time between two stimuli)")
        lines( soas, rt1 , col="red")
        points( soas, rt2 , col="blue")
        lines( soas, rt2 , col="blue")
        legend("topright",c("RT1","RT2"),fill=c("red","blue"))
        Sys.sleep(1)
        dev.off()
    }
}

plotmean <- function(left, right) {
    allRT11 <-list()
    allRT12 <-list()
    allRT13 <-list()
    allRT14 <-list()
    allRT21 <-list()
    allRT22 <-list()
    allRT23 <-list()
    allRT24 <-list()
    for (value in files[,6]) {
        filename <- paste(root, value, sep="")
        print(filename)

        x = read.table(filename)
        RT1 = x[left:right,8]
        RT2 = x[left:right,9]
        correct = x[left:right,10]==1 & x[left:right,11]==1
        soa = x[left:right,7]
        RT2 = RT2 + RT1 - soa
        soas = sort(unique(soa))
        realdata = x[left:right,1]==2

        rt1 = numeric(4)
        rt2 = numeric(4)

        rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
        rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
        rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
        rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

        rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
        rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
        rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
        rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

        allRT11 <- unlist(append(allRT11, rt1[1]))
        allRT12 <- unlist(append(allRT12, rt1[2]))
        allRT13 <- unlist(append(allRT13, rt1[3]))
        allRT14 <- unlist(append(allRT14, rt1[4]))
        allRT21 <- unlist(append(allRT21, rt2[1]))
        allRT22 <- unlist(append(allRT22, rt2[2]))
        allRT23 <- unlist(append(allRT23, rt2[3]))
        allRT24 <- unlist(append(allRT24, rt2[4]))
    }

    rt1 = numeric(4)
    rt2 = numeric(4)

    rt1[1]=mean( allRT11 )
    rt1[2]=mean( allRT12 )
    rt1[3]=mean( allRT13 )
    rt1[4]=mean( allRT14 )

    rt2[1]=mean( allRT21 )
    rt2[2]=mean( allRT22 )
    rt2[3]=mean( allRT23 )
    rt2[4]=mean( allRT24 )

    r=c(min(c(rt1,rt2)),max(c(rt1,rt2)))
    #png(filename="/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/code/finalinit.png")
    plot( soas, rt1 , col="red", ylim=r, ylab="Response times", xlab = "SOA (time between two stimuli)")
    lines( soas, rt1 , col="red")
    points( soas, rt2 , col="blue")
    lines( soas, rt2 , col="blue")
    legend("topright",c("RT1","RT2"),fill=c("red","blue"))
    #dev.off()

}

plotmeanage <- function(left, right) {
    youngallRT11 <-list()
    youngallRT12 <-list()
    youngallRT13 <-list()
    youngallRT14 <-list()
    youngallRT21 <-list()
    youngallRT22 <-list()
    youngallRT23 <-list()
    youngallRT24 <-list()

    oldallRT11 <-list()
    oldallRT12 <-list()
    oldallRT13 <-list()
    oldallRT14 <-list()
    oldallRT21 <-list()
    oldallRT22 <-list()
    oldallRT23 <-list()
    oldallRT24 <-list()

    for (i in 1:length(files[,1])) {
        value = files[i, 6]
        age = files[i, 4]
        dominant_hand = files[i, 5]
        time_taken = files[i, 9]

        filename <- paste(root, value, sep="")
        print(filename)

        x = read.table(filename)
        RT1 = x[left:right,8]
        RT2 = x[left:right,9]
        correct = x[left:right,10]==1 & x[left:right,11]==1
        soa = x[left:right,7]
        RT2 = RT2 + RT1 - soa
        soas = sort(unique(soa))
        realdata = x[left:right,1]==2

        rt1 = numeric(4)
        rt2 = numeric(4)

        rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
        rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
        rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
        rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

        rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
        rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
        rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
        rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

        if (age <= 22) {
            youngallRT11 <- unlist(append(youngallRT11, rt1[1]))
            youngallRT12 <- unlist(append(youngallRT12, rt1[2]))
            youngallRT13 <- unlist(append(youngallRT13, rt1[3]))
            youngallRT14 <- unlist(append(youngallRT14, rt1[4]))
            youngallRT21 <- unlist(append(youngallRT21, rt2[1]))
            youngallRT22 <- unlist(append(youngallRT22, rt2[2]))
            youngallRT23 <- unlist(append(youngallRT23, rt2[3]))
            youngallRT24 <- unlist(append(youngallRT24, rt2[4]))
        }
        else {
            oldallRT11 <- unlist(append(oldallRT11, rt1[1]))
            oldallRT12 <- unlist(append(oldallRT12, rt1[2]))
            oldallRT13 <- unlist(append(oldallRT13, rt1[3]))
            oldallRT14 <- unlist(append(oldallRT14, rt1[4]))
            oldallRT21 <- unlist(append(oldallRT21, rt2[1]))
            oldallRT22 <- unlist(append(oldallRT22, rt2[2]))
            oldallRT23 <- unlist(append(oldallRT23, rt2[3]))
            oldallRT24 <- unlist(append(oldallRT24, rt2[4]))
        }

    }

    youngrt1 = numeric(4)
    youngrt2 = numeric(4)
    oldrt1 = numeric(4)
    oldrt2 = numeric(4)

    oldrt1[1]=mean( oldallRT11 )
    oldrt1[2]=mean( oldallRT12 )
    oldrt1[3]=mean( oldallRT13 )
    oldrt1[4]=mean( oldallRT14 )

    oldrt2[1]=mean( oldallRT21 )
    oldrt2[2]=mean( oldallRT22 )
    oldrt2[3]=mean( oldallRT23 )
    oldrt2[4]=mean( oldallRT24 )

    youngrt1[1]=mean( youngallRT11 )
    youngrt1[2]=mean( youngallRT12 )
    youngrt1[3]=mean( youngallRT13 )
    youngrt1[4]=mean( youngallRT14 )

    youngrt2[1]=mean( youngallRT21 )
    youngrt2[2]=mean( youngallRT22 )
    youngrt2[3]=mean( youngallRT23 )
    youngrt2[4]=mean( youngallRT24 )

    r=c(min(c(youngrt1,youngrt2)),max(c(youngrt1,youngrt2)))
    png(filename="/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/code/finalyoung.png")
    plot( soas, youngrt1 , col="red", ylim=r, ylab="Response times (under 23)", xlab = "SOA (time between two stimuli)")
    lines( soas, youngrt1 , col="red")
    points( soas, youngrt2 , col="blue")
    lines( soas, youngrt2 , col="blue")
    legend("topright",c("RT1","RT2"),fill=c("red","blue"))
    dev.off()
    Sys.sleep(10)
    r=c(min(c(oldrt1,oldrt2)),max(c(oldrt1,oldrt2)))
    png(filename="/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/code/finalold.png")
    plot( soas, oldrt1 , col="red", ylim=r, ylab="Response times (after 23)", xlab = "SOA (time between two stimuli)")
    lines( soas, oldrt1 , col="red")
    points( soas, oldrt2 , col="blue")
    lines( soas, oldrt2 , col="blue")
    legend("topright",c("RT1","RT2"),fill=c("red","blue"))
    dev.off()
}

plotmeanhand <- function(left, right, handed) {
    # handed is 2 if right, 1 if left
    allRT11 <-list()
    allRT12 <-list()
    allRT13 <-list()
    allRT14 <-list()
    allRT21 <-list()
    allRT22 <-list()
    allRT23 <-list()
    allRT24 <-list()
    for (i in 1:length(files[,1])) {
        value = files[i, 6]
        age = files[i, 4]
        dominant_hand = files[i, 5]
        time_taken = files[i, 9]

        filename <- paste(root, value, sep="")
        print(filename)

        if (dominant_hand != handed) {
            next
        }

        x = read.table(filename)
        RT1 = x[left:right,8]
        RT2 = x[left:right,9]
        correct = x[left:right,10]==1 & x[left:right,11]==1
        soa = x[left:right,7]
        RT2 = RT2 + RT1 - soa
        soas = sort(unique(soa))
        realdata = x[left:right,1]==2

        rt1 = numeric(4)
        rt2 = numeric(4)

        rt1[1]=mean( RT1[ correct & realdata & soa==soas[1] ] )
        rt1[2]=mean( RT1[ correct & realdata & soa==soas[2] ] )
        rt1[3]=mean( RT1[ correct & realdata & soa==soas[3] ] )
        rt1[4]=mean( RT1[ correct & realdata & soa==soas[4] ] )

        rt2[1]=mean( RT2[ correct & realdata & soa==soas[1] ] )
        rt2[2]=mean( RT2[ correct & realdata & soa==soas[2] ] )
        rt2[3]=mean( RT2[ correct & realdata & soa==soas[3] ] )
        rt2[4]=mean( RT2[ correct & realdata & soa==soas[4] ] )

        allRT11 <- unlist(append(allRT11, rt1[1]))
        allRT12 <- unlist(append(allRT12, rt1[2]))
        allRT13 <- unlist(append(allRT13, rt1[3]))
        allRT14 <- unlist(append(allRT14, rt1[4]))
        allRT21 <- unlist(append(allRT21, rt2[1]))
        allRT22 <- unlist(append(allRT22, rt2[2]))
        allRT23 <- unlist(append(allRT23, rt2[3]))
        allRT24 <- unlist(append(allRT24, rt2[4]))
    }

    rt1 = numeric(4)
    rt2 = numeric(4)

    rt1[1]=mean( allRT11 )
    rt1[2]=mean( allRT12 )
    rt1[3]=mean( allRT13 )
    rt1[4]=mean( allRT14 )

    rt2[1]=mean( allRT21 )
    rt2[2]=mean( allRT22 )
    rt2[3]=mean( allRT23 )
    rt2[4]=mean( allRT24 )

    postfix = ""
    if (handed == 1) {
        postfix = "left.png"
    }
    else {
        postfix = "right.png"
    }

    r=c(min(c(rt1,rt2)),max(c(rt1,rt2)))

    #png(filename=paste("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/code/", postfix, sep = ""))
    plot( soas, rt1 , col="red", ylim=r, ylab="Response times", xlab = "SOA (time between two stimuli)")
    lines( soas, rt1 , col="red")
    points( soas, rt2 , col="blue")
    lines( soas, rt2 , col="blue")
    legend("topright",c("RT1","RT2"),fill=c("red","blue"))
    #dev.off()

}

demoall(21,120)
#plotmean(21,70)
plotmean(21,70)
plotmeanage(21,120)

plotmeanhand(21, 120, 1)

files <- read.csv("/home/zubair/Documents/Work/Acads/Semester7/subjects/cogsci/Project/tfinal/data_multiple.csv")


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
# install.packages("e1071")
# install.packages("pmml")
# install.packages("gmodels")
# install.packages("rpart.plot")
# install.packages("ROCR")
# install.packages("caret")

# Load below packages
library(e1071)
library(pmml)
library(gmodels)
library(rpart.plot) # This package is specifically loaded for titanic dataset shipped within it.
library(ROCR)
library(caret)

# Here we directly load the titanic dataset installed with the "rpart.plot" package.
data(ptitanic)

# rename column names in ptitanic dataset from rpart.plot package
titanicOriginal <- setNames(ptitanic, c("Class", "Survived", "Sex", "Age", "Siblings", "Children"))

# Omit rows with missing values
titanicOriginal <- na.omit(titanicOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# titanic<- read.csv("Titanic.csv")

# Randomizing data
titanic<-titanicOriginal[sample(nrow(titanicOriginal)),]

# Divide dataset for training and test
trainData <- titanic[1:836, ]
testData  <- titanic[837:1046, ]

# Set predicted field in formula
formula = formula(Survived ~ .)

# Create model for training set using naiveBayes
titanicTrainingModel = naiveBayes(formula, trainData, threshold = 0)

# Display the predicted results and create cross table to check on accuracy
# Predict "survived" column for test data set
titanicTestPrediction <- predict(titanicTrainingModel, testData)
# Display predicted values
titanicTestPrediction

# Create cross table to check on accuracy.
CrossTable(titanicTestPrediction, testData$Survived,
           prop.chisq = FALSE, prop.t = FALSE, prop.r = FALSE,
           dnn = c('predicted', 'actual'))

# Predict the Probabilities for test dataset
titanicTestProbabilities = predict(titanicTrainingModel, newdata = testData, threshold = 0, type = "raw")

# Generate ROC curve and calculate AUC value to predict the accuracy for Titanic test dataset
# To create visualizations - ROC curve with "ROCR" package two vectors of data are needed,
# The first vector must contain the class values - survived column and
# The second vector must contain the estimated probability of the positive class(PassengerSurvivedProbability)
pred <- prediction(labels = testData$Survived, predictions = titanicTestProbabilities[,2])

# Using the perf performance object, we can visualize the ROC curve with R's plot() function
perf <- performance(pred, measure = "tpr", x.measure = "fpr")

# Plot the ROC curve for the visualization
plot(perf, main = "ROC curve for Titanic Test Dataset", col = "blue", lwd = 3)

# To indicate reference line in the ROC plot
abline(a = 0, b = 1, lwd = 2, lty = 2)

# We can use the ROCR package to calculate the AUC(Area under the ROC Curve)
# To do so, we first need to create another performance object and specify measure = "auc", as shown in the following code:
perf.auc <- performance(pred, measure = "auc")

# perf.auc is an object (specifically known as an S4 object) we need to use a special type of notation to access the values stored within.
# S4 objects hold information in positions known as slots
# The str() function can be used to see all slots for an object
str(perf.auc)

# To access the AUC value, which is stored as a list in the y.values slot, we can use the @ notation along with the unlist() function, which simplifies lists to a vector of numeric values
# Below AUC value is under the "excellent/good" category
unlist(perf.auc@y.values)

# View Specificity, Sensitivity and Accuracy information using confusionMatrix function from "caret" package
confusionMatrix(titanicTestPrediction,testData$Survived, positive = "survived")

# PMML generation
saveXML(pmml(titanicTrainingModel, predictedField = "Survived"), "Titanic.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original ptitanic data set and predicted results are saved in "ROuput.csv"
# "ROuput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying Naive Bayes model to entire dataset and save the results in a CSV file
classes = predict(titanicTrainingModel, newdata = titanicOriginal, threshold = 0, type = "class")
probabilities = predict(titanicTrainingModel, newdata = titanicOriginal, threshold = 0, type = "raw")

# Save predicted value in a data frame
writeOutput = function(classes, probabilities, file)
{
	result = NULL
	if(is.null(probabilities))
	{
		result = data.frame(classes)
		names(result) = c("Survived")
	}
	else
	{
		result = data.frame(classes, probabilities)
		names(result) = c("Predicted_Survived", "PassengerDiedProbability","PassengerSurvivedProbability")
	}
	write.csv(result, file, quote=F)
}

# Write the results in a CSV file
writeOutput(classes, probabilities, "ROutput.csv")


logit <- function(x, ns = 23714) {
    if (!is.null(ns))x = ((ns - 1) * x + 0.5)/ns
    return(log((1/x) -1)* (-1))
}


#' Deterministic model function
#'
#' Deterministic daily age structured model
#'
#' @param params A list with the following parameters included:
#'
#' ini.prev = percentage of individuals infected at the start (scalar value between 0 and 1),
#'
#' n.age.cats = number of age categories to monitor. Currently makes the most sense to be by decade for 10 categories (must be scalar value greater than 3).
#'
#' n.i.cats = number of I subcategories
#'
#' n.e.cats = number of E subcategories
#'
#' e.move = rate of movement in the exposed categories (scalar values between 0 and 1).
#'
#' i.move = rate of movement in the infectious categories (scalar between 0 and 1)
#'
#' beta = transmission coefficient
#'
#' contacts = symmetrical matrix of n.age.cats*n.age.cats of the contact rate between age categories. 1 = average, 1.1 = 10% increase, .9 = 10% decrease.
#'
#' n0 = initial population size (scalar value greater than 0)
#'
#' n.days = number of days to run the model (scalar value greater than 2),
#'
#' severity is a vector of length n.age.cats of the proportion of I that goes to the hospital
#'
#' d.no is the proportion of severe cases that die per day w/o hospital care (currently scalar)
#'
#' d.yes is the proportion that die with hospital care
#'
#' beds is the # of beds or ICUs that are available
#'
#' @return A list with 3 outputs:
#'
#' 1. List of counts of the # of individuals in S, E, I, R categories over time with the following columns: age category, day of simulation, sub category (for E and I), n = number of individuals
#'
#' 2. List of outcomes-- Dt = deaths, Ht = hospitalizations needed
#'
#'  Lists for Dt and Ht with the following columns: age category, day of the simulation, n = # of individuals
#'
#' 3. R0 = basic disease reproductive number
#'
#' @importFrom popbio stable.stage
#' @importFrom dplyr rename mutate
#' @importFrom reshape2 melt
#' @importFrom stats rgamma
#' @importFrom magrittr %>%
#' @examples
#' params <- list(ini.prev = 0.001, n.age.cats = 10,  n.e.cats = 6, n.i.cats = 5,
#'               e.move = 0.99, i.move = 0.99, beta = .35, theta = 1,
#'               n0 = 10000, n.days = 360, d.no = 0.05, d.yes = 0.01, beds = 20,
#'               contacts = matrix(1, nrow = 10, ncol = 10),
#'               severity = c(0, 0, 0.001, 0.002, 0.004, 0.010, 0.020, 0.044,
#'               0.093, 0.200))
#'
#' out <- det_model(params)
#'
#' @export

det_model <- function(params) {
  #### warnings ####
  # write the list objects to the local environment
  for (v in 1:length(params)) assign(names(params)[v], params[[v]])
  if(exists("ini.prev")==FALSE){
    message("initial prevalence is missing, using default value")
    ini.ad.m.prev <- 0.01
  }
  if(exists("n.age.cats")==FALSE){
    message("# of age categories is missing, using default value")
    n.age.cats <- 10
  }

  if(exists("e.move")==FALSE){
    message("e.move is missing, using default value")
    e.move <- 0.4
  }

  if(exists("i.move")==FALSE){
    message("i.move is missing, using default value")
    i.move <- 0.4
  }

  if(exists("beta")==FALSE){
    message("transmission beta is missing, using default value")
    beta <- 0.08
  }

  if(exists("theta")==FALSE){
    message("theta is missing, using default value")
    theta <- 1
  }

  if(exists("n0")==FALSE){
    message("initial population size n0 is missing, using default value")
    n0 <- 10000
  }

  if(exists("n.days")==FALSE){
    message("n.days is missing, using default value")
    n.days <- 360
  }

  ##### check parameter values #####
  if(ini.prev < 0) warning("ini.prev must >=0")
  if(ini.prev > 1) warning("ini.prev must be <= 1")

  if(n.age.cats < 4) warning("n.age.cats must be 4 or more")
  if(e.move < 0) warning("e.move must be between 0 and 1")
  if(e.move > 1) warning("e.move must be between 0 and 1")
  if(i.move < 0) warning("i.move must be between 0 and 1")
  if(i.move > 1) warning("i.move must be between 0 and 1")
  if(beta < 0) warning("beta cannot be negative")
  if(n0 <= 0) warning("n0 must be positive")
  if(n.days <= 0) warning("n.days must be positive")
  if(n.e.cats <= 2) warning("n.e.cats must be >= 2")
  if(n.i.cats <= 2) warning("n.i.cats must be >= 2")

  #### INITIAL CONDITIONS ####

  #NOTE!!! currently making up these survival and repro values
  #NOTE!!! n.age.cats not fully flexible, best if n.age.cats = 10 (1 for each decade)
  prop.aging <- 1/n.age.cats # proportion that age out of a category (approx.)
  mort <- rep(0.001, n.age.cats - 4)
  old.mort <- rep(0.1, 4) # last 4 categories

  remain <- rep(1, n.age.cats) - prop.aging - c(mort, old.mort)
  repro <- 0.08

  # Create the matrix to start the population at stable age dist
  # Probably should just fix n.age.cats and feed in the current US age dist.
  M <- matrix(rep(0, n.age.cats * n.age.cats), nrow = n.age.cats)
  diag(M) <- remain
  M[row(M) == (col(M) + 1)] <- prop.aging # off diagonal
  M[n.age.cats, n.age.cats] <- 1-old.mort[1] # old category mortality

  # insert the fecundity vector for prebirth census
  # only used for the stable age dist
  M[1, 2:4] <- repro * (1-mort[1]) * 0.5

  #lambda(M)
  #plot(stable.stage(M))

  # pre-allocate the output matrices
  tmp <- matrix(0, nrow = n.age.cats, ncol = n.days)
  St <- tmp  # susceptible
  Et <- array(rep(tmp), dim = c(n.age.cats, n.days, n.e.cats)) # exposed
  It <- array(rep(tmp), dim = c(n.age.cats, n.days, n.i.cats))  # infectious
  Rt <- tmp # recovered

  # for tracking purposes
  Dt <- tmp # disease deaths
  Ht <- tmp  # hospitalizations

  # Intializing with the stable age distribution.
  St[, 1] <- popbio::stable.stage(M) * n0 * (1 - ini.prev)

  # equally allocating prevalence across ages,
  # currently putting them in the 1st I category
  It[, 1, 1] <- popbio::stable.stage(M) * n0 * ini.prev

  # calculate R0 (not sure about this)
  R0 <- (1-exp (-(beta * n0) / n0^theta)) *
    mean(rgamma(1000, n.i.cats, i.move))
  # assumes no mortality during infectious period and no effect of
  # hospitalization or containment
  # doesn't account for contact matrix. Probably need an NGM approach

  #### MODEL ####
  for (t in 2:(n.days)) {
    # bring forward previous month, then modify it
    St[, t]   <- St[, t - 1]
    Et[, t, ] <- Et[, t - 1, ]
    It[, t, ] <- It[, t - 1, ]
    Rt[, t]   <- Rt[, t - 1]

    # Move E individuals forward in their subcategories
    e.movers <- Et[, t, ] * e.move

    Et[, t, 1] <- Et[, t, 1] - e.movers[, 1]
    Et[, t, 2:n.e.cats] <- Et[, t, 2:n.e.cats] - e.movers[, 2:n.e.cats] +
      e.movers[, 1:(n.e.cats-1)]

    # Exposed become infectious
    It[, t, 1] <- It[, t, 1] + e.movers[ , n.e.cats]

    # Move I individuals forward in their subcategories
    i.movers <- It[, t, ] * i.move

    It[, t, 1] <- It[, t, 1] - i.movers[, 1]
    It[, t, 2:n.i.cats] <- It[, t, 2:n.i.cats] - i.movers[, 2:n.i.cats] +
                            i.movers[, 1:(n.i.cats-1)]

    # infectious individs exit from the last I cat into recovered
    Rt[ , t] <- Rt[ , t] + i.movers[ , n.i.cats]

    ##### Transmission #####
    I.current <- rowSums(It[ ,t, ]) # current # of I's by age
    Nall <- sum(St[, t]) + sum(Et[, t, ]) + sum(It[, t, ]) + sum(Rt[, t]) #total

    # probably a faster way to do this
    cases <- St[, t] * contacts %*%
                       (1 - exp( -(beta * (as.matrix(I.current)/ Nall ^ theta))))

    St[, t] <- St[, t] - cases
    Et[, t, 1] <- Et[, t, 1] + cases

    ##### Hospitalizations needed #####
    Ht[ ,t] <- severity * I.current

    ##### Deaths #####
    # hospital beds are allocated proportion to case load
    # maybe modify in the future for different options
    hos.yes <- min(c(beds * Ht[,t]/sum(Ht[,t]), Ht[,t])) # hospitalized
    hos.no <- Ht[,t] - hos.yes # not able to be hospitalized

    # deaths depend on whether they are hospitalized
    Dt[ ,t] <- hos.no * d.no + hos.yes * d.yes

    # remove those deaths from the I category
    # currently not skewed by time in the infectious class
    It[ , t, ] <- It[ , t, ] - (It[ , t, ] / I.current) * Dt[ ,t]
  }

  ##### organize the output #####
  St <- as.data.frame(t(St))
  names(St) <- paste("age", seq(1,n.age.cats), sep = ".")
  St$day <- 1:n.days

  St.long <- melt(St, id.vars = c("day")) %>%
    rename(age = variable, n = value)
  St.long$age <- as.numeric(St.long$age)
  St.long <- St.long[,c("age", "day", "n")]

  Rt <- as.data.frame(t(Rt))
  names(Rt) <- paste("age", seq(1,n.age.cats), sep = ".")
  Rt$day <- 1:n.days

  Rt.long <- melt(Rt, id.vars = c("day")) %>%
    rename(age = variable, n = value)
  Rt.long$age <- as.numeric(Rt.long$age)
  Rt.long <- Rt.long[,c("age", "day", "n")]

  Dt <- as.data.frame(t(Dt))
  names(Dt) <- paste("age", seq(1,n.age.cats), sep = ".")
  Dt$day <- 1:n.days

  Dt.long <- melt(Dt, id.vars = c("day")) %>%
    rename(age = variable, n = value)
  Dt.long$age <- as.numeric(Dt.long$age)
  Dt.long <- Dt.long[,c("age", "day", "n")]

  Ht <- as.data.frame(t(Ht))
  names(Ht) <- paste("age", seq(1,n.age.cats), sep = ".")
  Ht$day <- 1:n.days

  Ht.long <- melt(Ht, id.vars = c("day")) %>%
    rename(age = variable, n = value)
  Ht.long$age <- as.numeric(Ht.long$age)
  Ht.long <- Ht.long[,c("age", "day", "n")]

    # convert array to matrix format
  Et.long <- melt(Et) %>%
    rename(age = Var1, day = Var2, subcat = Var3, n = value)
  It.long <- melt(It) %>%
    rename(age = Var1, day = Var2, subcat = Var3, n = value)

  counts <- list(St = St.long, Et = Et.long, It = It.long, Rt = Rt.long)
  outcomes <- list(Dt = Dt.long, Ht = Ht.long)
  output <- list(counts = counts, outcomes = outcomes, R0 = R0)
}


library(rrcovNA)
set.seed(42)

# read training data
train <- read.csv('data/train.csv', sep=',', na.strings=c(''))
# drop some columns
train <- subset(train, select = -c(Cabin, Ticket, Name, Fare))
# correct some column types
train$Sex <- as.factor(train$Sex)
train$Embarked <- as.factor(train$Embarked)

# add explicit levels argument to make R use 0 and 1 as the levels instead of 1 and 2
train$Survived <- as.factor(train$Survived, levels=c(0,1))

summary(train)
str(train)

# impute missing multivariate data using sequential algorithm
train.imp_seq = impSeq(train)
summary(train.imp_seq)
str(train.imp_seq)

# Impute missing multivariate data using robust sequential algorithm using explicit default alpha
# we need to get the x column of the returned result to obtain the imputed dataframe
train.imp_seq_rob = impSeqRob(train, alpha=0.9)$x
summary(train.imp_seq_rob)
str(train.imp_seq_rob)