library(dash)
library(dashCoreComponents)
library(dashHtmlComponents)
library(tidyverse)
library(plotly)
library(gapminder)
library(repr)
library(gridExtra)

# We'll replace our styles with an external stylesheet
# for simplicity
app <- Dash$new(external_stylesheets = "https://codepen.io/chriddyp/pen/bWLwgP.css")

full_data <- read_csv("https://raw.githubusercontent.com/evelynmoorhouse/DSCI532_World_Wide_Weapons_Report_R/master/data/clean/full_data.csv")

# yearMarks <- map(unique(full_data$year), as.character)
# names(yearMarks) <- unique(full_data$year)
# yearSlider <- dccRangeSlider(
#   id = "year",
#   marks = yearMarks,
#   min = 1990,
#   max = 2018,
#   step = 5,
#   value = list(1990, 2018)
# )

countryDropdown <- dccDropdown(
  id = "country",
  # map/lapply can be used as a shortcut instead of writing the whole list
  # especially useful if you wanted to filter by country!
  options = map(
    unique(full_data$country), function(x){
      list(label=x, value=x)
    }),
  value = 'Canada'
)

statisticDropdown <- dccDropdown(
  id = "statistic",
  # map/lapply can be used as a shortcut instead of writing the whole list
  # especially useful if you wanted to filter by country!
  options = map(
    unique(full_data$direction), function(x){
      list(label=x, value=x)
    }),
  value = 'Import'
)

yearSlider <- dccSlider(
  id = "year_value",
  min = 1988,
  max = 2018,
  marks = list(as.character(unique(full_data$year))),
  value = 2018
)

# Uses default parameters such as all_continents for initial graph
make_GDP_percent_graph <- function(country_shown = "Canada",
                       statistic = "Import"){

  #filter our data based on the stat/country selections
  data <- full_data %>%
    mutate('gdp_percent' = trade_usd/gdp) %>%
    filter(direction == statistic) %>%
    filter(country == country_shown)

  # make the plot!
  # on converting yaxis string to col reference (quosure) by `!!sym()`
  # see: https://github.com/r-lib/rlang/issues/116

  p1 <- ggplot(data, aes(x = year, y = gdp_percent)) +
    geom_bar(stat = "identity", colour = 'black', fill = 'orange') +
    ylab('% of GDP') +
    xlab('Year') +
    ggtitle(paste0(country_shown, " Weapons ", statistic, " share in GDP")) +
    theme_classic()

  p1

  ggplotly(p1)
}

make_USD_total_graph <- function(country_shown = "Canada",
                       statistic = "Import"){

  #filter our data based on the stat/country selections
  data <- full_data %>%
    filter(direction == statistic) %>%
    filter(country == country_shown)

  # make the plot!
  # on converting yaxis string to col reference (quosure) by `!!sym()`
  # see: https://github.com/r-lib/rlang/issues/116

  p2 <- ggplot(data, aes(x = year, y = trade_usd)) +
    geom_area(fill = 'orange', colour = 'black') +
    ylab('USD Value') +
    xlab('Year') +
    ggtitle(paste0(country_shown, " Weapons ", statistic, " value in USD")) +
    theme_classic()

  p2

  ggplotly(p2)
}

make_gdp_perc_year_graph <- function(statistic = "Import",
                                year_val = 2018) {

  # wrangling for this graph
  data <- full_data %>%
    mutate(perc_gdp = (trade_usd/gdp)*100) %>%
    arrange(desc(perc_gdp)) %>%
    filter(year == year_val,
           direction == statistic) %>%
    head(16)

  # make the plot
  p3 <- ggplot(data, aes(x = reorder(country, -perc_gdp), y = perc_gdp)) +
    geom_bar(stat = 'identity', colour = 'black', fill = 'orange') +
    theme_classic() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    labs(x = 'Country',
         y = 'Percentage of GDP') +
    ggtitle(paste0( statistic, "s as a Percentage of GDP in ", year_val))

  p3

  ggplotly(p3)
}

# Now we define the graph as a dash component using generated figure
graph_gdp_cont <- dccGraph(
  id = 'GDP_perc_country',
  figure=make_GDP_percent_graph() # gets initial data using argument defaults
)

graph_USD_cont <- dccGraph(
  id = 'USD_total_country',
  figure=make_USD_total_graph() # gets initial data using argument defaults
)

graph_perc_gdp <- dccGraph(
  id = 'Perc_GDP_graph',
  figure=make_gdp_perc_year_graph() # gets initial data using argument defaults
)

app$layout(
  htmlDiv(
    list(
      htmlH1('World Wide Arms and Ammunition Movement and GDP Effects'),
      htmlH3("This app is designed to explore how the movement of weapons globally has changed over the last 30 years, and how imports and exports of arms and ammunition relate to a country's GDP."),
      htmlP("Select a year to view cross-sectional data:"),
      yearSlider,
      htmlP("Select a statistic:"),
      statisticDropdown,
      graph_perc_gdp,
      htmlP("Select a country to view time-series data:"),
      countryDropdown,
      graph_gdp_cont,
      graph_USD_cont,
      htmlDiv(), #spacer
      dccMarkdown("[Data Source](https://cran.r-project.org/web/packages/gapminder/README.html)")
    )
  )
)

app$callback(
  #update figure of gap-graph
  output=list(id = 'GDP_perc_country', property='figure'),
  #based on values of year, continent, y-axis components
  params=list(input(id = 'country', property='value'),
              input(id = 'statistic', property='value')),
  #this translates your list of params into function arguments
  function(country_value, statistic_value) {
    make_GDP_percent_graph(country_value, statistic_value)
  })

app$callback(
  #update figure of gap-graph
  output=list(id = 'USD_total_country', property='figure'),
  #based on values of year, continent, y-axis components
  params=list(input(id = 'country', property='value'),
              input(id = 'statistic', property='value')),
  #this translates your list of params into function arguments
  function(country_value, statistic_value) {
    make_USD_total_graph(country_value, statistic_value)
  })

app$callback(
  #update figure of gdp-perc-year graph
  output=list(id = 'Perc_GDP_graph', property='figure'),
  params=list(input(id = 'statistic', property='value'),
              input(id = 'year_value', property='value')),
  #this translates your list of params into function arguments
  function(statistic_value, year_value) {
    make_gdp_perc_year_graph(statistic_value, year_value)
  })

app$callback(
  #update figure of gdp-perc-year graph
  output=list(id = 'Perc_GDP_graph', property='figure'),
  params=list(input(id = 'statistic', property='value'),
              input(id = 'year_value', property='value')),
  #this translates your list of params into function arguments
  function(statistic_value, year_value) {
    make_gdp_perc_year_graph(statistic_value, year_value)
  })

app$run_server()


print_factors <- function(x) {
print(paste("The factors of",x,"are:"))
for(i in 1:x) {
if((x %% i) == 0) {
print(i)
}
}
}


 ZGBCON Example Program Results

 Estimate of condition number =  1.04E+02


#!/usr/bin/env Rscript

set.seed(12)
n_runs <- 100
n_clusters <- 100
n_items <- 1000  # 10 per cluster

x <- runif(n_clusters)
y <- runif(n_clusters)

# 20 points per cluster
x <- x + rnorm(n_items, sd=0.01)
y <- y + rnorm(n_items, sd=0.01)

for (run in 1:n_runs) {
    cl <- kmeans(cbind(x,y), centers=n_clusters)

    m <- matrix(0, nrow=n_items, ncol=n_clusters)
    for (i in 1:n_items) {
        m[i, cl$cluster[i]] <- 1
    }
    write.table(m, file="largeK.txt", append=ifelse(run==1, F, T), quote=F, sep=" ", row.names=F, col.names=F)
    cat("\n", file="largeK.txt", append=T)
}


#rm(list=ls(all=TRUE))
results_fn="results/raw"
outtxt_fn="results-text.txt"

configs.threads=c(1:6)
configs.loop=1
configs.recursion=c(10)
configs.labels=c("No Probe","Inactive Probe","Collecting Data","Writing Data")
configs.count=length(configs.labels)
results.count=200000
results.skip=100000

for (threads in configs.threads) {
  resultsBIG <- array(dim=c(length(configs.recursion),configs.count,threads*configs.loop*(results.count-results.skip)),dimnames=list(configs.recursion,configs.labels,c(1:(threads*configs.loop*(results.count-results.skip)))))
  for (cr in configs.recursion) {
    for (cc in (1:configs.count)) {
      for (cl in (1:configs.loop)) {
        results_fn_temp=paste(results_fn, "-", cl, "-", threads, "-", cc, ".csv", sep="")
        for (ct in (1:threads)) {
          results=read.csv2(results_fn_temp,nrows=(results.count-results.skip),skip=(ct-1)*results.count+results.skip,quote="",colClasses=c("NULL","numeric"),comment.char="",col.names=c("thread_id","duration_nsec"),header=FALSE)
          resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(((cl-1)*threads*(results.count-results.skip)+1):(cl*threads*(results.count-results.skip)))] <- results[["duration_nsec"]]/(1000)
        }
        rm(results,results_fn_temp)
      }
    }
  }
  for (cr in configs.recursion) {
    printvalues = matrix(nrow=7,ncol=configs.count,dimnames=list(c("mean","ci95%","md25%","md50%","md75%","max","min"),c(1:configs.count)))
    for (cc in (1:configs.count)) {
      printvalues["mean",cc]=mean(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
      printvalues["ci95%",cc]=qnorm(0.975)*sd(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])/sqrt(length(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))]))
      printvalues[c("md25%","md50%","md75%"),cc]=quantile(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))],probs=c(0.25,0.5,0.75))
      printvalues["max",cc]=max(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
      printvalues["min",cc]=min(resultsBIG[(1:length(configs.recursion))[configs.recursion==cr],cc,c(1:(results.count-results.skip))])
    }
    resultstext=formatC(printvalues,format="f",digits=4,width=8)
    print(resultstext)
    write(paste("Threads: ", threads),file=outtxt_fn,append=TRUE)
    write("response time",file=outtxt_fn,append=TRUE)
    write.table(resultstext,file=outtxt_fn,append=TRUE,quote=FALSE,sep="\t",col.names=FALSE)
  }
}


#This script will find the shear modulus. You will need to change the initial guess and may need to adjust the window of data.
#
#
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#------------------------CSV file name here---------------------
shfile <- "your_file_name_here_sim_data_ShxyData.csv"

#-------------------Read in csv file-----------------------------
shfilename <- strsplit(shfile,"\\.")[[1]]
shdat <- read.csv(shfile)

#create vectors for stress and strain
shstress <- shdat[,1]
shstrain <- shdat[,2]

#Create new vectors containing data before chain slippage, change accordingly.
shendpoint <- length(shstrain)
shstress <- shstress[1:shendpoint]
shstrain <- shstrain[1:shendpoint]

#fit a regular linear model to stress-strain data, this is for the segmented command
lin.mod <- lm(shstress ~ shstrain)

#use segmented package to calculated breakpoint(s), for multiple use c(value,value) after psi=
#Young's modulus, value for psi is guess
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~shstrain, psi=0.02)

#Extract coefficients
#Set more breaks to 1 if multiple breakpoints are needed
morebreaks <- 0

#Shear modulus average and standard error
sh_value <- summary(segmented.mod)$coefficients[2,1]
sh_stderror <- summary(segmented.mod)$coefficients[2,2]
if (morebreaks == 1) {
  sh_strainvalue1 <- segmented.mod$psi[3]
  sh_strainvalue2 <- segmented.mod$psi[4]
} else {
  sh_strainvalue <- segmented.mod$psi[2]
}

#This is used in the shear modulus plot
modulus_value <- round(sh_value/1000,digits=1)  # To get it into GPa

#Intercept of line
sh_intercept <- summary(segmented.mod)$coefficients[1,1]
sh_intstderror <- summary(segmented.mod)$coefficients[1,2]

