#  James Rekow

identifyNumSubgroups2  = function(infoMat, centersVec){

  #  ARGS:
  #
  #  RETURNS:

  source("computeSSRatio.r")

  #  compute SS ratio of clusters for kmeans results using each number of centers in centersVec
  SSRatioVec = sapply(1:length(centersVec), function(n) computeSSRatio(inputMat = infoMat,
                                                                       centers = centersVec[n]))

  kmr = kmeans(x = SSRatioVec, centers = 2)

  numSubgroupsGuess = which.max(abs(diff(kmr$cluster)))

  return(numSubgroupsGuess)

} #  end  identifyNumSubgroups2  function


library(tidyverse)
library(data.tale)
library(maditr)
library(parallel)

setwd("/bioinf/projects/megx/UNKNOWNS/2017_11/")

gene_annot_all <- fread("data/pfam_annotation/marine_hmp_pfam31_multi_domain_coord.tsv.gz", header = F) %>%
  setNames(c("gene","pfam","start","end"))

# Gene coverage for mono-domain annotation
mono <- gene_annot_all %>% dt_filter(!grepl("\\|",start)) %>%
  mutate(pfam_covered_aa=(as.numeric(end)-as.numeric(start))+1) %>% select(gene,pfam,pfam_covered_aa)
save(mono,file="data/pfam_annotation/marine_hmp_pfam31_mono_coord.rda")

# Gene coverage for mono-domain annotation
multi <- gene_annot_all %>% dt_filter(grepl("\\|",start)) %>%
  separate_rows(start,end,sep="\\|")

list <- split(multi, list(multi$gene), drop=TRUE)

# Function to calculate multi-domain annotations coverage, taking into account eventual coordinates overlaps
overlaps_dt_f <- function(df){
  tbl <- as.data.table(df %>% mutate(start=as.numeric(start),end=as.numeric(end)))

  setkey(tbl, gene, start, end)
  over <- foverlaps(tbl, tbl, nomatch = 0)
  over <- over[start != i.start]
  over[, overlap := abs(over[, ifelse(start > i.start, start, i.start)] - over[, ifelse(end < i.end, end, i.end)])]
  over <- over %>%  mutate(overlap=ifelse(start==i.end,1,overlap)) %>% select(gene,overlap,i.start,i.end) %>% distinct() %>% select(-i.start,-i.end) %>%
    group_by(gene) %>% summarise(overlap=sum(overlap))
  covered_aa <- tbl %>% mutate(covered=(end-start)+1) %>% group_by(gene,pfam) %>%
    summarise(pfam_covered_aa=sum(covered)) %>% select(gene,pfam,pfam_covered_aa) %>% distinct()
  if(identical(over$overlap, integer(0))){
    tbl <- covered_aa
  }else{
    tbl <- covered_aa %>% left_join(over) %>% mutate(pfam_covered_aa=pfam_covered_aa - (overlap+1)) %>%
      select(gene,pfam,pfam_covered_aa) %>% distinct()
  }
}

multi_overlap <- mclapply(list, overlaps_dt_f, mc.cores = getOption("mc.cores",18))
multi_overlap <- plyr::ldply(multi_overlap, data.frame) %>% select(-`.id`)

gene_annot <- bind_rows(mono,multi_overlap)

gene_length <- fread("data/mmseqs_clustering/marine_hmp_orf_length.tsv.gz",header = F,sep="\t") %>%
  setNames(c("gene","length"))

# gene_annot_length <- gene_annot %>% dt_left_join(gene_length) # check

gene_compl <- fread("data/gene_prediction/marine_hmp_orfs_partial_info.tsv.gz",header=F) %>%
  setNames(c("gene","completion")) %>% mutate(completion=ifelse(completion==0,"00",
                                                                ifelse(completion==1,"01",
                                                                       ifelse(completion==10,"10","11"))))

gene_annot_length_coverage <- gene_annot_length %>% dt_left_join(gene_compl) %>%
  mutate(pfam_covered_aa_p=(pfam_covered_aa/length))


#Load package
suppressMessages(library(qvalue))
suppressMessages(library(limma))
suppressMessages(library(DESeq2))
suppressMessages(library(WGCNA))
suppressMessages(library(preprocessCore))
suppressMessages(library(peer))

#Read command line arguments
args <- commandArgs(trailingOnly = TRUE)
try(if(length(args) != 3) stop("Incorrect number of arguments, usage> Rscript RNA_processing.R INPUT PEER_factor OUTPUT"))
opt_input  = args[1];
opt_factor = as.numeric(args[2]);
opt_outputdir = args[3];

count<-read.table(opt_input,row.names=1,stringsAsFactors=F)
colnames(count)<-count[1,]
count2<-read.table(opt_input,row.names=1,stringsAsFactors=F,head=T)
colnames(count2)<-colnames(count)
log2cpm<-voom(count2)$E
genes_to_keep = apply(log2cpm>=0,1,sum) >= round(0.25 * ncol(log2cpm))
annotation = read.csv("/zs32/data-analysis/liucy_group/shareData/Chinese_brain/RNA-seq/expression/annotation.gene.gencodeV19.csv")
log2cpm.fgene = log2cpm[genes_to_keep,]
normadj <- (0.5+0.5*bicor(log2cpm.fgene, use='pairwise.complete.obs'))^2
#normadj <- (0.5+0.5*cor(log2cpm.fgene))^2
netsummary <- fundamentalNetworkConcepts(normadj);
k <- netsummary$Connectivity; K <- k/max(k); Z.K <- (K-mean(K))/sqrt(var(K))
C <- netsummary$ClusterCoef; Z.C = (C - mean(C))/sqrt(var(C))
sdout <- 3
outliers <- (Z.K > mean(Z.K)+sdout*sd(Z.K))|(Z.K < mean(Z.K)-sdout*sd(Z.K))
print(paste("There are ",sum(outliers)," outliers samples based on a bicor distance sample network connectivity standard deviation above ",sdout,sep="")); print(colnames(log2cpm.fgene)[outliers]); print(table(outliers))
log2cpm.fgene.fsample <- log2cpm.fgene[,!outliers]
pdf(paste(opt_outputdir,"/log2cpm.fgene.zscore.pdf",sep=""))
#plot(Z.K, col = as.numeric(colData(dds)$Region), pch=19, main="Outlier detection", ylab="Network connectivity (z score)")
plot(Z.K, col = "black", pch=19, main="Outlier detection", ylab="Network connectivity (z score)")
abline(h=-sdout, lty=2)
dev.off()
log2cpm.fgene.fsample.qn<-normalize.quantiles(log2cpm.fgene.fsample,copy=T)  # Quantile normalization across columns
rownames(log2cpm.fgene.fsample.qn)<-rownames(log2cpm.fgene.fsample)
colnames(log2cpm.fgene.fsample.qn)<-colnames(log2cpm.fgene.fsample)
out=paste(opt_outputdir, "/log2cpm.fgene.fsample.qn", sep="")
write.table(log2cpm.fgene.fsample.qn, out,sep="\t", row.names=T, quote=F,col.names=NA)
expr = t(as.matrix(log2cpm.fgene.fsample.qn))  # N rows and G columns, where N is the number of samples, and G is the number of genes. No column or row names.
dim(expr)
factorList=list()
residList=list()
for(nFactor in 1:1*opt_factor){
    model = PEER()  # create the model object
    PEER_setPhenoMean(model,expr)  # set the observed data
    #PEER_setNk(model,30)  # Set the hidden confounders.
    PEER_setNk(model,nFactor) # gradient number of factors
    PEER_getNk(model)
    PEER_setAdd_mean(model, TRUE)  # include an additional factor (covariate) to account for the mean expression
    ## PEER_setCovariates(model, as.matrix(meta))  # adding covariates has no effect on the model?
    #PEER_setNmax_iterations(model, 100)  # If the model is not converged after the default 1,000 iterations, and the variance of the residuals keeps decreasing, choose a higher value of iterations, e.g., 10,000.
    PEER_update(model)  # perform the inference
    factors = PEER_getX(model)  # inferred confounders
    weights = PEER_getW(model)  # their weights
    precision = PEER_getAlpha(model)     # precision (inverse variance) of the weights
    residuals = PEER_getResiduals(model) # the residual dataset
    #plot(precision)
    #PEER_plotModel(model)
    Variance<-c(); for(i in 2:(opt_factor+1)){Variance<-c(Variance,var(factors[,i]))}; Variance<-sort(Variance, decreasing=TRUE); Variance<-100*Variance/sum(Variance)
    pdf(paste(opt_outputdir,"/variance-factor.pdf",sep=""),width=5,height=5)
    plot(Variance,type="o",pch=19,col="red",xlab="Factors")
    dev.off()
    factors1<-t(factors)[-1,]
    colnames(factors1)<-colnames(log2cpm.fgene.fsample.qn)
    rownames(factors1)<-paste("Factor",1:nrow(factors1),sep="")
    factorList[[nFactor]]<-factors1
    #factors2<-rbind(t(meta),factors1)
    #factors2<-cbind(meta,t(factors1))
    #write.table(t(factors2), file=paste("log2cpm.fgene.fsample.qn.realign.peerCovariates.factor",nFactor,".xls",sep=""), sep="\t", row.names=T, quote=F,col.names=NA)
    write.table(factors1, file=paste(opt_outputdir,"/expr",opt_factor,".xls",sep=""), sep="\t", row.names=T, quote=F,col.names=NA)
}


#### questions for CITN:
# - C1D-7 timepoint: only in cohort 1. Can I consider C1D01 the "pre-tx" timepoint and ignore C1D-7 in my models?
# -

rm(list=ls())
source("RCC_gather_n_collect.r")

library(NormqPCR)
library(RColorBrewer)

fadecols = function(cols,fade=.5)
{
  fcols = c()
  for(i in 1:length(cols))
  {
    tmp = as.vector(col2rgb(cols[i])/256)
    fcols[i] = rgb(tmp[1],tmp[2],tmp[3],fade)
  }

  return(fcols)
}

#####
# load RCCs
#####

datasets = collate.lanes.2.dataset(allRCC.path = paste0("input_data/CITN_lysate RCC_258_Jan2018"),
                                   sup.path = paste0("input_data/CITN_lysate RCC_258_Jan2018","//"))$datasets
dat = datasets[[1]]
# there's one sample run in dup. Delete it:
dup.rcc = "20171228_CITN 22_107-27-013 FUW12_04"
remove = dat$sample.annot$sample.Name==dup.rcc
dat$count = dat$count[!remove,]
dat$sample.annot = dat$sample.annot[!remove,]

for(i in c("count","sample.annot")){rownames(dat[[i]])=dat$sample.annot$Sample.ID}
#####
# load annot
#####
annot = read.csv("input_data/CITN07 sample cohort info.csv",stringsAsFactors = F,row.names=1)
# remove the dup rcc from here as well:
head(annot)
remove = rownames(annot)==paste0(dup.rcc,".RCC")
annot = annot[!remove,]
rownames(annot) = annot$sample.ID

#####
# align annot to rccs, evaluate overlap
#####
sharedids = intersect(rownames(dat$count),rownames(annot))
setdiff(rownames(dat$count),rownames(annot))
setdiff(rownames(annot),rownames(dat$count))
annot = annot[sharedids,]
raw = dat$count[sharedids,]
#raw = log2(pmax(dat$count[sharedids,],1))

# split out controls:
neg = raw[,grepl("NEG_",colnames(raw))]
pos = raw[,grepl("POS_",colnames(raw))]
raw = raw[,!grepl("NEG_",colnames(raw))&!grepl("POS_",colnames(raw))]

######
## Signal QC: genes
######

# calculate maximum count of each gene, and save it as a signal threshold:
max.counts = apply(raw, 2, max)
#hist(log2(pmax(max.counts,1)))

# drop genes in background: all with max < 32 counts
#minrawthresh = 25
#in.bg = (apply(raw,2,max)<log2(minrawthresh))
#plot(apply(raw,2,mean),apply(raw,2,sd))
#plot(apply(raw,2,mean),apply(raw,2,max),col=1+in.bg)
#abline(h=log2(minrawthresh))

# remove low signal genes:
#raw = raw[,!in.bg]