#Write matrix
if (morebreaks == 1) {
  df_shps <- data.frame(sh_value,sh_stderror,sh_strainvalue1,sh_strainvalue2,sh_intercept,sh_intstderror)

} else {
  df_sh <- data.frame(sh_value,sh_stderror,sh_strainvalue,sh_intercept,sh_intstderror)
}
#Write coefficients to file
write.table(df_sh,file=paste(shfilename[1],"txt",sep="."),sep="\t")

# Get point at sh_value
sh_value <- segmented.mod$psi[2]
sh_value_stderror <- segmented.mod$psi[3]
sh_y_value <- segmented.mod$coefficients[2]*sh_value+segmented.mod$coefficients[1]

#Plot breakpoint analysis for shear modulus
pdf(paste(shfilename[1],"pdf",sep="."))
plot(shstrain,shstress,col="blue",xlim=c(0,max(shstrain)),ylim=c(min(shstress),max(shstress)),main = paste("Shear Modulus=",modulus_value,"GPa"),xlab = 'True Strain',ylab = 'True Stress (MPa)')
par(new = TRUE)
plot(segmented.mod,col="red",xlim=c(0,max(shstrain)),ylim=c(min(shstress),max(shstress)),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(sh_value,sh_y_value,pch=24,col="black",bg="black",xlim=c(0,max(shstrain)),ylim=c(min(shstress),max(shstress)),xlab = '',ylab = '')
dev.off()


## Setup R error handling to go to stderr
options(show.error.messages = F,
            error = function() {
                cat(geterrmessage(), file = stderr()); q("no", 1, F)
            }
       )
warnings()
library(optparse)
library(ggplot2)
library(reshape2)

option_list <- list(
    make_option(c("-i", "--input"), type = "character", help = "Path to dataframe"),
    make_option(c("-t", "--title"), type = "character", help = "Main Title"),
    make_option("--xlab", type = "character", help = "X-axis legend"),
    make_option("--ylab", type = "character", help = "Y-axis legend"),
    make_option("--sample", type = "character", help = "a space separated of sample labels"),
    make_option("--method", type = "character", help = "bedtools or pysam"),
    make_option(c("-o", "--output"), type = "character", help = "path to the pdf plot")
    )

parser <- OptionParser(usage = "%prog [options] file", option_list = option_list)
args <- parse_args(parser)
samples <- substr(args$sample, 2, nchar(args$sample) - 2)
samples <- strsplit(samples, ", ")

# data frames implementation

table <- read.delim(args$input, header = F)
headers <- c("chromosome", "start", "end", "id")
for (i in seq(1, length(table) - 4)) {
    headers <- c(headers, samples[[1]][i])
colnames(table) <- headers
}

## function
if (args$method == "bedtools") {
    cumul <- function(x, y) sum(table[, y] / (table$end - table$start) > x) / length(table$chromosome)
    } else {
    cumul <- function(x, y) sum(table[, y] > x) / length(table$chromosome)
    }
scale_fun <- function(x) sprintf("%.3f", x)

## end of function
## let's do a dataframe before plotting
if (args$method == "bedtools") {
    maxdepth <- trunc(max(table[, 5:length(table)] / (table$end - table$start))) + 20
    } else {
    maxdepth <- trunc(max(table[, 5:length(table)])) + 20
    }

graphpoints <- data.frame(1:maxdepth)
i <- 5
for (colonne in colnames(table)[5:length(colnames(table))]) {
    graphpoints <- cbind(graphpoints,  mapply(cumul, 1:maxdepth, rep(i, maxdepth)))
    i <- i + 1
    }
colnames(graphpoints) <- c("Depth", colnames(table)[5:length(table)])
maxfrac <- max(graphpoints[, 2:length(graphpoints)])

graphpoints <- melt(graphpoints, id.vars = "Depth", variable.name = "Samples", value.name = "sample_value")

## GRAPHS

pdf(file = args$output)
ggplot(data = graphpoints, aes(x = Depth, y = sample_value, colour = Samples)) +
      geom_line(size = 1) +
      scale_x_continuous(trans = "log2", breaks = 2 ^ (seq(0, log(maxdepth, 2)))) +
      scale_y_continuous(breaks = seq(0, maxfrac, by = maxfrac / 10), labels = scale_fun) +
      labs(x = args$xlab, y = args$ylab, title = args$title) +
      theme(legend.position = "top", legend.title = element_blank(),
            legend.text = element_text(colour = "blue", size = 7))

devname <- dev.off()


function(dlist, sjs=NA){
#This function reads a list object containing data from a
#Crazy Beliefs experiment, in the format read in by
#get.data. Each element of the list corresponds to a different
#subject, and contains a sub-list with that subject's data.
#
#This function fits, for each subject in dlist, a logistic curve to
#their test 1 and test 2 performance and stores the parameters, including
#slope, intercept, and boundary, in an output matrix.
#
#dlist is the data list containing subject data
#sjs us a list of subjects to include in the analysis.

if(is.na(sjs)){                #if sjs is not specified, include all sjs
	nitems<-length(dlist)  # and set nitems to the number of subjects
	sjs <- 1:nitems}
else nitems<-length(sjs)

t1 <- matrix(0, nitems,2)	#create two temporary matrices to hold
t2<-t1				#test 1 and test 2 paramter estimates

#create temporary matrix to hold other data
cond<-matrix(c("E","E","E","0","E"), nitems, 5, byrow=T)

#Loop over subjects to get logistic parameters estimates for
#test 1 and test 2
for(i1 in c(1:nitems)){
	sdat <- dlist[[sjs[i1]]] #pull out data for current subject
	tmod1<- glm(acc~Pic, data = sdat[[2]], family="binomial") 	#fit test 1 model
	tmod2<- glm(acc~Pic, data = sdat[[4]], family="binomial") 	#fit test 2 model
	t1[i1,]<-tmod1$coefficients 					#store test 1 coefficients
	t2[i1,]<-tmod2$coefficients					#store test 2 coefficients
	cond[i1,]<-as.matrix((sdat[[1]])[1,1:5])			#pull out other info about this sj and condition
    print(paste("Processing sj:", i1))
	}								#and store in cond matrix

b1<- -1 * t1[,1]/t1[,2]		#estimate boundary for test 1
b2<- -1 * t2[,1]/t2[,2]		#estimate boundary for test 2

cond<-as.data.frame(cond)	#convert cond matrix to data-frame object

out<-as.data.frame(cbind(cond,t1,b1,t2,b2)) #glue condition, t1, and t2 matrices together in data frame
names(out)<-c("axlab","noingrp","closebound","sno","FaceLeft","t1int","t1slope","t1bound","t2int","t2slope","t2bound") #name columns

out$closebound <- as.numeric(as.character(out$closebound))  #Change field type to numeric instead of factor
cbside <- rep("left", times = nitems) #initialize close-bound-size vector
cbside[out$closebound > 150] <- "right"  #change side label to right if close bound was above 150
out <- cbind(out[,1:3], cbside, out[4:11])

bshift <- b2 - b1		#compute shift in boundary
alshift <- bshift		#copy bshift to alshift

#Flip direction for subjects with close source at 135
#so positive numbers mean toward pole where source resides (aligned shift)
alshift[out$closebound==135] <- bshift[out$closebound==135] * -1

out<-cbind(out, bshift, alshift) #glue boundary shift data to output dataframe

Zalshift <- (out$alshift - mean(out$alshift))/sqrt(var(out$alshift))  #compute Zscore for alshift across all conditions

#Compute Zscore for alshift separately for each boundary condition
#Zmsbycond <- rep(0, times = nitems) #make zero vector to hold data
#for(i1 in levels(out$bounds)){
#        mscond <- out$alshift[out$bounds==i1] #pull out data for current condition#
#	Zmsbycond[out$bounds == i1] <- (mscond - mean(mscond))/sqrt(var(mscond))  #compute zscores for current condition
#       }
out<-cbind(out, Zalshift) #glue Zscores onto ouput data frame
out <- cbind("one15", out) #Add column to indicate the experiment condition (one close)
names(out)[1]<-"cond"  #name that column
PID <- paste(out$cond, substring(out$axlab,4,4), out$closebound, out$sno, sep="_")  #Make unique participant ID vector
t1dist <- as.numeric(as.character(out$closebound)) - out$t1bound  #Compute distance of t1bound to close source
out <- cbind(PID, out)   #Add PID vector to output matrix
out <- cbind(out, t1dist)   #Add PID vector to output matrix
out <- out[,c(1:3, 5:18)] #Remove the "number in group" field which is always the same
out #output result
}


library('acepack')
library('stats')

compute_pairwise_ace <- function(df, num_features, cat_features) {
    for (col in cat_features) {
        df[, col] = as.numeric(df[, col])
    }
    df = df[, c(cat_features, num_features)]
    n = ncol(df)
    n_cat = length(cat_features)
    result = c()
    for (i in seq(1, n - 1)) {
        y = df[, i]
        x = df[, (i + 1):n]
        cat_indexes = seq(1, n_cat - i + 1, length = max(0, n_cat - i + 1))
        a = ace(x, y, cat = cat_indexes)
        acescores = cor(a$tx, a$ty)
        result = c(result, rep(0, i-1), 1, acescores)
    }
    result = c(result, rep(0, n-1), 1)
    result = matrix(result, n, n)
    result = result + t(result) - diag(1, n, n)
    return (result)
}


langton.ant = function(n = 100) {
	map = matrix(data = 0, nrow = n, ncol = n)
	p = floor(c(n/2, n/2))
	d = sample(1:4, 1)
	i = 1
	while(p[1] > 0 & p[1] <= n & p[2] > 0 & p[2] <= n) {
		if(map[p[1], p[2]] == 1) {
			map[p[1], p[2]] = 0
			p = p + switch(d, c(0, 1), c(-1, 0), c(0, -1), c(1, 0))
			d = ifelse(d == 4, 1, d + 1)
		} else {
			map[p[1], p[2]] = 1
			p = p + switch(d, c(0, -1), c(1, 0), c(0, 1), c(-1, 0))
			d = ifelse(d == 1, 4, d - 1)
		}
	}
	return(map)
}

image(langton.ant(), xaxt = "n", yaxt = "n", bty = "n")


#
# Predictor using moving average
#
Predictor <- function(windowSize) {
    library(TTR)
    yVals <- c()
    learnClosed <- FALSE
    f <- NULL
    windowSize <- windowSize

    clean <- function() {
        learnClosed <<- FALSE
        yVals <<- c()
        f <<- NULL
    }

    learn <- function(y) {
        yVals <<- append(yVals, y)
    }

    forecast <- function() {
        if(!learnClosed) {
            learnClosed <<- TRUE
            f <<- SMA(yVals, windowSize)
        }

        return(f[length(f)])
    }

    return(list(forecast=forecast, learn=learn, clean=clean))
}


###Load packages
library(ggpubr)
library(readxl)
##############------------------Dominance score for supplementary Figure S4A----------------------------------
snv <- read_xlsx("Supplementary Table 2.Somatic mutations in our SCLC cohort", sheet="Sheet1",skip=1)
snv <- as.data.frame(snv, stringsAsFactors = F)

sclc_driver <- read.delim("~/TCGA/Mutated_Genes_SCLC_239P_cBioportal.txt",header=T,fill=T,stringsAsFactors=F)
colnames(sclc_driver) <- c("gene","q","mut","mut_patient","Freq","cosmic")
sclc_driver$Freq <- as.numeric(gsub("%","",sclc_driver$Freq))
sclc_driver <- sclc_driver[which( sclc_driver$Freq >=5),]

cosmic <- read.delim("~/Census_allThu_Mar_19_09_31_24_2020.tsv",stringsAsFactors=F)

sclc_driver_snv <- snv[which((snv$Hugo_Symbol %in% sclc_driver$gene) | (snv$Hugo_Symbol %in% cosmic$Gene.Symbol)),]

sclc_driver_snv2 <- tidyr::separate(sclc_driver_snv, col="Tumor_Sample_Barcode", into=c("pid","sid"),sep="-")

pid_gene <- unique(sclc_driver_snv2[,c("pid","Hugo_Symbol")])

#Di is the dominance score for gene i,
#Ni is the number of patients carrying non-silent mutations in gene i
#while dj is the number of LUAD driver mutations in patient j. Di=(Sum(1/dj))/Ni
#Ocurrence calculatoin	frequency of patients carrrying that driver mutation
##Gene dominant.score occurrence

##dj calculation
dj <- as.data.frame(table(pid_gene$pid))
dj$ratio <- 1/dj$Freq

##Ni calculation
gene.freq <- as.data.frame(table(pid_gene$Hugo_Symbol))
##
gene.freq$Occurrence <- gene.freq$Freq/40

##
Di <- NULL
for (i in gene.freq$Var1){
Ni <- gene.freq$Freq[gene.freq$Var1==i]
pid_tmp <- pid_gene$pid[pid_gene$Hugo_Symbol==i]

	dj_tmp <- dj$ratio[dj$Var1%in%pid_tmp]
	sum_dj <- sum(dj_tmp)
	sum_dj <- as.numeric(sum_dj)

	Di_tmp <- c(as.character(gene.freq$Var1[gene.freq$Var1==i]),sum_dj/Ni)
	Di <- rbind(Di,Di_tmp)
}

Di <- as.data.frame(Di,stringsAsFactors=F)
rownames(Di) <- Di[,1]
colnames(Di) <- c("Gene","Dominant.score")
dij <- merge(gene.freq, Di, by.x="Var1", by.y="Gene",all=T, no.dups=T)
dij$Dominant.score <- as.numeric(dij$Dominant.score)
colnames(dij)[1] <- "Gene"

dij.p <- dij[dij$Gene%in%cosmic$Gene.Symbol,]
dij.p$name <- ""
dij.p$name[(dij.p$Occurrence >=0.25) | (dij.p$Dominant.score>=0.03)] <- as.character(dij.p$Gene[(dij.p$Occurrence >=0.25) | (dij.p$Dominant.score>=0.03)])

##plot

ggscatter(dij.p, "Occurrence", "Dominant.score", color="Occurrence",label = "name", repel = TRUE, ylab="Driver dominant score",main="SCLC")

## To observe the drivers in LUAD
luad_driver <- read_xlsx("~/41586_2014_BFnature13385_MOESM21_ESM.xlsx",sheet="S_Table 4-MutSig2CV List",skip=2)
luad_sigs <- luad_driver$Gene[luad_driver$`Bonferroni p-value` < 0.025]

luad_snv <- read_xlsx("~/41586_2014_BFnature13385_MOESM21_ESM.xlsx",sheet="S_Table 5-Verification",skip=2)

luad_snv2 <- luad_snv[luad_snv$"Validation Judgement"==1,c("Hugo Symbol","Tumor Sample Barcode")]
luad_snv2 <- as.data.frame(luad_snv2)
pid_gene <- unique(luad_snv2)
colnames(pid_gene) <- c("Hugo_Symbol","pid")
##dj
dj <- as.data.frame(table(pid_gene$pid))
dj$ratio <- 1/dj$Freq

##Ni calculation
gene.freq <- as.data.frame(table(pid_gene$Hugo_Symbol))
##
gene.freq$Occurrence <- gene.freq$Freq/length(unique(pid_gene$pid))

##
Di <- NULL
for (i in gene.freq$Var1){
Ni <- gene.freq$Freq[gene.freq$Var1==i]
pid_tmp <- pid_gene$pid[pid_gene$Hugo_Symbol==i]

	dj_tmp <- dj$ratio[dj$Var1%in%pid_tmp]
	sum_dj <- sum(dj_tmp)
	sum_dj <- as.numeric(sum_dj)

	Di_tmp <- c(as.character(gene.freq$Var1[gene.freq$Var1==i]),sum_dj/Ni)
	Di <- rbind(Di,Di_tmp)
}

Di <- as.data.frame(Di,stringsAsFactors=F)
rownames(Di) <- Di[,1]
colnames(Di) <- c("Gene","Dominant.score")
dij <- merge(gene.freq, Di, by.x="Var1", by.y="Gene",all=T, no.dups=T)
dij$Dominant.score <- as.numeric(dij$Dominant.score)
colnames(dij)[1] <- "Gene"

ggscatter(dij, "Occurrence", "Dominant.score", color="Occurrence", ylab="Driver dominant score",main="LUAD")

dij$name <- ""
dij$name[(dij$Occurrence >=0.3) | (dij$Dominant.score>=0.3)] <- as.character(dij$Gene[(dij$Occurrence >=0.3) | (dij$Dominant.score>=0.3)])
##plot
ggscatter(dij, "Occurrence", "Dominant.score", color="Occurrence",label = "name", repel = TRUE, ylab="Driver dominant score",main="LUAD")

### To observe the drivers in LUSC
lusc_snv <- read_xls("~/nature11404-s2/data.file.S7.5.clinical.and.genomic.data.table.xls",sheet="LUSC_CpG_Filtered.patients.coun",range=cell_cols("N:BF"))
lusc_snv <- lusc_snv[-1,]
colnames(lusc_snv) <- lusc_snv[1,]
lusc_snv <- lusc_snv[-1,]
head(lusc_snv)
lusc_snv <- as.data.frame(lusc_snv)

ff <- function(x){sum(!is.na(x))}
gene.freq <- apply(lusc_snv,2,ff)
gene.freq <- as.data.frame(gene.freq)
gene.freq$Occurrence <- gene.freq$gene.freq/178
gene.freq <- gene.freq[-1,]
gene.freq$Var1 <- rownames(gene.freq)

rownames(lusc_snv) <- lusc_snv$`Tumor ID`
lusc_snv <- lusc_snv[,-1]
dj <- apply(lusc_snv,1,ff)
dj <- as.data.frame(dj)
dj$ratio <- 1/dj$dj
dj$pid <- rownames(dj)
###

Di <- NULL
for (i in gene.freq$Var1){
Ni <- gene.freq$gene.freq[gene.freq$Var1==i]

pid_tmp <- rownames(lusc_snv)[colnames(lusc_snv)==i]

	dj_tmp <- dj$ratio[dj$pid%in%pid_tmp]
	sum_dj <- sum(dj_tmp)
	sum_dj <- as.numeric(sum_dj)

	Di_tmp <- c(as.character(gene.freq$Var1[gene.freq$Var1==i]),sum_dj/Ni)
	Di <- rbind(Di,Di_tmp)
}

Di <- as.data.frame(Di,stringsAsFactors=F)
rownames(Di) <- Di[,1]
colnames(Di) <- c("Gene","Dominant.score")
dij <- merge(gene.freq, Di, by.x="Var1", by.y="Gene",all=T, no.dups=T)
dij$Dominant.score <- as.numeric(dij$Dominant.score)
colnames(dij)[1] <- "Gene"

ggscatter(dij, "Occurrence", "Dominant.score", color="Occurrence", ylab="Driver dominant score",main="LUSC")

dij$name <- ""
dij$name[(dij$Occurrence >=0.2) | (dij$Dominant.score>=1.0)] <- as.character(dij$Gene[(dij$Occurrence >=0.2) | (dij$Dominant.score>=1.0)])

ggscatter(dij, "Occurrence", "Dominant.score", color="Occurrence",label = "name", repel = TRUE, ylab="Driver dominant score",main="LUSC")


# this command will install seewave as well as its deps,
# tuneR and signal :)
#install.packages("seewave")
# this is needed to deal with big files.
# this won't do anything if you're using RStudio:
# instead, see these instructions:
# https://stackoverflow.com/a/52612921
#Sys.setenv('R_MAX_VSIZE'=32000000000)

# IMPORTS
library(tuneR)
library(seewave)

# OPTIONS
setwd("~/OWL/Data/SWIFT/SWIFT1/SWIFT1_2019-04-21")
freq = 48000
minHZ = 100
maxHZ = 800

# FILENAMES TO PROCESS
filenames <- list.files(pattern = "\\.wav$", ignore.case=TRUE)
cat("Scanning files:", filenames)

# PROCESS FILES
for (fn in filenames) {
  cat("Input:", fn, "\n")
  outfn <- paste('filtered', fn, sep = '_')
  wave <- readWave(fn)
  fwave <- ffilter(wave, f = freq, from = minHZ, to = maxHZ, bandpass = TRUE)
  savewav(fwave, f = freq, filename = outfn)
  cat("Output:", outfn, "\n")
}


# NETWORK ANALYSIS
#install.packages(c("SpiecEasi","parallelDist","Matrix","Rtsne","TSP","gmodels","igraph","parallel"))
library(SpiecEasi) # for sparcc, spieceasi
library(parallelDist) #for parDist
library(Matrix) #for tril
library(Rtsne) #for Rtsne
library(TSP) #for TSP
library(gmodels) #for fast.prcomp
library(igraph) #for components
library(parallel) #for detectCores
source("FastPCA.R")
library(reshape2)

source("microscape-s00-setup.r")

options(menu.graphics=FALSE)

#output.path
outfolder <- "out_dada"

# read from disk
normtab <- readRDS(file.path(outfolder,"normtab_filt.rds")) #

# run parallel sparcc
# sparcc.out <- parsparcc(proptab, iter=detectCores()-1, inner_iter=5, th=0.1)
# sparcc.out <- parsparcc(proptab, iter=7, inner_iter=15, th=0.1) #crashed
# for computational sake, only compute correlations on sequences present in at least 5 samples (9472/19073 = 50%)
# crashed after n=21 with cores=13
# n=9 cores=5 took 10 hours
# n=5 cores=5 ran out of memory at i=5
# bonk should use a consistent number of iterations
# n=5 i=5 cores=1 took 43 hours
# new merged samples:
# crashed after n=19 with cores=13
# approximate time in days to complete: y = 121.3x^-2.209
#     #sparcc.out <- sparcc(proptab, iter=15, inner_iter=15, th=0.1)

# do subset based on TSNE clustering ?

#i is minimum number of samples
#crashed at i=45, iter=20, inner=20, th=0.1, cores=13
for(i in seq(75,5,-10)) {
    normtab_small <- normtab[,colSums(normtab>0)>i]  ### THIS MEANS I NEED TO SAVE THE NAMES WITH THE NETWORK_MELT BELOW
	small.cols <- match(colnames(normtab_small),colnames(normtab))
	small.esvs <- paste0("ESV_",small.cols)
    print(date())
    print(i)
    print(dim(normtab_small))
    sparcc.out <- parsparcc(normtab_small, iter=20, inner_iter=20, th=0.1, cores=13)
    saveRDS(sparcc.out,file=file.path(outfolder,paste0("sparcc_out_",i,".rds")))

	# Cluster sequences using sparcc correlations
	seq.sparcc.dist <- sparcc.out$Cor
	rownames(seq.sparcc.dist) <- small.esvs
	colnames(seq.sparcc.dist) <- small.esvs
	seq.sparcc.dist[is.na(seq.sparcc.dist)] <- 1
#	seq.sparcc.pca <- fast.prcomp(seq.sparcc.dist)
	seq.sparcc.pca <- FastPCA(seq.sparcc.dist,50)
	seq.sparcc.pca.uniq <- unique(seq.sparcc.pca$x)
	seq.tsne.sparcc.list <- Rtsne(seq.sparcc.pca.uniq,verbose=TRUE, theta=0.5, max_iter=2000, pca=FALSE)
	seq.tsne.sparcc <- seq.tsne.sparcc.list$Y
	if(!identical(seq.sparcc.pca$x,seq.sparcc.pca.uniq)) {
		seq.tsne.sparcc.full <- addDups(seq.sparcc.dist, seq.tsne.sparcc)
	} else {
		seq.tsne.sparcc.full <- seq.tsne.sparcc
	}
	# reorder based on clustering using traveling salesperson algorithm
	seq.tsne.sparcc.dist <- dist(seq.tsne.sparcc.full)
	seq.tsp.sparcc <- solve_TSP(TSP(seq.tsne.sparcc.dist))
	seq.tsp.sparcc.ind <- c(seq.tsp.sparcc, seq.tsp.sparcc[1])
	plot(seq.tsne.sparcc.full, pch='.', main="Sequence SparCC")
	lines(seq.tsne.sparcc.full[seq.tsp.sparcc.ind,])

	rownames(seq.tsne.sparcc.full) <- small.esvs

	saveRDS(seq.sparcc.dist,file.path(outfolder,"seq_sparcc_dist.rds"))
	saveRDS(seq.sparcc.pca,file.path(outfolder,"seq_sparcc_pca.rds"))
	saveRDS(seq.tsne.sparcc.full,file.path(outfolder,"seq_sparcc_tsne.rds"))
	saveRDS(seq.tsp.sparcc,file.path(outfolder,"seq_sparcc_tsp.rds"))

	# vastly simplified by just saving vectors of weights and colors instead of the whole graph
	# four columns sorted by correlation: node1, node2, correlation, weight

	network_correlations <- sparcc.out$Cor
	network_matrix <- as.matrix(Matrix::tril(network_correlations) + t(Matrix::tril(network_correlations)))/2 #to make it symmetric so igraph doesn't crash

    network_melt <- melt(network_matrix)
    colnames(network_melt) <- c("node1","node2","corr")
    network_melt <- network_melt[network_melt$node1 > network_melt$node2, ]
    network_melt <- network_melt[abs(network_melt$corr)>0.1,]
    network_melt$weight <- network_melt$corr^3/max(abs(network_melt$corr)^3)
    network_melt$color[network_melt$corr<0] <- rgb(abs(network_melt$weight[network_melt$corr<0]),0,0,abs(network_melt$weight[network_melt$corr<0]))
    network_melt$color[network_melt$corr>=0] <- rgb(0,0,abs(network_melt$weight[network_melt$corr>=0]),abs(network_melt$weight[network_melt$corr>=0]))
	network_melt$node1 <- small.esvs[network_melt$node1]
	network_melt$node2 <- small.esvs[network_melt$node2]

	saveRDS(network_melt, file.path(outfolder, "network_melt.rds"))

   }

# at i=75
# > dim(network_melt)
# [1] 18724     5

# at old i=19
# >     print(dim(normtab_small))
# [1] 2191 3123

# 	# save a graph at each cutoff
# 	save.graphs <- list()
# 	for(i in 100:1) {
# 		cutoff <- i/100
# 		print(cutoff)
#
# 		# define graph
# 		network_matrix <- abs(network_correlations) > cutoff
# 		diag(network_matrix) <- 0
# 		if(sum(network_matrix)==0) { save.graphs[[as.character(i)]] <- NULL; print("done"); next }
#
# 		network_matrix <- as.matrix(Matrix::tril(network_matrix) + t(Matrix::tril(network_matrix))) #to make it symmetric so igraph doesn't crash
#
# 		network_graph <- adj2igraph(network_matrix)
#
# 		save.graphs[[paste0("cor_",as.character(i))]] <- network_graph
# 	}
# 	saveRDS(save.graphs, file.path(outfolder,"network_graphs.rds")) #730Mb each... must be a better way but for now...
#
# 	# save the edge weights at each cutoff
# 	save.weights <- list()
# 	for(i in 100:1) {
# 		print(i)
# 		network_graph <- save.graphs[[paste0("cor_",as.character(i))]]
# 		if(is.null(network_graph)) next
# 		#define weights and colors
# 		# network_matrix inherits from i=1 above
# 		network_weights <- (network_matrix & upper.tri(network_matrix))*network_correlations
#
# 		#scale the weights
# 		E(network_graph)$weight <- network_weights[abs(network_weights) > cutoff]^3 # cubed preserves sign
# 		#recenter the weights
# 		E(network_graph)$weight <- E(network_graph)$weight/max(abs(E(network_graph)$weight))
# 		#color the rescaled weights
# 		E(network_graph)$color <- rgb(0,0,0,0)
# 		network_neg <- E(network_graph)$weight < 0
# 		network_pos <- E(network_graph)$weight > 0
# 		E(network_graph)$color[network_neg] <- rgb(abs(E(network_graph)$weight[network_neg]),0,1,abs(E(network_graph)$weight[network_neg]))
# 		E(network_graph)$color[network_pos] <- rgb(0,0,abs(E(network_graph)$weight[network_pos]),abs(E(network_graph)$weight[network_pos]))
# 		network_weights[network_weights==1] <- 0
#
# 		save.weights[[paste0("cor_",as.character(i))]] <- network_weights
# 	}
# 	saveRDS(save.weights, file.path(outfolder,"network_weights.rds"))
#

# }


library("randomForest")

# RandomForest
dm_model <- randomForest(dm_model_formula, ntree=100, mtry=5, data=dm_traindf, importance=TRUE)

# Score
pred <- predict(dm_model, dm_inputdf, type="prob")
dm_scoreddf <- data.frame(pred)
colnames(dm_scoreddf) <- c("P_BAD0", "P_BAD1")

# Print/plot model output
png("rpt_forestMsePlot1.png")
plot(dm_model, main='randomForest MSE Plot')
legend("topright", colnames(dm_model$err.rate),col=1:3,cex=0.8,fill=1:3)
dev.off()

write.csv(importance(dm_model),
          file="rpt_forestIMP.csv",
          row.names=TRUE)


logistic.display.local = function (logistic.model, alpha = 0.05, decimal = 5)  {

    model <- logistic.model

    if (class(model)[1] != "glm" | class(model)[2] != "lm" |
        model$family$family != "binomial") {
        stop("model not from logistic regression")
    }

    s0 = Anova(model)
    s1 <- summary(model)

    orci <- as.data.frame(s1$coefficients)

    colnames(orci) <- c("OddsRatio", paste("Lower", 100 - 100 * alpha,
        "CI", sep = ""), paste("Upper", 100 - 100 * alpha, "CI",
        sep = ""), "P-value")

    orci[, 3] <- exp(orci[, 1] + qnorm(1 - alpha/2) * orci[, 2])
    orci[, 2] <- exp(orci[, 1] - qnorm(1 - alpha/2) * orci[, 2])
    orci[, 1] <- exp(orci[, 1])

    a <- orci[rownames(orci) != "(Intercept)", ]
    a$LogLikelihood = as.numeric(logLik(model))
    a$N = length(model$y)
    a$AIC = s1$aic
    a$deviance = s1$deviance
    a$Chisq.LogRatio = s0$"LR Chisq"
    a$Chisq.df = s0$Df
    a$Chisq.Pvalue = s0$"Pr(>Chisq)"

    a = round(a, decimal)

    a$Level = rownames(a)

    return(a)
}


#' This function is used to predict the total reported as well as unreported case counts, total recovered and total deaths
#'
#' @param data  (Mandatory) input : Mainly the training dataset. If the model is Multinomial then the data matrix should contain 3 columns namely Confirmed,Recovered and Death, while if the model is Poisson or Binomial, then the data should contain only one column namely Confirmed. Please see that the names of the colums are maintained.
#' @param data_init (Mandatory) This is the initial data values that should be provided by the user which is a six size length vector. The first entry should contain the Total Confirmed, Total Recovered ,Total Death , Daily Confirmed ,Daily Recovered and Daily Death for the Starting Date. If the starting total confirmed is 0 , please replace it by 1.
#' @param init_pars  = NULL( default) . Else the user can give a user input initial paramters which should consist of the initial values of the time varying beta , proportion of testing for the different periods.
#' @param N (Mandatory) : The population size.
#' @param plot =TRUE . If estimate = FALSE , this will give two plots , one is the panel plot for total cases, total recovered, total death and total confirmed if the model is Multinomial , else it will give only a plot for total confirmed when the model is binomial or poisson and the second plot is the plot of untested, false negative and reported cases. And when estimate=  TRUE , then it will give two other plots along with the previous two plots. One is the box plot for basic reproduction number and the other one is the trace plot for the convergence of the mcmc paramters.
#' @param T_predict  It is the no of days that we want to predict after the train period. The value of T_predict should be atleast greater than equal to  the no of rows for the data_test.
#' @param period_start The total time period is divided into small periods depending on the lockdowm measures imposed by the goverment. So this is a vector consisting of the start dates for the different time periods.
#' @param estimate = TRUE (default) If it is TRUE then it will run the MCMC algorithm to estimate the parameters. Else if it is FALSE then the user needs to give input the paramter values in the pars argument.
#' @param pars = NULL (default) .If estimate = FALSE, then the user need to give input the paramter estimates .
#' @param data_test = NULL ( default). Else the person needs to give to give the test data for comparing with the model estimates.
#' @param auto.initialize = TRUE(default) This is the option for using a mle based initial parameter.
#' @param ... arguments passed to the function model_estimateR, model_initializeR and model_plotR which is used for the initializing the parameters. The parameters are described below:
#'            \itemize{
#'                 \item{"niter"}{= 1e5 (default)  No of iteration for the MCMC metropolis hasting algorithm.}
#'                 \item{"BurnIn"}{ = 5e4 (default) This is the Burn-In Period for the MCMC algorithm}
#'                 \item{"model"} {= Multinomial(DEFAULT) This is the likelihood function that will be used. There are three options available namely Multinomial, Poisson and Binomial.}
#'                 \item{"alpha_p"}{= 0.5 (default) It is defined as the ratio of rate of spread of infection by tested positive patients to that by false negatives. We have taken $\alpha_p < 1$ as patients who are tested positive are subjected to quarantine where the chance of spreading the disease is less than that of false negative patients who are mostly unaware of their infectious nature. So, false negative individuals continue to spread the disease freely at a higher rate than tested positive individuals. }
#'                 \item{"alpha_u"}{= 0.7 (default) It is defined as the  scaling factor for the rate of spread of infection by untested individuals. $\alpha_u$ is assumed to be < 1 as U mostly consists of asymptomatic or mildly symptomatic cases who are known to spread the disease at a much lower rate than those with higher levels of symptoms.}
#'                 \item{"beta_1 }{= 0.6 (default) . It is the scaling factor for rate of recovery  for untested individuals .  $\beta_1$ is  assumed to be less than 1.  The condition of Untested individuals is not so severe as they consists of mostly asymptomatic people. So, they are assumed to recover faster than the Current Positive Ones. }
#'                 \item{"beta_2"}{= 0.7 (default) . It is the inverse of the scaling factor for rate of recovery  for false negative individuals .  $\beta_2$ is assumed to be less than 1. It is assumed that the recovery rate is slower than the detected ones for the False Negative ones because they are not getting any hospital treatments. }
#'                 \item{"delta_1}{= 0.3 (default) It is the scaling factor for death rate for undetected individuals .  $\delta_1 $ is assumed to be less than 1. Similarly  for the Untested ones, the death rate is taken to be lesser because they are mostly asymptomatic. So, their probability of dying is much less.}
#'                 \item{"delta_2"}{= 0.7 (default). It is the inverse of  the scaling factor for death rate for false negative individuals . $\delta_2$ is assumed to be less than 1. Same as before, the death rate for False Negative ones are assumed to be higher than the Current detected Positive as they are not receiving proper treatment.}
#'                 \item{"lambda"}{=  1 / (66.26 * 365)(default) Natural birth  rate. The value given here as the default value is the world's common birth  rate.}
#'                 \item{"mu"}{=  1 / (66.26 * 365)(default) Natural  death rates. This is assumed to be equal with natural birth rate for the sake of simplicity.}
#'                 \item{"D_e"}{= 5.2 (default) Incubation period .}
#'                 \item{"Dr"}{= 17.8 (default) Mean days till recovery for positive individuals.}
#'                 \item{"f"}{=0.15 (default) False negative probability of RT-PCR test.}
#'                 \item{"mCFR"}{= NULL (It is calculated from the data  by default) It is defined as the ratio of the total reported deceased cases and the total removed cases  till that day.}
#'                 \item{"init.exposed.ratio "}{= 3 (default) This is the scaling factor for the calculation of the initial number of exposed people from the sum of the initial number of unreported, repoted people.}
#'                 \item{"init.confirmed.ratio"}{= 0.15 (default) This is the initial value of the probability of being tested.}
#'                 \item{"opt_num"}{= 100 (default) The number of times an user wants to run the mle optimization before deciding on the best initial parameter.}
#'                 \item{"trace_plot.common_axis"}{=FALSE(Default) This will give the trace plot for  the convergence of the mcmc estimated time varying parameters}
#'                 \item{"save plot"}{=TRUE (Default) It is the option for saving the plots in the directory folder.}
#'
#' @return if estimate =
#' @export
#'
#' @examples

model_predictR <- function(data, data_init, init_pars = NULL, N, plot = TRUE, T_predict, period_start,end_beta, estimate = TRUE,pi,
                           pars = NULL, data_test = NULL, auto.initialize = TRUE, ... ){
  if(estimate == FALSE && is.null(pars)) stop("Either supply parameters or set estimate = TRUE")
  if(estimate == FALSE){
    mcmc_pars = pars
  }  else{
    cat("Estimating ... ", fill = T)
    cat("  ", fill = T)
    mcmc_estimate = model_estimateR(data = data, data_init = data_init, init_pars = init_pars, N = N,end_beta=end_beta,
                                    period_start = period_start, plot = TRUE, auto.initialize = auto.initialize,...)
    mcmc_pars = mcmc_estimate$mcmc_pars
    if(plot == TRUE) plots_estimateR = mcmc_estimate$plots
  }
  var_init = model_initializeR(data = data, data_init = data_init, init_pars = NULL, N = N, end_beta=end_beta,
                               auto.initialize = FALSE, period_start = period_start, override = TRUE, ...)

  fix_pars = var_init$fix_pars
  init_state_num = var_init$init_state_num
  period_start = var_init$period_start

  library(pbapply)
  cat(" ", fill = T)
  cat("Predicting ... ", fill = T)
  pboptions(type="txt", char="|")
   prediction <- pbapply(mcmc_pars[ , 1:(2*length(period_start))], 1, function(x)
  model_stochastic_simulateR(init_obs_current = init_state_num, init_obs_daily = data_init[4:6], period_start = period_start,
                               timestrain= (1:nrow(data)),timestest=((nrow(data)+1):(nrow(data)+T_predict)),pi_fn=pi,
                               pars = x, fix_pars = fix_pars, ...))
  Result = list(prediction = prediction)

  if(estimate == TRUE)
    Result$mcmc_pars = mcmc_pars

  ### Plot

  if(plot == TRUE){
    T_simu = T_predict + nrow(data)
    plots_predictR <- model_plotR(Result = Result, T_predict = T_predict, T_simu = T_simu, n_period = n_period,
                                  data = data, data_test = data_test, data_initial = data_initial,
                                  call = "predictR", ...)
    Result$plots = c(plots_estimateR, plots_predictR)
    return(Result)
  }

  return(Result)

}


# 加载库
library(WGCNA);

# 读取文件
# The following setting is important, do not omit.
# 如果没有显式地指定“stringsAsFactors=FALSE”,默认会将所有的字符串转换为因子,导致数据处理速度较慢
options(stringsAsFactors = FALSE)
# Read in the female liver data set 读取135个雌性小鼠的数据
femData = read.csv("./data/LiverFemale3600.csv")
# Take a quick look at what is in the data set:
# 查看数据的维度
dim(femData)
# 预览数据
head(femData)

#  删除冗余数据-c(1:8)删除前8列数据，t()转置数据
datExpr0 = as.data.frame(t(femData[, -c(1:8)]));
head(datExpr0)

# 将原数据的行列名复制过来
names(datExpr0) = femData$substanceBXH;
rownames(datExpr0) = names(femData)[-c(1:8)];
head(datExpr0)

gsg = goodSamplesGenes(datExpr0, verbose = 3)
gsg$allOK;

if (!gsg$allOK)
{
    # Optionally, print the gene and sample names that were removed:
    # 打印删除的基因和样本名称
    if (sum(!gsg$goodGenes)>0)
        printFlush(paste("Removing genes:", paste(names(datExpr0)[!gsg$goodGenes], collapse = ", ")));
    if (sum(!gsg$goodSamples)>0)
        printFlush(paste("Removing samples:", paste(rownames(datExpr0)[!gsg$goodSamples], collapse = ", ")));
    # Remove the offending genes and samples from the data:
    # 从数据中删除有问题的基因和样本
    datExpr0 = datExpr0[gsg$goodSamples, gsg$goodGenes]
}

# hclusts聚类算法, dist计算基因之间的距离
sampleTree = hclust(dist(datExpr0), method = "average");
# Plot the sample tree: Open a graphic output window of size 12 by 9 inches
# The user should change the dimensions if the window is too large or too small.
# 绘制聚类树，sizeGrWindow设置绘图窗口大小
# sizeGrWindow(16,9)
pdf(file = "./plot/sampleClustering.pdf", width = 12, height = 9);
# 设置文字大小
par(cex = 0.5);
# 设置图像边距c(bottom, left, top, right)
# par(mar = c(0,4,2,0))
# 画图 main标题，sub子标题，xlab x轴标题，cex.lab标题字体大小，cex.axis坐标轴刻度大小，cex.main主标题字体
plot(sampleTree, main = "Sample clustering to detect outliers", sub="", xlab="", cex.lab = 1.5, cex.axis = 1.5, cex.main = 2)
dev.off()

# Plot a line to show the cut
# 设置文字大小
par(cex = 0.5);
plot(sampleTree, main = "Sample clustering to detect outliers", sub="", xlab="", cex.lab = 1.5, cex.axis = 1.5, cex.main = 2)
# 在上图上画红线
abline(h = 15, col = "red");
# Determine cluster under the line
# 剪枝算法，cutHeight 修剪树枝的高度 minSize集群最小数
clust = cutreeStatic(sampleTree, cutHeight = 15, minSize = 10)
# 剪枝结果
table(clust)
# clust 1 contains the samples we want to keep
keepSamples = (clust==1)
# 符合要求的数据
datExpr = datExpr0[keepSamples, ]
# 提取行
nSamples = nrow(datExpr)
# 提取列
nGenes = ncol(datExpr)

traitData = read.csv("./data/ClinicalTraits.csv");
dim(traitData)
#names(traitData)
# remove columns that hold information we do not need.
# 删除不需要的列
allTraits = traitData[, -c(31, 16)];
allTraits = allTraits[, c(2, 11:36) ];
dim(allTraits)
head(allTraits)
# names(allTraits)

# 形成一个类似于表达数据的数据框架，以保存临床特征
# 提取行名
femaleSamples = rownames(datExpr)
# 数据匹配 返回匹配行
traitRows = match(femaleSamples, allTraits$Mice);
# 提取指定要求行
datTraits = allTraits[traitRows, -1];
# 提取行名
rownames(datTraits) = allTraits[traitRows, 1];
# 垃圾回收
collectGarbage();

# Re-cluster samples
# 画聚类图
sampleTree2 = hclust(dist(datExpr), method = "average")
# Convert traits to a color representation: white means low, red means high, grey means missing entry
# 画表型的热图
# 将特征转换为颜色表示：白色表示低，红色表示高，灰色表示缺少条目
# 如果signed为true 以绿色开头代表最大负值，以白色开头代表零附近的值，然后变为红色代表正值
traitColors = numbers2colors(datTraits, signed =FALSE);
# Plot the sample dendrogram and the colors underneath.
# 绘制出树状图和下面的颜色
plotDendroAndColors(sampleTree2, traitColors,groupLabels = names(datTraits),main = "Sample dendrogram and trait heatmap")

# Choose a set of soft-thresholding powers
# 给出候选的β值，c(1:10)表示1到10；seq(from = 12, to=20, by=2)表示从12开始间隔两个数到20
powers = c(c(1:10), seq(from = 12, to=20, by=2))
powers
# Call the network topology analysis function 调用网络拓扑分析函数
# verbose表示输出结果详细程度
sft = pickSoftThreshold(datExpr, powerVector = powers, verbose = 0);

# sft这中保存了每个powers值计算出来的网络特征,其中powerEstimate就是最佳power值，fitIndices保存了每个power对应的网络的特征。
str(sft)

# Plot the results 结果绘图
# 设置窗格大小
#sizeGrWindow(9, 5)
# 设置图的显示一行两列
# par(mfrow = c(1,2));
cex1 = 0.9;
# Scale-free topology fit index as a function of the soft-thresholding power
# 生成阈值和网络的特征之间的关系函数
plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
xlab="Soft Threshold (power)",ylab="Scale Free Topology Model Fit,signed R^2",type="n",
main = paste("Scale independence"))
text(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2],
labels=powers,cex=cex1,col="red");
# this line corresponds to using an R^2 cut-off of h
abline(h=0.90,col="red")

# sft$fitIndices 保存了每个power构建的相关性网络中的连接度的统计值，k就是连接度值，每个power值提供了max, median, max3种连接度的统计量
# 对连接度的均值进行可视化
# Mean connectivity as a function of the soft-thresholding power
plot(sft$fitIndices[,1], sft$fitIndices[,5],
xlab="Soft Threshold (power)",ylab="Mean Connectivity", type="n",
main = paste("Mean connectivity"))
text(sft$fitIndices[,1], sft$fitIndices[,5], labels=powers, cex=cex1,col="red")

# datExpr表达数据，TOMType拓扑重叠矩阵计算方式，minModuleSize用于模块检测的最小模块尺寸,
# reassignThreshold 是否在模块之间重新分配基因的p值比率阈值，mergeCutHeight 树状图切割高度
# numericLabels 返回的模块应该用颜色（FALSE）还是数字（TRUE）标记,pamRespectsDendro树状图相关参数
# saveTOMs 字符串的向量，saveTOMFileBase 包含包含共识拓扑重叠文件的文件名库的字符串
net = blockwiseModules(datExpr, power = sft$powerEstimate,TOMType = "unsigned", minModuleSize = 30,reassignThreshold = 0,
                       mergeCutHeight = 0.25,numericLabels = TRUE, pamRespectsDendro = FALSE,saveTOMs = TRUE,
                       saveTOMFileBase = "femaleMouseTOM",verbose = 3)

 table(net$colors)