######
# get HKs and normalize:
######
is.hk = intersect(colnames(raw),rownames(dat$gannot)[dat$gannot$CodeClass=="Housekeeping"])
# run genorm to get good subset:
temp = selectHKs(log2(pmax(raw[,is.hk], 1)), log=TRUE, minNrHKs=10, Symbols=is.hk)
selectedhks = temp$ranking[names(temp$ranking)<=12]

# calc hk geomean:
hk.factor = apply(log2(pmax(raw[,selectedhks], 1)),1,mean)

# remove low-signal lanes:
hist(hk.factor,breaks=40,col="grey")
abline(v=4)
lowsignal = hk.factor<4
raw = raw[!lowsignal,]
neg = neg[!lowsignal,]
pos = pos[!lowsignal,]
annot = annot[!lowsignal,]
hk.factor = hk.factor[!lowsignal]
# normalize:
norm = sweep(raw, 1, 2^hk.factor, "/") * 2^mean(hk.factor)
# remove HKs from analysis:
norm = norm[,setdiff(colnames(norm),is.hk)]
# log-transformed normalized data:
log2norm = log2(pmax(norm, 1))

######
## look at structure of annot:
######
# cohort as a string:
annot$cohort=factor(as.character(annot$cohort),levels=c("2","1"))
# extract patient ID:
annot$patient = substr(annot$sample.ID,1,10)
# timepoint variables:
table(annot$cohort,annot$timepoint)
table(annot$course,annot$timepoint)
# there's not an single time variable, but rather the combo of timepoint and course gives time.
annot[annot$patient=="107-11-015",]
# and it looks like the timepoint and course columns have errors anyway - or at least, they differ from the sample.id column

# extract time from sample ID:
annot$time = substr(annot$sample.ID,12,16)
unique(annot$time)
annot$time[annot$time=="CID08"]="C1D08"
annot$time[annot$time=="CID22"]="C1D22"
annot$time[annot$time=="CID01"]="C1D01"
annot$time[annot$time=="CID-7"]="C1D-7"
# recode time variable to accommodate weird baselines:
annot$time[annot$time=="C1D-7"] = "baseline"
annot$time[(annot$time=="C1D01")&(annot$cohort==2)] = "baseline"

annot$time = factor(annot$time,
                    levels = c("baseline","C1D01","C1D08","C1D15","C1D22",
                               "C2D01","C2D08","C2D15","C3D01","C4D01",
                               "FUW04","FUW12"))
table(annot$patient,annot$time)
table(annot$time,annot$cohort)

### assign colors:
timecols = colorspace::diverge_hcl(length(unique(annot$time)))
names(timecols)=levels(annot$time)
annot$timecol = timecols[annot$time]

cohortcols = c("cornflowerblue","orange")
names(cohortcols) = c("2","1")
annot$cohortcol = cohortcols[annot$cohort]
## -> so create a time variable:
#annot$time = factor(paste0(annot$course,annot$timepoint),
#                       levels = c( "C1d1","C1d8","C1d15","C1d22",
#                                   "C2d1","C2d8","C2d15","C2d22",
#                                   "C3d1","C4d1","FUWd4","FUWd12"))

######
# load gene set matrix and align to norm:
######
gannot = as.matrix(read.csv("input_data/PCI gene set matrix.csv",row.names = 1,stringsAsFactors = F))
gannot = gannot[match(colnames(norm),rownames(gannot)),]
gannot = replace(gannot,is.na(gannot),0)

save(raw,norm,log2norm,annot,gannot,hk.factor,max.counts,file="data_post_QC_and_normalization/CITN07 data ready for analysis October2018.RData")
save(raw,norm,log2norm,annot,gannot,hk.factor,max.counts,file="../NanoString_cell_scores_and_differential_expression/data/CITN07 data ready for analysis October2018.RData")
write.csv(log2norm, file = "data_post_QC_and_normalization/CITN07 log2-transformed normalized expression data ready for analysis October2018.csv")
write.csv(norm, file = "data_post_QC_and_normalization/CITN07 normalized expression data ready for analysis October2018.csv")
write.csv(annot, file = "data_post_QC_and_normalization/CITN07 sample annotation data ready for analysis October2018.csv")
write.csv(gannot, file = "data_post_QC_and_normalization/CITN07 gene annotation data ready for analysis October2018.csv")

NanoString_QC_and_normalization/CITN07 data qc and normalization.r


a = c(1,1,1,1,1,1,1,2,2,2,2,2,2,2)
b = c("A","A","A","B","B","B","B","C","C","D","D","D","D","D")
c = c(60,20,20,80,5,5,5,50,50,25,25,25,20,5)
dat = data.frame(Group=a, Member=b, Percentage=c)

table_values = c("2", "4", "2", "1")
table_total = c("A", "B", "C", "D")
tab = data.frame(Type=table_total, Value=table_values)

ggplot(dat, aes(x=Member, y=Percentage)) +
  geom_bar(stat="identity", position="dodge", fill="white", colour="black") +
  geom_text(aes(x=table_total, label=table_values), y=-2, data=tab)


basePic <- function() {
  data <- read.csv("data", header=F)

  km <- kmeans(data,6)
  plot(data[,1],data[,2],col=km$cluster)
}

plotPs <- function() {
  ps <- read.csv("data", heade=F)

  points(as.matrix(ps), col="red",pch=20)

}


library(ggplot2)
library(ggthemes)

user <- read.csv(file="usernumber.csv",sep="\t",head=F)
user$date <- as.POSIXct(as.character(user$V2),format="%d.%m.%Y %H:%M")
ggplot(user,aes(user$date,user$V1)) + geom_smooth() + theme_light() + scale_x_datetime("Date") + scale_y_continuous("# of users")
ggsave("users.pdf")


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of wonky world model predictions"
#' author: "Judith Degen"
#' date: "December 6, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/models/wonky_world/results/")
source("rscripts/helpers.r")