# open a graphics window
# sizeGrWindow(12, 9)
# Convert labels to colors for plotting
# 将标签转化为绘图颜色
mergedColors = labels2colors(net$colors)
# Plot the dendrogram and the module colors underneath
# 绘制树状图和下面的模块颜色
# dendroLabels树状图标签。设置为FALSE完全禁用树状图标签；设置为NULL使用的行标签datExpr
# addGuide是否应在树状图中添加垂直的“指导线”？线条使识别单个样本的颜色代码更加容易。
plotDendroAndColors(net$dendrograms[[1]], mergedColors[net$blockGenes[[1]]],"Module colors",
                    dendroLabels = FALSE, hang = 0.03,addGuide = TRUE, guideHang = 0.05)

moduleLabels = net$colors
moduleColors = labels2colors(net$colors)
MEs = net$MEs;
geneTree = net$dendrograms[[1]];
save(MEs, moduleLabels, moduleColors, geneTree,
file = "FemaleLiver-02-networkConstruction-auto.RData")

# Define numbers of genes and samples
# 获得基因数和样本数
nGenes = ncol(datExpr);
nSamples = nrow(datExpr);

# Recalculate MEs with color labels
# 用彩色标签重新计算MEs
# 在给定的单个数据集中计算模块的模块本征基因
MEs0 = moduleEigengenes(datExpr, moduleColors)$eigengenes
# 对给定的（特征）向量进行重新排序，以使相似的向量（通过相关性度量）彼此相邻
MEs = orderMEs(MEs0)

# 计算module的ME值与表型的相关系数
moduleTraitCor = cor(MEs, datTraits, use = "p");
moduleTraitPvalue = corPvalueStudent(moduleTraitCor, nSamples);

names(MEs)

# sizeGrWindow(10,6)
# 显示相关性及其p值
textMatrix = paste(signif(moduleTraitCor, 2), "\n(",signif(moduleTraitPvalue, 1), ")", sep = "");
dim(textMatrix) = dim(moduleTraitCor)
par(mar = c(6, 8.5, 3, 3));
# Display the correlation values within a heatmap plot\
# ySymbols 当ylabels使用时所使用的其他标签； colorLabels 应该使用颜色标签吗
# colors 颜色； textMatrix 单元格名字
labeledHeatmap(Matrix = moduleTraitCor,xLabels = names(datTraits),yLabels = names(MEs),ySymbols = names(MEs),
               colorLabels = FALSE,colors = greenWhiteRed(50),textMatrix = textMatrix,setStdMargins = FALSE,
               cex.text = 0.4,zlim = c(-1,1),
main = paste("Module-trait relationships"))

sizeGrWindow(10,6)
# Will display correlations and their p-values

dim(textMatrix) = dim(moduleTraitCor)
par(mar = c(6, 8.5, 3, 3));
# Display the correlation values within a heatmap plot
labeledHeatmap(Matrix = moduleTraitCor,
xLabels = names(datTraits),
yLabels = names(MEs),
ySymbols = names(MEs),
colorLabels = FALSE,
colors = greenWhiteRed(50),
textMatrix = textMatrix,
setStdMargins = FALSE,
cex.text = 0.5,
zlim = c(-1,1),
main = paste("Module-trait relationships"))