#' get model predictions
load("data/mp.RData")
mp = read.table("data/parsed_marble_results.tsv", quote="", sep="\t", header=T)
nrow(mp)
head(mp)
wr = read.table("data/parsed_wonky_results.tsv", quote="", sep="\t", header=T)
head(wr)
wr = droplevels(subset(wr, Wonky == "true"))
rownames(wr) = paste(wr$Item, wr$QUD, wr$Alternatives, wr$SpeakerOptimality, wr$SmoothingBW)
mp$WonkyProbability = wr[paste(mp$Item,mp$QUD, mp$Alternatives, mp$SpeakerOptimality, mp$SmoothingBW),]$PosteriorProbability
#summary(mp)
#mp$QUDOpt = as.factor(paste(mp$QUD,mp$SpeakerOptimality))
mp$NormAllPrior = mp$PriorProbability.15/rowSums(mp[,6:21])

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/1_sinking-marbles-prior/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = paste(priorexpectations$effect,priorexpectations$object)
mp$PriorExpectation = priorexpectations[as.character(mp$Item),]$expectation/100
save(mp, file="data/mp.RData")

expectations = ddply(mp, .(Item, QUD, Alternatives, SmoothingBW, SpeakerOptimality, NormAllPrior,PriorExpectation), summarize, expectation=sum(PosteriorProbability*seq(1,15,by=1)))
head(expectations)
expectations$ExpectationProportion = expectations$expectation/15
expectations$QUDOpt = as.factor(paste(expectations$QUD,expectations$SpeakerOptimality))

ggplot(expectations, aes(x=NormAllPrior,y=ExpectationProportion,color=as.factor(SpeakerOptimality),shape=QUD,group=QUDOpt)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives)
ggsave("graphs/marble_expectations.pdf",width=25,height=7)

ggplot(expectations, aes(x=ExpectationProportion,fill=QUD)) +
  geom_histogram(position="dodge") +
  facet_grid(SpeakerOptimality~Alternatives,scales="free_y")
ggsave("graphs/expectation_histograms.pdf",width=12)

subexp = subset(expectations, SpeakerOptimality == 2 & QUD == "how-many" & SmoothingBW == "bwdf")
ggplot(subexp, aes(x=NormAllPrior,y=ExpectationProportion)) +
  geom_point() +
  geom_smooth() +
  facet_wrap(~Alternatives)
ggsave("graphs/expectations_spopt2_qudhowmany_bwdf.pdf",width=12,height=7)

ggplot(subset(subexp,Alternatives=="0_basic"), aes(x=PriorExpectation,y=ExpectationProportion)) +
  geom_point() +
  geom_smooth(method="lm") +
#  geom_abline(intercept=0,slope=1,color="gray70")  +
  scale_x_continuous(name="Prior expectation") +
  scale_y_continuous(name="Posterior expectation")
ggsave("graphs/expectations_bypriorexp_spopt2_qudhowmany_alternativesbasic.pdf",width=12,height=7)
ggsave("graphs/modelpredictions_expectations.pdf")

dd = droplevels(subset(subexp,Alternatives=="0_basic"))
m = lm(ExpectationProportion ~ PriorExpectation, data=dd)
summary(m)

ggplot(subset(mp, Alternatives=="0_basic" & SpeakerOptimality == 2 & QUD == "how-many" & NumState == 15), aes(x=NormAllPrior,y=PosteriorProbability,color=SmoothingBW)) +
  geom_point() +
  #geom_smooth() +
  #geom_abline(intercept=0,slope=1,color="gray70") +
  scale_x_continuous(name="Prior probability of all-state") +
  scale_y_continuous(name="Posterior probability of all-state")
ggsave("graphs/modelpredictions_allstate.pdf")

# get empirical posteriors:
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/3_sinking-marbles-nullutterance/results/data/r.RData")
head(r)
some = subset(r, quantifier == "Some" & Proportion == 100)
some$Item = as.factor(paste(some$effect, some$object))
head(some$normresponse)
# get model predictions for all-state with basic alts, spopt==2, and qud==how-many
mp_some_allstate = subset(mp, Alternatives=="0_basic" & SpeakerOptimality == 2 & QUD == "how-many" & NumState == 15)
head(mp_some_allstate)
nrow(mp_some_allstate)

agr = aggregate(normresponse ~ Item,data=some,FUN=mean)
agr$CILow = aggregate(normresponse ~ Item,data=some, FUN=ci.low)$normresponse
agr$CIHigh = aggregate(normresponse ~ Item,data=some,FUN=ci.high)$normresponse
agr$YMin = agr$normresponse - agr$CILow
agr$YMax = agr$normresponse + agr$CIHigh
row.names(agr) = agr$Item
head(agr)
mp_some_allstate$EmpiricalPosterior = agr[as.character(mp_some_allstate$Item),]$normresponse
mp_some_allstate$YMin = agr[as.character(mp_some_allstate$Item),]$YMin
mp_some_allstate$YMax = agr[as.character(mp_some_allstate$Item),]$YMax

ggplot(mp_some_allstate, aes(x=PosteriorProbability, y=EmpiricalPosterior)) +
  geom_point() +
  geom_smooth() +
#  geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(x=0,slope=1,color="gray70") +
  scale_x_continuous(name="Model predicted posterior all-state probability") +
  scale_y_continuous(name="Empirical mean all-state probability") +
  facet_wrap(~SmoothingBW)
ggsave("graphs/model-empirical.pdf")
cor(mp_some_allstate$PosteriorProbability,mp_some_allstate$EmpiricalPosterior) # .51

head(subexp)
# get empirical expectations:
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/5_sinking-marbles-nullutterance-priordv/results/data/r.RData")
head(r)
some = subset(r, quantifier == "Some")
some$Item = as.factor(paste(some$effect, some$object))
rownames(some) = some$Item
# plot subject variability
ggplot(some, aes(x=ProportionResponse)) +
  geom_histogram() +
  facet_wrap(~workerid)
ggsave("graphs/some_subjectvariability.pdf",width=12,height=10)

# mark the people who chose at most 3 middle values to respond to "some" with
some$NoVariance = as.factor(ifelse(some$workerid %in% c("8","24","27","37","52","54","61","72","79","108","113"),1,0))

agr = aggregate(ProportionResponse ~ Item,data=some,FUN=mean)
agr$CILow = aggregate(ProportionResponse ~ Item,data=some, FUN=ci.low)$ProportionResponse
agr$CIHigh = aggregate(ProportionResponse ~ Item,data=some,FUN=ci.high)$ProportionResponse
agr$YMin = agr$ProportionResponse - agr$CILow
agr$YMax = agr$ProportionResponse + agr$CIHigh
row.names(agr) = agr$Item