# Define variable weight containing the weight column of datTrait
# 定义包含数据特征权重列的变量权重
weight = as.data.frame(datTraits$weight_g);
names(weight) = "weight"
geneModuleMembership = as.data.frame(cor(datExpr, MEs, use = "p"));
# 模块的名称(颜色) substring提取文本从第3个字母开始
modNames = substring(names(MEs), 3)
# 基因和模块的相关系数
geneModuleMembership = as.data.frame(cor(datExpr, MEs, use = "p"));
MMPvalue = as.data.frame(corPvalueStudent(as.matrix(geneModuleMembership), nSamples));
names(geneModuleMembership) = paste("MM", modNames, sep="");
names(MMPvalue) = paste("p.MM", modNames, sep="");

#gene和性状的关系
geneTraitSignificance = as.data.frame(cor(datExpr, weight, use = "p"));
GSPvalue = as.data.frame(corPvalueStudent(as.matrix(geneTraitSignificance), nSamples));
names(geneTraitSignificance) = paste("GS.", names(weight), sep="");
names(GSPvalue) = paste("p.GS.", names(weight), sep="");

# 模型颜色
module = "brown"
# 匹配列
column = match(module, modNames);
moduleGenes = moduleColors==module;
#sizeGrWindow(7, 7);
par(mfrow = c(1,1));
# 画散点图
verboseScatterplot(abs(geneModuleMembership[moduleGenes, column]),
                    abs(geneTraitSignificance[moduleGenes, 1]),
                    xlab = paste("Module Membership in", module, "module"),
                    ylab = "Gene significance for body weight",
                    main = paste("Module membership vs. gene significance\n"),
                    cex.main = 1.2, cex.lab = 1.2, cex.axis = 1.2, col = module)

# 提取表带数据样本名称
# names(datExpr);
# 指定颜色数据名称
# names(datExpr)[moduleColors=="brown"]

# 基因注释数据
annot = read.csv(file = "./data/GeneAnnotation.csv");
dim(annot)
names(annot)
probes = names(datExpr)
probes2annot = match(probes, annot$substanceBXH)
# The following is the number or probes without annotation:
sum(is.na(probes2annot))

# Create the starting data frame
geneInfo0 = data.frame(substanceBXH = probes,
geneSymbol = annot$gene_symbol[probes2annot],
LocusLinkID = annot$LocusLinkID[probes2annot],
moduleColor = moduleColors,
geneTraitSignificance,
GSPvalue)
# Order modules by their significance for weight
modOrder = order(-abs(cor(MEs, weight, use = "p")));
# Add module membership information in the chosen order
for (mod in 1:ncol(geneModuleMembership))
{
    oldNames = names(geneInfo0)
    geneInfo0 = data.frame(geneInfo0, geneModuleMembership[, modOrder[mod]],
    MMPvalue[, modOrder[mod]]);
    names(geneInfo0) = c(oldNames, paste("MM.", modNames[modOrder[mod]], sep=""),
    paste("p.MM.", modNames[modOrder[mod]], sep=""))
}
# Order the genes in the geneInfo variable first by module color, then by geneTraitSignificance
geneOrder = order(geneInfo0$moduleColor, -abs(geneInfo0$GS.weight));
geneInfo = geneInfo0[geneOrder, ]
write.csv(geneInfo, file = "geneInfo.csv")

# Calculate topological overlap anew: this could be done more efficiently by saving the TOM
# calculated during module detection, but let us do it again here.
# 重新计算拓扑重叠：通过保存TOM可以更有效地完成此操作
# 是在模块检测期间计算的，但让我们在这里再次进行。
dissTOM = 1-TOMsimilarityFromExpr(datExpr, power = 6);
# Transform dissTOM with a power to make moderately strong connections more visible in the heatmap
# 变换dissTOM
plotTOM = dissTOM^7;
# Set diagonal to NA for a nicer plot
diag(plotTOM) = NA;
# Call the plot function
# sizeGrWindow(9,9)
# 基因的聚类树聚类时的距离为1-TOM值结合基因间的距离，即1-TOM值，用热图展示
# TOMplot(plotTOM, geneTree, moduleColors, main = "Network heatmap plot, all genes")

nSelect = 400
# For reproducibility, we set the random seed
set.seed(10);
select = sample(nGenes, size = nSelect);
selectTOM = dissTOM[select, select];
# There’s no simple way of restricting a clustering tree to a subset of genes, so we must re-cluster.
# 重新画聚类图
selectTree = hclust(as.dist(selectTOM), method = "average")
selectColors = moduleColors[select];
# Open a graphical window
# sizeGrWindow(9,9)
# Taking the dissimilarity to a power, say 10, makes the plot more informative by effectively changing
# the color palette; setting the diagonal to NA also improves the clarity of the plot
plotDiss = selectTOM^7;
diag(plotDiss) = NA;
TOMplot(plotDiss, selectTree, selectColors, main = "Network heatmap plot, selected genes")

# Recalculate module eigengenes
# 重新计算基因特征值
MEs = moduleEigengenes(datExpr, moduleColors)$eigengenes
# Isolate weight from the clinical traits
weight = as.data.frame(datTraits$weight_g);
names(weight) = "weight"
# Add the weight to existing module eigengenes
MET = orderMEs(cbind(MEs, weight))
# Plot the relationships among the eigengenes and the trait
#sizeGrWindow(5,7.5);
par(cex = 0.9)
# 画树形图
# marDendro给出树状图的边距设置，marHeatmap热图边距设置
plotEigengeneNetworks(MET, "", marDendro = c(0,4,1,2), marHeatmap = c(3,4,1,2), cex.lab = 0.8, xLabelsAngle= 90)

# Plot the dendrogram
# sizeGrWindow(6,6);
par(cex = 1.0)
plotEigengeneNetworks(MET, "Eigengene dendrogram", marDendro = c(0,4,2,0),
plotHeatmaps = FALSE)
# Plot the heatmap matrix (note: this plot will overwrite the dendrogram plot)
par(cex = 1.0)
plotEigengeneNetworks(MET, "Eigengene adjacency heatmap", marHeatmap = c(3,4,2,2),plotDendrograms = FALSE, xLabelsAngle = 90)


b <- c(1,3,7,5,3,2)
names(b) <- c('jan','feb','mar','apr','may','jun')
barplot(b)
abline(h=mean(b))


plot.cis<-function(d, pcol=1, x=NA, y.lab="", y.lim = NA){
    #This function computes mean and 95% confidence intervals for each column of a matrix
    #then plots these as filled circles and error bars
    #d: matrix of data
    #pcol: plotting color vector
    #x: which rows of data should be used, use all as default
    #y.lab: Label for y axis

    nitems<-dim(d)[1] #number of items
    nvars <- dim(d)[2] #number of variables
    if(is.na(x[1])) x <- c(1:nvars)  #If x values are not specified, just use 1:nvars

    mns <- colMeans(d, na.rm=T)
    serr <- rep(0, times=nvars)  #holder for standard error
    for(i in c(1:nvars)){
        serr[i] <-sqrt(var(d[,i], na.rm=T))/sqrt(nitems-sum(is.na(d[,i]))) #serr
        }
    ci <- serr * 1.96
    if(is.na(y.lim[1])) y.lim <- c(min(mns-ci), max(mns+ci)) * 1.1  #y limit for plot
    x.lim <- c(min(x) - 0.1*(max(x)-min(x)), max(x) + 0.1*(max(x)-min(x)))

    plot(x, mns, pch=16, cex = 2, col=pcol, ylim = y.lim, xlim = x.lim, xaxt="n", xlab="", ylab=y.lab)
    arrows(x,mns - ci,x, mns + ci, angle=90, length=.1, code=3, col = pcol)
    box()
}


## visualizing outputs of strat model
## Eric Barefoot
## Dec 2019

# load libraries

library(colorout)
library(tidyverse)
library(here)

# load data

epc_data = readRDS(here('data', 'derived_data', 'strat_model_results_20191202.rds'))

ggplot(data = epc_data, aes(x = pres_percents, y = reworking)) +
geom_abline() + geom_point(aes(color = avul))

epc_data %>%  filter(most_common_avulsion == 'clustered') %>%
ggplot(aes(x = pres_percents, y = reworking)) +
geom_abline() + geom_point()

n2g_pres_plot = epc_data %>%  filter(most_common_avulsion == 'clustered') %>%
filter(IR == 0.4) %>%
ggplot(data = ., aes(x = pres_percents, y = n2g))

n2g_pres_plot + geom_point(aes(color = vertagg_rate))
# n2g_pres_plot + geom_point()

nagg_pres_plot = epc_data %>% filter(most_common_avulsion == 'clustered') %>%
# filter(latmob == 4) %>%
ggplot(data = ., aes(x = pres_percents, y = nagg))

# nagg_pres_plot + geom_point()
nagg_pres_plot + geom_point(aes(color = IR))

n2g_nagg_plot_log = epc_data %>% # filter(avul == 'random') %>%
ggplot(data = ., aes(x = log(nagg), y = log(n2g)))

n2g_nagg_plot_log + geom_point(aes(color = avul), alpha = 0.4) +
geom_smooth(method = 'lm', formula = y ~ x, se = FALSE, aes(color = avul,group = avul))

n2g_nagg_plot = epc_data %>% # filter(avul == 'clustered') %>%
ggplot(data = ., aes(x = nagg, y = n2g))

n2g_nagg_plot + geom_point(aes(color = avul), alpha = 0.4)

nagg_vagg_plot = epc_data %>%
# filter(avul == 'compensational') %>%
# filter(IR == 0.4) %>%
ggplot(data = ., aes(x = vertagg_rate, y = nagg))

nagg_vagg_plot + geom_jitter(aes(color = IR))

for (i in seq(0.4,0.9,0.1)) {
  n2g_vagg_plot = epc_data %>%
  filter(avul == 'compensational') %>%
  filter(IR == round(i,1)) %>%
  ggplot(data = ., aes(x = log(vertagg_rate), y = log(n2g)))
  # ggplot(data = ., aes(x = vertagg_rate, y = n2g))

  print(n2g_vagg_plot + geom_jitter())
  Sys.sleep(5)
}

n2g_vagg_plot = epc_data %>%
# filter(avul == 'compensational') %>%
filter(between(IR, 0.3, 0.65)) %>%
ggplot(data = ., aes(x = log(vertagg_rate), y = log(n2g)))
# ggplot(data = ., aes(x = vertagg_rate, y = n2g))
n2g_vagg_plot + geom_jitter()
# n2g_vagg_plot + geom_jitter(aes(color = avul))

epc_just_logvert = epc_data %>%
filter(between(IR, 0.3, 0.65)) %>%
transmute(lvert = log(vertagg_rate), ln2g = log(n2g))

model_lvert_ln2g = lm(ln2g~lvert, data = epc_just_logvert)

library(segmented)

model_lvert_ln2g_seg = segmented(model_lvert_ln2g)

brpoint = model_lvert_ln2g_seg$psi[2]

n2g_vagg_plot_breakpoint = epc_data %>%
# filter(avul == 'compensational') %>%
filter(between(IR, 0.3, 0.65)) %>%
ggplot(data = ., aes(x = log(vertagg_rate), y = log(n2g)))

n2g_vagg_plot_breakpoint + geom_jitter() +
geom_vline(xintercept = brpoint, color = 'red3')
# n2g_vagg_plot + geom_jitter(aes(color = avul))

epc_filt = epc_data %>%
# filter(vertagg_rate > exp(brpoint)) %>%
filter(between(IR, 0.3, 0.55)) %>%
filter(most_common_avulsion == 'compensational')

ggplot() +
geom_point(aes(x = pres_percents, y = reworking), data = epc_data) +
geom_point(aes(x = pres_percents, y = reworking), data = epc_filt, color = 'white', size = 0.5) +
geom_abline()

n2g_nagg_plot = epc_filt %>% filter(avul == 'random') %>%
ggplot(data = ., aes(x = nagg, y = n2g))

n2g_nagg_plot + geom_point(aes(color = IR))

n2g_vagg_plot = epc_filt %>%
# filter(avul == 'compensational') %>%
# filter(between(IR, 0.3, 0.65)) %>%
ggplot(data = ., aes(x = log(vertagg_rate), y = log(n2g)))
# ggplot(data = ., aes(x = vertagg_rate, y = n2g))
n2g_vagg_plot + geom_jitter(aes(color = log(IR / vertagg_rate)))

epc_ratio = epc_filt %>% transmute(x = log10(IR/vertagg_rate), y = log10(n2g))

model_irvert_ln2g = lm(y~x, data = epc_ratio)

model_irvert_ln2g_seg = segmented(model_irvert_ln2g)

brpoint = model_irvert_ln2g_seg$psi[2]

n2g_vagg_plot = epc_filt %>%
# filter(avul == 'compensational') %>%
# filter(between(IR, 0.3, 0.65)) %>%
ggplot(data = ., aes(x = log10(IR/vertagg_rate), y = log10(n2g)))
# ggplot(data = ., aes(x = vertagg_rate, y = n2g))
n2g_vagg_plot + geom_jitter() + geom_vline(xintercept = brpoint, colo = 'red')

n2g_pres_plot = epc_filt %>%
# filter(most_common_avulsion == 'clustered') %>%
# filter(IR == 0.4) %>%
ggplot(data = ., aes(y = pres_percents, x = n2g))

n2g_pres_plot + geom_point(aes(color = latmob)) +
geom_line(aes(x = x, y = y, group = g), data = f)

epc_filt2 = epc_filt %>% mutate(presInv = 1 / (pres_percents-1.01), n2gInv = 1/n2g)
epc_filt2 %>% ggplot(aes(x = pres_percents, y = n2g)) + geom_point()

n2gMod = lm(n2gInv ~ presInv, data = epc_filt2, weight = 1-pres_percents)
reworkingMod = lm(reworking ~ pres_percents, data = epc_filt2)
reworkingModSeg = segmented(reworkingMod)

epc_filt3 = epc_filt2 %>% mutate(n2gPred = 1/predict(n2gMod)) %>%
mutate(reworkingPred = predict(reworkingModSeg))

ggplot(aes(x = presInv), data = epc_filt3) +
geom_point(aes(y = n2gInv)) +
geom_line(aes(y = 1/n2gPred), color = 'red3')

ggplot(aes(x = pres_percents), data = epc_filt3) +
geom_point(aes(y = n2g)) +
geom_line(aes(y = n2gPred), color = 'red3')

ggplot(aes(x = pres_percents), data = epc_filt3) +
geom_point(aes(y = reworking)) + geom_abline() +
geom_vline(xintercept = reworkingModSeg$psi[2], color = 'red3') +
geom_line(aes(y = reworkingPred), color = 'blue3')

nagg_IR_plot = epc_data %>% filter(avul == 'compensational') %>%
filter(vertagg_rate == 0.305) %>%
ggplot(data = ., aes(x = IR, y = nagg))

nagg_IR_plot + geom_jitter(aes(color = latmob))

nagg_latmob_plot = epc_data %>% # filter(most_common_avulsion == 'clustered') %>%
# filter(latmob == 4) %>%
ggplot(data = ., aes(x = latmob, y = n2g))

nagg_latmob_plot + geom_jitter()

nagg_reworking_plot = epc_data %>%
# filter(most_common_avulsion == 'clustered') %>%
# filter(latmob == 4) %>%
ggplot(data = ., aes(x = reworking, y = nagg))

# nagg_pres_plot + geom_point()
nagg_reworking_plot + geom_point(aes(color = input_n2g))

nagg_input_plot = epc_data %>% filter(most_common_avulsion == 'random') %>%
filter(IR == 0.4) %>%
ggplot(data = ., aes(x = vertagg_rate, y = input_n2g))

nagg_input_plot + geom_jitter(aes(color = IR))

n2g_reworking_plot = epc_data %>%
filter(most_common_avulsion == 'random') %>%
# filter(latmob == 4) %>%
ggplot(data = ., aes(x = reworking, y = n2g))

n2g_reworking_plot + geom_point()
n2g_reworking_plot + geom_point(aes(color = nagg))

enrichment_plot = epc_data %>% filter(most_common_avulsion == 'clustered') %>%
# filter(IR == 0.4) %>%
ggplot(data = ., aes(x = input_n2g, y = n2g))

enrichment_plot + geom_jitter(aes(color = avul)) + geom_abline()
# enrichment_plot + geom_jitter() + geom_abline()

reworking_input_plot = epc_data %>%  filter(most_common_avulsion == 'random') %>%
# filter(IR == 0.4) %>%
ggplot(data = ., aes(x = input_n2g, y = reworking))

reworking_input_plot + geom_jitter(aes(color = n2g))


2018-10 from:林玥
修改2019-01-03

UP&DOWN-RF

-------输入数据-------
#读入训练集与验证集
traindata <- read.csv("traindata.csv", header = TRUE)
testdata <- read.csv("testdata.csv", header = TRUE)

-------非均衡数据处理-------
#加载R包
library(ROSE)

#检查poi数据的不平衡度
table(traindata$landmark)
prop.table(table(traindata$landmark))

#SMOTE采样
rosedata <- ROSE(landmark ~ ., data = traindata, seed = 1)$data
table(rosedata$landmark)
prop.table(table(rosedata$landmark))

-------非均衡数据处理*2-------
library(DMwR)

table(traindata$landmark)
prop.table(table(traindata$landmark))

smotedata <- SMOTE(landmark ~ ., traindata, perc.over = 1200,perc.under = 100)
table(smotedata$landmark)
prop.table(table(smotedata$$landmark))

-------随机森林（Random Forest）模型搭建-------
#加载R包
library(randomForest)

#设定随机数种子
set.seed(100)

#运行随机森林模型
rf_ntree <- randomForest(landmark~., data = rosedata, ntree = 600, importance = TRUE)
rf_ntree <- randomForest(landmark~., data = smotedata, ntree = 600, importance = TRUE)

#输出模型结果
print(rf_ntree)

#查看每一棵树的误判率
plot(rf_ntree)

#计算模型变量的重要性
importance(rf_ntree,type = 1, scale = TRUE)
importance(rf_ntree,type = 2, scale = TRUE)
varImpPlot(rf_ntree)

-------检测测试集-------
#随机森林预测
pred <- predict(object = rf_ntree,newdata = testdata)

#AUC曲线
roc.curve(testdata$landmark, pred)

#另一种AUC曲线
library(pROC)
roc <- roc(testdata$landmark, pred)
plot(roc, print.auc = TRUE, auc.polygon = TRUE, grid = c(0.1, 0.2), grid.col = c("green", "red"), max.auc.polygon = TRUE, auc.polygon.col = "skyblue", print.thres = TRUE)

#计算混淆矩阵
prediction <- predict(object = rf_ntree,newdata = testdata,type = "response")
actual <- testdata$landmark
confusionmtx <- table(actual,prediction)
confusionmtx


library(readr)
library(dplyr)
library(ggplot2)
library(caret)
library(doParallel)
replace_na <- function(x){
  x <- ifelse(is.na(x), -3, x)

  return(x)
}
rmse <- function(y, y_hat){
  e <- y - y_hat
  mse <- mean(e^2)
  rmse <- sqrt(mse)

  return(rmse)
}

#####################################
########### Configurações ###########
#####################################
# cl <- makePSOCKcluster(8)
# registerDoParallel(cl)

###########################
########### ETL ###########
###########################
train <-
  read_csv(file = 'Dados/train.csv') %>%
  filter(!is.na(NU_NOTA_MT)) %>%
  mutate_all(replace_na)

y <- train$NU_NOTA_MT
X <-
  train %>%
  select(NU_IDADE, TP_SEXO, TP_COR_RACA, TP_ST_CONCLUSAO, NU_NOTA_CH, NU_NOTA_CN, NU_NOTA_LC, Q001, Q002, Q006, Q024, Q025, Q026, Q047) %>%
  mutate(TP_COR_RACA = factor(TP_COR_RACA), TP_ST_CONCLUSAO = factor(TP_ST_CONCLUSAO)) %>% mutate_if(is.character, as.factor)
ux <- X %>% select(NU_NOTA_CH, NU_NOTA_CN, NU_NOTA_LC) %>% colMeans()

test <- read_csv(file = 'Dados/test.csv')
X_test <-
  test %>%
  select(NU_IDADE, TP_SEXO, TP_COR_RACA, TP_ST_CONCLUSAO, NU_NOTA_CH, NU_NOTA_CN, NU_NOTA_LC, Q001, Q002, Q006, Q024, Q025, Q026, Q047) %>%
  mutate(TP_COR_RACA = factor(TP_COR_RACA), TP_ST_CONCLUSAO = factor(TP_ST_CONCLUSAO)) %>% mutate_if(is.character, as.factor) %>%
  mutate(NU_NOTA_CH = ifelse(is.na(NU_NOTA_CH), ux['NU_NOTA_CH'], NU_NOTA_CH),
         NU_NOTA_CN = ifelse(is.na(NU_NOTA_CN), ux['NU_NOTA_CN'], NU_NOTA_CN),
         NU_NOTA_LC = ifelse(is.na(NU_NOTA_LC), ux['NU_NOTA_LC'], NU_NOTA_LC))

###########################
########### AED ###########
###########################
summary(y)
hist(y)

nomes <- X_test %>% colnames
p <- list()
for(i in nomes){
  dummy <-  data.frame(x = X[, i, T], y = y)
  p[[i]] <-
    ggplot(data = dummy, mapping = aes(x = x, y = y)) +
    geom_point() +
    labs(title = i)
}
pdf(file = 'train.pdf')
p
dev.off()

#################################
########### Modelagem ###########
#################################
train_set <- cbind(X, y_t = y)

fit_lm <- lm(y_t ~ ., data = train_set)
rmse(y, fitted(fit_lm)) %>% data.frame(model = 'lm') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit_lm, X_test)) %>% write_csv(path = 'lm_predict.csv')

fit1 <- train(y_t ~.,
              data = train_set,
              method = 'treebag',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit1)) %>% data.frame(model = 'treebag') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit1, X_test)) %>% write_csv(path = 'fit1_predict.csv')

fit2 <- train(y_t ~.,
              data = train_set,
              method = 'bagEarth',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit2)) %>% data.frame(model = 'bagEarth') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit2, X_test)) %>% write_csv(path = 'fit2_predict.csv')

fit3 <- train(y_t ~.,
              data = train_set,
              method = 'ranger',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit3)) %>% data.frame(model = 'ranger') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit3, X_test)) %>% write_csv(path = 'fit3_predict.csv')

fit4 <- train(y_t ~.,
              data = train_set,
              method = 'gamboost',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit4)) %>% data.frame(model = 'gamboost') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit4, X_test)) %>% write_csv(path = 'fit4_predict.csv')

fit5 <- train(y_t ~.,
              data = train_set,
              method = 'gaussprLinear',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit5)) %>% data.frame(model = 'gaussprLinear') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit5, X_test)) %>% write_csv(path = 'fit5_predict.csv')