subexp$EmpiricalMean = agr[as.character(subexp$Item),]$ProportionResponse
subexp$YMin = agr[as.character(subexp$Item),]$YMin
subexp$YMax = agr[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions.pdf",width=12,height=7)

cors = ddply(subexp, .(Alternatives), summarize, Correlation=cor(ExpectationProportion,EmpiricalMean))
cors # best correlation is with basic alternatives (some, none, all -- .6) and basic+many/most/few/afew (-- .59)

# split up by subject vairance on "some" trials
agr = aggregate(ProportionResponse ~ Item + NoVariance,data=some,FUN=mean)
agr$CILow = aggregate(ProportionResponse ~ Item + NoVariance,data=some, FUN=ci.low)$ProportionResponse
agr$CIHigh = aggregate(ProportionResponse ~ Item + NoVariance,data=some,FUN=ci.high)$ProportionResponse
agr$YMin = agr$ProportionResponse - agr$CILow
agr$YMax = agr$ProportionResponse + agr$CIHigh
agrgood = subset(agr, NoVariance == 0)
agrbad = subset(agr, NoVariance == 1)
row.names(agrgood) = agrgood$Item
row.names(agrbad) = agrbad$Item
nrow(agrgood)
nrow(agrbad)
subexp$EmpiricalMean_good = agrgood[as.character(subexp$Item),]$ProportionResponse
subexp$YMin_good = agrgood[as.character(subexp$Item),]$YMin
subexp$YMax_good = agrgood[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean)) +
  geom_point() +
  #geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions_good.pdf",width=12,height=7)

subexp$EmpiricalMean_bad = agrbad[as.character(subexp$Item),]$ProportionResponse
subexp$YMin_bad = agrbad[as.character(subexp$Item),]$YMin
subexp$YMax_bad = agrbad[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean_bad)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin_bad,ymax=YMax_bad)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions_bad.pdf",width=12,height=7)

cors = ddply(subexp, .(Alternatives), summarize, Correlation=cor(ExpectationProportion,EmpiricalMean))
cors # best correlation is with basic alternatives (some, none, all -- .6) and basic+many/most/few/afew (.22)

# plot wonkiness
wonk = unique(mp[,c("PriorExpectation","WonkyProbability","Item","SmoothingBW","Alternatives","SpeakerOptimality","QUD")])
nrow(wonk)
ggplot(wonk, aes(x=PriorExpectation,y=WonkyProbability, color=as.factor(SpeakerOptimality), shape=QUD)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives,scales="free")
ggsave("graphs/wonky_probabilities.pdf",width=20,height=7)

wonk = unique(mp[,c("NormAllPrior","WonkyProbability","Item","SmoothingBW","Alternatives","SpeakerOptimality","QUD")])
nrow(wonk)
ggplot(wonk, aes(x=NormAllPrior,y=WonkyProbability, color=as.factor(SpeakerOptimality), shape=QUD)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives,scales="free")
ggsave("graphs/wonky_probabilities_byallprior.pdf",width=20,height=7)


#------------------ choose only some time windows
if (length(selct_TW) > nrow(Timewindows)) selct_TW = c(1:nrow(Timewindows))
Timewindows = Timewindows[selct_TW,]

#-------------add a column to the data saying if it is day or night

# get time of start in minutes (temp):
temp=t(as.data.frame(strsplit(format(metadata$real_time_start,"%H:%M:%S"),split = ':')))
temp= as.data.frame(temp)
names (temp)= c("hr","min", "sec")
temp <- temp %>% mutate (time= as.numeric(as.character(hr))*60+ as.numeric(as.character(min)))

# add the column to metadata and Mins, get light conditions in minadd
metadata$start_time_min =temp$time
Mins=left_join (Mins,metadata)
Mins= Mins %>% mutate(timeofday = (start_time_min+Bin) %% (24*60)) %>%
  mutate (lightcondition = ifelse(timeofday >LIGHT_ON & timeofday <LIGHT_OFF, "DAY","NIGHT")) %>%
  select (-timeofday, -start_time_min)
Mins$lightcondition = as.factor(Mins$lightcondition)
minadd= Mins %>% select (ID, Bin, lightcondition)

#----------------------- create result table (Multi_datainput_m, behav_gp)

#--choose the behavior grouping used (both defined during grouping_variables.r called from Timewindows_8.r)

if (groupingby == "Berlin"){
  behav_gp =behav_gp
} else if (groupingby == "Jhuang") {
  behav_gp = behav_jhuang
}

#-- add lightcondition to behav_gp
behav_gp = left_join(behav_gp, minadd)

#-- create Multi_datainput: 1 for character elements
Multi_datainput = behav_gp %>% group_by(ID) %>%
  summarise_if(is.character,funs(sum)) %>% select (ID)

#-- create Multi_datainput: 2 get a value for each time window,:
#--- 1 take all data for a window

for (i in c(1:nrow(Timewindows))){
  # filer to data in the time window
  if (Timewindows$time_reference [i] =="Bin"){
    windowdata = behav_gp %>% filter (Bin > Timewindows [i,2] & Bin < Timewindows [i,3])
  }else if (Timewindows$time_reference[i] =="Bintodark"){
    windowdata = behav_gp %>% filter (bintodark > Timewindows [i,2] & bintodark < Timewindows [i,3])
  }else if (Timewindows$time_reference[i] =="lightcondition"){
    windowdata = behav_gp %>% filter (lightcondition == Timewindows [i,2] )
  }else print ("error in timewindows table")

  #based on the get_windowsummary() function, calculate values and add it to the result data frame
  Multi_datainput = inner_join (Multi_datainput,get_windowsummary(windowdata, i=i), by ="ID")

}

#-- save data for later use

write.table(Multi_datainput, paste0(onlinemin,'/timedwindowed_',groupingby,"_",Name_project,'.csv'), sep = ';',row.names = FALSE)

#-- add groupingvar, take ID out
Multi_datainput_m = left_join(Multi_datainput, metadata %>% select (ID, groupingvar), by= "ID")