fit6 <- train(y_t ~.,
              data = train_set,
              method = 'earth',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit6)) %>% data.frame(model = 'earth') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit6, X_test)) %>% write_csv(path = 'fit6_predict.csv')

fit7 <- train(y_t ~.,
              data = train_set,
              method = 'xgbTree',
              preProcess = c("center", "scale"),
              tuneLength = 10,
              trControl = trainControl(method = "cv", search = 'random'))
rmse(y, fitted(fit7)) %>% data.frame(model = 'xgbTree') %>% write_csv(path = 'metrics.csv', append = T)
data.frame(NU_INSCRICAO = test$NU_INSCRICAO, NU_NOTA_MT = predict(fit7, X_test)) %>% write_csv(path = 'fit7_predict.csv')


# "XGBoost for all severity"

# Temp
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(mgcv)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library(doParallel)
detectCores(all.tests = FALSE, logical = TRUE)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

setwd(".")

set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

colnames(Data)
dim(Data)

Data[, table(TrainTest), ]
Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible

######################## Prediction settings
# CV methods
CV_method <- "cv"
CV_number <- 5
Repeated_number <- 1
Tune_number <- 1

#################################################################
###
#################################################################
# formula
Form_temp <- formula(
	SeverityAll ~
	Population100000 +
	Mean_income_city_2015 +
	Green_area_percent +
	Age_median_city +
	Population_over_65_100000 +
	SexRatioF +

	RainySeason +
	DifDateRain +
	holiday_flag +
	Hour +
	Month +

	precip1Hour +
	windSpeed_ms +
	DownwardSolarRadiation_kwm2 +
	relativeHumidity +
	temperature +
	temperature_past1d_max_diff +
	temperature_past1d_mean_diff +
	temperature_past1d_min_diff
)

##################################################################
###   xgbTree
##################################################################

Size_n <- 20  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
tune_params = expand.grid(
 	nrounds = c(seq(10, 90, 10), seq(100, 1000, 100)),
	max_depth = seq(3, 9, 2),
	min_child_weight = seq(1, 5, 1),
		gamma = 0,
 			colsample_bytree = 0.8,
 			subsample = 0.8,
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 41  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_nrounds <- xgbTree_temp$bestTune$nrounds
get_max_depth <- xgbTree_temp$bestTune$max_depth
get_min_child_weight <- xgbTree_temp$bestTune$min_child_weight

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = seq(0, 0.4, 0.01),
 			colsample_bytree = 0.8,
 			subsample = 0.8,
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 25  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_gamma <- xgbTree_temp$bestTune$gamma

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = get_gamma,
 			colsample_bytree = seq(0.6, 1, 0.1),
 			subsample = seq(0.6, 1, 0.1),
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 10  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_colsample_bytree <- xgbTree_temp$bestTune$colsample_bytree
get_subsample <- xgbTree_temp$bestTune$subsample

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = get_gamma,
 			colsample_bytree = get_colsample_bytree,
 			subsample = get_subsample,
					eta = seq(0.01, 0.1, 0.01)
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

### set seed
Size_n <- 19
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_eta <- xgbTree_temp$bestTune$eta

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = get_gamma,
 			colsample_bytree = get_colsample_bytree,
 			subsample = get_subsample,
					eta = get_eta
 	) %>% as.data.frame

#
tic()
xgbTree_temp <- rfe(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params,

    sizes = 1:20,
    rfeControl = rfe_control
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

xgbTree_temp$optVariables

```

# Temp selected variables
```{r}

# formula
Form_temp <- formula(
	SeverityAll ~
		temperature +
		Population100000 +
		Population_over_65_100000 +
		DownwardSolarRadiation_kwm2 +
		Month +
		DifDateRain +
		relativeHumidity +
		temperature_past1d_max_diff +
		Green_area_percent +
		precip1Hour +
		windSpeed_ms +
		Age_median_city +
		temperature_past1d_mean_diff +
		Mean_income_city_2015
)

##################################################################
###   xgbTree
##################################################################

Size_n <- 20  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
tune_params = expand.grid(
 	nrounds = c(seq(10, 90, 10), seq(100, 1000, 100)),
	max_depth = seq(3, 9, 2),
	min_child_weight = seq(1, 5, 1),
		gamma = 0,
 			colsample_bytree = 0.8,
 			subsample = 0.8,
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 41  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_nrounds <- xgbTree_temp$bestTune$nrounds
get_max_depth <- xgbTree_temp$bestTune$max_depth
get_min_child_weight <- xgbTree_temp$bestTune$min_child_weight

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = seq(0, 0.4, 0.01),
 			colsample_bytree = 0.8,
 			subsample = 0.8,
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 25  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_gamma <- xgbTree_temp$bestTune$gamma

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = get_gamma,
 			colsample_bytree = seq(0.6, 1, 0.1),
 			subsample = seq(0.6, 1, 0.1),
					eta = 0.1
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

Size_n <- 10  ### set seed
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

#
xgbTree_temp$bestTune
get_colsample_bytree <- xgbTree_temp$bestTune$colsample_bytree
get_subsample <- xgbTree_temp$bestTune$subsample

tune_params = expand.grid(
 	nrounds = get_nrounds,
	max_depth = get_max_depth,
	min_child_weight = get_min_child_weight,
		gamma = get_gamma,
 			colsample_bytree = get_colsample_bytree,
 			subsample = get_subsample,
					eta = seq(0.01, 0.1, 0.01)
 	) %>% as.data.frame

# xgbTree
tic()
xgbTree_temp <- train(
	form = Form_temp,
	data = Data_train,
    method = "xgbTree",

	objective="reg:squarederror",
	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneGrid = tune_params
	)
summary(xgbTree_temp)
xgbTree_temp
toc()

xgbTree_temp$bestTune

saveRDS(xgbTree_temp, "xgbTree_temp.rds")

```

# info
```{r}
sessionInfo()

```


require(rms)
set.seed(1)
n <- 1000
cvd <- data.frame(id    = sample(1 : 100, n, TRUE),
                  bmi   = rnorm(n, 25, 3),
                  wtpre = sample(c(-1, 1), n, TRUE))
t.enter <- runif(n)
t.exit  <- t.enter + runif(n)
cens    <- sample(0:1, n, TRUE)
cvd$S <- Surv(t.enter, t.exit, cens)

label(cvd$id) <- "Id"
label(cvd$bmi) <- "BMI"
units(cvd$bmi) <- "Kg/m2"

dd <- datadist(cvd); options(datadist = "dd")
#S <- with(cvd, Surv(t.enter, t.exit, cens))

cph(S ~ rcs(bmi) + cluster(id) + wtpre, data=cvd)
f <- cph  (S ~ pol(bmi, 3) + cluster(id) + offset(wtpre), data = cvd, eps=1e-6)
g <- coxph(S ~ pol(bmi, 3) + cluster(id) + offset(wtpre), data = cvd,
           control=coxph.control(eps=1e-6))
coef(f) - coef(g)
f
g

Predict(f, bmi=20, offset=list(wtpre=5))   # 4.849534
d <- data.frame(bmi=20, wtpre=5)
predict(f, d)       # 4.849534
k <- coef(f)
mp <- function(fit, bmi=20, wtpre=5) {
  k  <- coef(fit)
  k0 <- if(length(fit$center)) - fit$center
  else {
    m  <- fit$means
    k0 <- - unname(k[1] * m[1] + k[2] * m[2] + k[3] * m[3])
    }
  k0 + k[1]*bmi + k[2] * bmi^2 + k[3] * bmi^3 + wtpre
}
mp(f)   # 4.849534
mp(g)   # "

f <- cph(S ~ pol(bmi, 3) + offset(wtpre), data=cvd, eps=1e-6)
g <- coxph(S ~ pol(bmi, 3) + offset(wtpre), data=cvd,
           control=coxph.control(eps=1e-6))
coef(f) - coef(g)
mp(f)   # 4.849534
mp(g)   # "
predict(f, d)   # -.1504; ignores offset
Predict(f, bmi=20, offset=list(wtpre=5))   # -.1504

p1 <- Predict(f, bmi, offset=list(wtpre=0))
p2 <- Predict(f, bmi, offset=list(wtpre=5))
plot(rbind(p1, p2))

z <- expand.grid(x1=LETTERS[1:3], x2=c('a','b','c'), reps=1:10)
z$S <- Surv(runif(nrow(z)))
cph(S ~ x1 * strat(x2), data=z)


# Load package
library(shiny)

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Regression analysis"),

    # Sidebar with a slider input for number of bins
    sidebarLayout(
        sidebarPanel(

            # Input: Select a file ----
            fileInput("file1", label = "Choose CSV File",
                      multiple = FALSE,
                      accept = c("text/csv",
                                 "text/comma-separated-values,text/plain",
                                 ".csv")),

            # Horizontal line ----
            tags$hr(),

            # Input: Checkbox if file has header ----
            checkboxInput("header", label = "Header", TRUE),

            # Input: Select separator ----
            radioButtons("sep", label = "Separator",
                         choices = c(Comma = ",",
                                     Semicolon = ";",
                                     Tab = "\t"),
                         selected = ","),

            # Horizontal line ----
            tags$hr(),

            # Input: Select quotes ----
            radioButtons("quote", label = "Quote",
                         choices = c(None = "",
                                     "Double Quote" = '"',
                                     "Single Quote" = "'"),
                         selected = '"'),

            # Horizontal line ----
            tags$hr(),

            # Input: Select number of rows to display ----
            radioButtons("disp", label = "Display",
                         choices = c(Head = "head",
                                     All = "all"),
                         selected = "head"),

            # Horizontal line ----
            tags$hr(),
            tags$hr(),

            # Action Button for linear model
            actionButton("lmPlot", label = "Linear Model"),

            # Horizontal line ----
            tags$hr(),

            # Download Button for linear model
            downloadButton('downloadPlot', 'Download Plot')

        ),

        # Show a plot of the generated distribution
        mainPanel(
           plotOutput("scatterPlot"),
           tableOutput("contents"),
           verbatimTextOutput("summary")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    # load data
    dataInput <- reactive({
        req(input$file1)

        df <- read.csv(input$file1$datapath,
                       header = input$header,
                       sep = input$sep,
                       quote = input$quote)
        return(df)
    })

    # reactive attributes
    data <- reactiveValues(lines = NULL, printSummary = FALSE)

    # plot scatter with predicting value
    output$scatterPlot <- renderPlot({
        ## plot(dataInput()$x, dataInput()$y, xlab = "x", ylab = "y")
        plot( y ~ x, data = dataInput())
        abline(data$lines, col = "red", lwd = 2)
    })

    # reactive manipulation
    observeEvent(input$lmPlot, {
        data$lines <- lm(y ~ x, data = dataInput())
        data$printSummary <- TRUE
    })

    # print data
    output$contents <- renderTable({
        if(input$disp == "head") {
            return(head(dataInput()))
        }
        else {
            return(dataInput())
        }
    })

    # output the summarty
    output$summary <- renderPrint({
        lmPlot <- lm(y ~ x, data = dataInput())
        cor <- cor(dataInput()$x, dataInput()$y, method="pearson")
        summaryObject <- summary(lmPlot)

        if (data$printSummary == TRUE) {

            # attributes(summaryObject)
            # print(summaryObject)

            cat("Model Summary", "\n")
            cat(paste("Slope: ", round(summaryObject$coefficients[2],4)), "\n")
            cat(paste("Intercept: ", round(summaryObject$coefficients[1], 4)), "\n")
            cat(paste("Pearson correlation: ", round(cor, 4)), "\n")
            cat(paste("r squared: ", round(summaryObject$r.squared, 4)), "\n")

        }
    })

    lmGraph <- function(){
        plot( y ~ x, data = dataInput())
        abline(data$lines, col = "red", lwd = 2)
    }

    output$downloadPlot <- downloadHandler(
        filename <-  function() { paste(strsplit(as.character(input$file1), ".", fixed = TRUE)[[1]][1], '_lm.png', sep='') },
        content <-  function(file) {
            png(file)
            lmGraph()
            dev.off()
        })

}

# Run the application
shinyApp(ui = ui, server = server)