Multi_datainput_m = Multi_datainput_m %>%
  mutate (groupingvar = as.factor(groupingvar))%>%
  select (-ID)

#-- alternatively add groupingvar + confoundvar
if (!is.na(Projects_metadata$confound_by)){
  Multi_datainput_m2 = left_join(Multi_datainput, metadata %>% select (ID, groupingvar, confoundvar), by= "ID")

  Multi_datainput_m2 = Multi_datainput_m2 %>%
    mutate (groupingvar = as.factor(groupingvar))%>%
    select (-ID)
}


#' Estimating the direct sampling (DSC) environmental contours
#'
#' @description
#' This function estimates the direct sampling (DSC) environmental contours with standardization, as proposed in Huesby et al. (2015),
#' for a given sample data set or a fitted joint distribution of class \code{ht} or \code{wln}.
#'
#' @param object either a fitted joint distribution of class \code{wln} or \code{ht}, or an existing sample data
#' set containing \code{hs} and \code{tp} as columns. See details.
#'
#' @param output_rp the required return periods (in years) for the estimated contours.
#'
#' @param npy the (optional) number of data points per year. This argument is only needed if the input
#' \code{object} is a sample data set.
#'
#' @param n_point the number of points to output around each contour. The default value is 100.
#'
#' @details
#' The direct sampling contour is estimated in the origianl physical scales of \eqn{hs} and \eqn{tp} by direct
#' Monte Carlo simulations rather than applying the RosenBlatt transformation.
#'
#' The function can be applied to an existing sample set, which can be generated by function \code{\link{sample_jdistr}}
#' or otherwise by importing a CSV file using function \code{\link[data.table]{fread}}. The input sample data
#' object must contain \code{hs} and \code{tp} as columns. The user must also specify the number of points per year
#' \code{npy} and a valid \code{output_rp}, i.e. the maximum \code{output_rp} must be shorter than the total
#' duration of the data set.
#'
#' Alternatively this function can be applied to a fitted joint distribution object
#' generated by function \code{\link{fit_ht}} or \code{\link{fit_wln}}.  When applied to a
#' \code{wln} or \code{ht} object, the contour estimation makes use of the importance
#' sampling technique proposed in Huseby et. al. (2014) to improve the efficiency of the function.
#'
#' @return
#' A set of estimated DSC contours with the specified return periods in the format
#' of a \code{data.table} with \code{rp}, \code{hs}, and \code{tp} as columns.
#'
#' @examples
#' # Estimating DSC contours based on a fitted model
#' data(ww3_pk)
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 50, dep_thresh_count = 500)
#' ec_ht = estimate_dsc(object = ht, output_rp = c(10,100,1000,10000))
#' plot_ec(ec = ec_ht, raw_data = ww3_pk)
#'
#' # Estimating DSC contours based on a sample data set
#' data(ww3_ts)
#' ec_data = estimate_dsc(object = ww3_ts, output_rp = c(.5, 1, 2), npy = ww3_ts[, .N/10])
#' plot_ec(ec = ec_data, raw_data = ww3_ts)
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}, \code{\link{sample_jdistr}}, \code{\link{plot_ec}}
#'
#' @references
#' Huseby, A., Vanem, E., Natvig, B., 2014. A new Monte Carlo method for environmental contour estimation.
#' Conference Proceedings. DOI:10.1201/b17399-286.
#'
#' Huseby, A., Vanem, E., Natvig, B., 2015. Alternative environmental contours for structural reliability
#' analysis. Struct. Saf. 54, 32-45.
#'
#' @export
estimate_dsc = function(object, output_rp, npy = NULL, n_point = 100){

  if("wln" %in% class(object)){

    res = .estimate_dsc_from_wln(wln = object, output_rp = output_rp, n_point = n_point)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("ht" %in% class(object)){

    res = .estimate_dsc_from_ht(ht = object, output_rp = output_rp, n_point = n_point)
    if(!is.null(npy)){
      warning("Argument npy will be imported from the provided joint distribution object.  The supplied npy is ignored.")
    }

  }else if("data.table" %in% class(object)){

    if(is.null(npy)){
      stop("Argument npy must be provided for estimating contours from sample data.")
    }else{
      invalid_rp = output_rp[output_rp>object[, .N/npy]]
      if(length(invalid_rp)==length(output_rp)){
        stop("All output_rp values are invalid as they require extrapolation. Consider fitting a joint distribution first.")
      }else if(length(invalid_rp)>=1 & length(invalid_rp)<length(output_rp)){
        warning("Certain output_rp values are ignored as they requires extrapolation. Consider fitting a joint distribution first.")
      }
      output_rp = setdiff(output_rp, invalid_rp)
    }

    res = cbind(
      rp=rep(output_rp, each=n_point+1),
      .estimate_dsc_from_data(sample_data = object, ex_prob = 1/output_rp/npy, n_point = n_point))

  }else{

    stop("The input object must be of class ht, wln or data.table.")
  }

  return(res)
}

.estimate_dsc_from_data = function(sample_data, ex_prob, n_point){

  ## Standardization
  ec_data = sample_data[, .(hs, tp)]
  st_mu = colMeans(ec_data)
  st_sigma = apply(ec_data, 2, sd)
  st_rho = cor(ec_data)[1,2]
  ec_data[, hs:= (sample_data$hs-st_mu["hs"])/st_sigma["hs"]]
  ec_data[, tp:= ((sample_data$tp-st_mu["tp"])/st_sigma["tp"]-st_rho*hs)/sqrt(1-st_rho^2)]

  ## C_theta calculation
  theta = seq(0, 2*pi, length.out = n_point+1)
  d_theta = 2*pi/(n_point)
  calc = data.table(theta = theta, ex_prob = rep(ex_prob, each=n_point+1))
  calc[, c_theta:=quantile(cos(theta[1])*ec_data$tp+sin(theta[1])*ec_data$hs, 1-ex_prob, na.rm=T), .(theta)]
  calc[, c_theta_left:=c_theta[c(.N-1, 1:(.N-2), .N-1)], .(ex_prob)]
  calc[, c_theta_right:=c_theta[c(2:.N, 2)], .(ex_prob)]
  calc[, c_theta_prime:=(c_theta_right-c_theta_left)/(2*d_theta)]
  calc[, tp:=(c_theta*cos(theta)-c_theta_prime*sin(theta))]
  calc[, hs:=(c_theta_prime*cos(theta)+c_theta*sin(theta))]

  ## Rev-standardization
  st_data = calc[, .(hs, tp)]
  calc[, hs:=st_sigma["hs"]*st_data$hs+st_mu["hs"]]
  calc[, tp:=st_sigma["tp"]*(st_rho*st_data$hs+st_data$tp*sqrt(1-st_rho^2))+st_mu["tp"]]

  ## Return
  res = calc[, .(hs, tp)]

}

.estimate_dsc_from_wln = function(wln, output_rp, n_point){

  out_list = list()
  for(this_rp in output_rp){
    this_sample_data = .sample_wln_is(wln = wln, target_rp = this_rp)
    n_sim = round(wln$npy*this_rp*.target_rp_ub)
    tail_prob = 1/(this_rp*.target_rp_lb*wln$npy)
    min_r = qnorm(1-tail_prob)
    ex_prob = 1-(n_sim*(1-1/this_rp/wln$npy)-n_sim*(1-exp(-min_r^2/2)))/this_sample_data[,.N]
    out_list[[as.character(this_rp)]] = cbind(
      rp = this_rp,
      .estimate_dsc_from_data(sample_data = this_sample_data, ex_prob = ex_prob, n_point = n_point))
  }
  res = rbindlist(out_list)
  return(res)
}

.estimate_dsc_from_ht = function(ht, output_rp, n_point){

  out_list = list()
  for(this_rp in output_rp){
    this_sample_data = .sample_ht_is(ht = ht, target_rp = this_rp)
    n_sim = round(ht$npy*this_rp*.target_rp_ub)
    tail_prob = 1/(this_rp*.target_rp_lb*ht$npy)
    min_r = qnorm(1-tail_prob)
    ex_prob = 1-(n_sim*(1-1/this_rp/ht$npy)-n_sim*(1-exp(-min_r^2/2)))/this_sample_data[,.N]
    out_list[[as.character(this_rp)]] =  cbind(
      rp = this_rp, .estimate_dsc_from_data(
        sample_data = this_sample_data,
        ex_prob = ex_prob, n_point = n_point))
  }
  res = rbindlist(out_list)
  return(res)
}


#!/usr/bin/Rscript

options(warn=-1)
args<-commandArgs(TRUE)
target=read.table(args[1])$V1
subject=read.table(args[2])$V2
cat(ks.test(target,subject)$p.value,"\n")


yearest <- function( diagnosis, yeardesign, stringsub = "one == 1"){

	diagnosis <- sapply( diagnosis, function(j) j)

	yeardesign <- sapply( yeardesign, function(j) j)

	stiringsub <- paste0("age < 65 & ", srtingsub)

	lapply(diagnosis, function(i){

		x <- do.call(rbind,
			lapply(yeardesign, function(j){
				as.data.frame(eval(bquote(
					svymean(~.(as.name(i)),
					subset(get(j), eval(parse(text=stringsub))),
					na.rm=T)
				)))
			})
		)

		y <- do.call(rbind,
			lapply(yeardesign, function(j){
				as.data.frame(eval(bquote(
					unwtd.count( ~.(as.name(i)),
					subset( get(j), eval(parse( text=stringsub))),
					na.rm=T)
				)))
			})
		)

		merge(x, y, by=0, all=TRUE)

	})

}


# "XGBoost Mid to higher 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(
	SeverityHigherMid ~
	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(
	SeverityHigherMid ~
		temperature +
		Population100000 +
		DownwardSolarRadiation_kwm2 +
		temperature_past1d_max_diff +
		DifDateRain +
		relativeHumidity +
		precip1Hour +
		windSpeed_ms +
		temperature_past1d_mean_diff +
		temperature_past1d_min_diff +
		Population_over_65_100000 +
		Month +
		Mean_income_city_2015 +
		Green_area_percent +
		holiday_flag +
		SexRatioF +
		Age_median_city +
		RainySeason +
		Hour
)

##################################################################
###   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()

```


#!/usr/bin/env Rscript

# Init system
library('agricolae')

# Load plant data
data.p <- read.table('rnaSeqModel_plant.txt')
rnames<- data.p[,1]
data.p <- data.frame(data.matrix(data.p[,2:ncol(data.p)]))
row.names(data.p) <- rnames

# Load bacterial data
data.b <- read.table('rnaSeqModel_bacterium.txt')
rnames<- data.b[,1]
data.b <- data.frame(data.matrix(data.b[,2:ncol(data.b)]))
row.names(data.b) <- rnames

# Make output variables
out.p <- data.frame(matrix(, nrow = nrow(data.p), ncol = 5))
out.b <- data.frame(matrix(, nrow = nrow(data.b), ncol = 5))

# Prepare intermediate variables for plants
test.p <- data.frame(matrix(, nrow = 15, ncol = 2))
test.p[1,1] <- 'A'
test.p[2,1] <- 'A'
test.p[3,1] <- 'A'
test.p[4,1] <- 'B'
test.p[5,1] <- 'B'
test.p[6,1] <- 'B'
test.p[7,1] <- 'C'
test.p[8,1] <- 'C'
test.p[9,1] <- 'C'
test.p[10,1] <- 'D'
test.p[11,1] <- 'D'
test.p[12,1] <- 'D'
test.p[13,1] <- 'E'
test.p[14,1] <- 'E'
test.p[15,1] <- 'E'
temp.p <- data.frame(matrix(, nrow = 5, ncol = 2))

# Prepare intermediate variables for bacteria
test.b <- data.frame(matrix(, nrow = 15, ncol = 2))
test.b[1,1] <- 'A'
test.b[2,1] <- 'A'
test.b[3,1] <- 'A'
test.b[4,1] <- 'B'
test.b[5,1] <- 'B'
test.b[6,1] <- 'B'
test.b[7,1] <- 'C'
test.b[8,1] <- 'C'
test.b[9,1] <- 'C'
test.b[10,1] <- 'D'
test.b[11,1] <- 'D'
test.b[12,1] <- 'D'
test.b[13,1] <- 'E'
test.b[14,1] <- 'E'
test.b[15,1] <- 'E'
temp.b <- data.frame(matrix(, nrow = 5, ncol = 2))

# Perform the analysis for the plant data
for (n in 1:nrow(data.p)) {
  test.p[,2] <- t(data.p[n,])
  stats.out <- kruskal(test.p$X2, test.p$X1, console = FALSE)
  temp.p[,1] <- rownames(stats.out$groups)
  temp.p[,2] <- as.character(stats.out$groups$groups)
  temp.p <- temp.p[order(temp.p[,1]),]
  out.p[n,] <- t(temp.p[,2])
}
row.names(out.p) <- rownames(data.p)

# Perform the analysis for the bacterium data
for (n in 1:nrow(data.b)) {
  test.b[,2] <- t(data.b[n,])
  stats.out <- kruskal(test.b$X2, test.b$X1, console = FALSE, alpha = 0.2)
  temp.b[,1] <- rownames(stats.out$groups)
  temp.b[,2] <- as.character(stats.out$groups$groups)
  temp.b <- temp.b[order(temp.b[,1]),]
  out.b[n,] <- t(temp.b[,2])
}
row.names(out.b) <- rownames(data.b)

# Save and export
write.table(out.p, file = "rnaSeqModel_plant_stats.txt")
write.table(out.b, file = "rnaSeqModel_bacterium_stats.txt")
save.image(file = "rnaSeqStatsWorkspace.RData")
quit("no")


## Experiments : turn contains RS or not?

library(xtable)
source("../scripts/proc-lme.r")
source("../scripts/collate-word-feats.r")

load("word.pros.dt")
load("xprospn.dt")

turn.pros <- get.turn.pros(word.pros)

xturn.nors <- get.turn.data.nors(turn.pros, xprospn)
save(xturn.nors, file="xturn.nors")
xturn.nors.params.all <- train.test.turn(xturn.nors)
save(xturn.nors.params.all, file="xturn.nors.params.all")

turn.nors.feats <- names(xturn.nors.params.all[["x0.data"]])
print(turn.nors.feats)

turn.nors.pred.all <- pred.tune(xturn.nors.params.all, feats=turn.nors.feats, outfile="pred.turn.nors.all")
fs.turn.nors.all <- get.fs.pred(xturn.nors.params.all, feats=turn.nors.feats, outfile="fs.turn.nors.all")

nocontext <- grep("^[pnd][pndg]", turn.nors.feats, value=T, invert=T)
turn.nors.pred.nocontext <- pred.tune(xturn.nors.params.all, feats=nocontext, outfile="pred.turn.nors.nocontext")
fs.turn.nors.nocontext <- get.fs.pred(xturn.nors.params.all, feats=nocontext, outfile="fs.turn.nors.nocontext")

# only F0 and Intensity features
pcontext <- turn.nors.feats[grep("(F0|I0)",turn.nors.feats)]
turn.nors.pred.pcontext <- pred.tune(xturn.nors.params.all, feats=pcontext, outfile="pred.turn.nors.pcontext")
fs.turn.nors.pcontext <- get.fs.pred(xturn.nors.params.all, feats=pcontext, outfile="fs.turn.nors.pcontext")

## F0 and Int, no context
pros <- pcontext[grep("(F0|I0)",pcontext)]
turn.nors.pred.pros <- pred.tune(xturn.nors.params.all, feats=pros, outfile="pred.turn.nors.pros")
fs.turn.nors.pros <- get.fs.pred(xturn.nors.params.all, feats=pros, outfile="fs.turn.nors.pros")

#lex <- grep("^n\\.", turn.nors.feats, value=T)
#turn.nors.pred.lex <- pred.tune(xturn.nors.params.all, feats=lex, outfile="pred.turn.nors.lex")
#fs.turn.nors.lex <- get.fs.pred(xturn.nors.params.all, feats=lex, outfile="fs.turn.nors.lex")
#
#nonlex <- grep("^n\\.", turn.nors.feats, value=T, invert=T)
#turn.nors.pred.nonlex <- pred.tune(xturn.nors.params.all, feats=nonlex, outfile="pred.turn.nors.nonlex")
#fs.turn.nors.nonlex <- get.fs.pred(xturn.nors.params.all, feats=nonlex, outfile="fs.turn.nors.nonlex")

############################################################################
### only Intensity features
#pi0 <- turn.nors.feats[grep("I0",turn.nors.feats)]
#turn.nors.pred.pi0 <- pred.tune(xturn.nors.params.all, feats=pi0, outfile="pred.turn.nors.pi0")
#
### only F0
#pf0 <- turn.nors.feats[grep("F0",turn.nors.feats)]
#turn.nors.pred.pf0 <- pred.tune(xturn.nors.params.all, feats=pf0, outfile="pred.turn.nors.pf0")
#fs.turn.nors.pf0 <- get.fs.pred(xturn.nors.params.all, feats=pf0, outfile="fs.turn.nors.pf0")
#
### only Intensity features
#ti0 <- pros[grep("I0",pros)]
#turn.nors.pred.ti0 <- pred.tune(xturn.nors.params.all, feats=ti0, outfile="pred.turn.nors.ti0")
#
### only F0
#tf0 <- pros[grep("F0",pros)]
#turn.nors.pred.tf0 <- pred.tune(xturn.nors.params.all, feats=tf0, outfile="pred.turn.nors.tf0")
#fs.turn.nors.tf0 <- get.fs.pred(xturn.nors.params.all, feats=tf0, outfile="fs.turn.nors.tf0")

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

m.turn.nors <- glmer(is.rs ~  (1 | spk)
                + to.zscore(mean.normF0) + to.zscore(mean.normI0)
                + to.zscore(range.normF0) + to.zscore(range.normI0)
                #+ to.zscore(sd.normF0) + to.zscore(.normI0)
                + to.zscore(slope.normF0) + to.zscore(slope.normI0)
                + to.zscore(intern.pause)
                + to.zscore(abs(dur))
                , data=xturn.nors,  family = binomial(link = "logit"))
display(m.turn.nors)
xtable(get.fixef(m.turn.nors, roundval=2))

sigpros <- c("dur")
turn.nors.pred.sigpros <- pred.tune(xturn.nors.params.all, feats=sigpros, outfile="pred.turn.nors.sigpros")