#Fill in missing Age for "train" and "test"
#Use randomForest for modeling and prediction

train=read.csv('train.csv',header=T)
train1=train
train1$Pclass=as.factor(train1$Pclass)
train1$Survived=as.factor(train1$Survived)

#Fill in missing age in training data
extractTitle=function(name){
+ if (length(grep('Miss',name))>0){return ('Miss')}
+ if (length(grep('Master',name))>0){return ('Master')}
+ if (length(grep('Mrs',name))>0){return ('Mrs')}
+ if (length(grep('Mr',name))>0){return ('Mr')}
+ else {return ('other')}
+ }
Title=NULL
for (i in 1:nrow(train1)){
+ Title=c(Title,extractTitle(train1[i,'Name']))
+ }
train1.title=data.frame(train1,Title)
trainNA=train1.title[is.na(train1.title$Age),]
trainNA[trainNA$Title=='Miss',]$Age=21.00
trainNA[trainNA$Title=='Master',]$Age=3.500
trainNA[trainNA$Title=='Mrs',]$Age=35.00
trainNA[trainNA$Title=='Mr',]$Age=30.00
trainNA[trainNA$Title=='other',]$Age=44.00
trainA=train1.title[complete.cases(train1.title$Age),]
trainComplete=rbind(trainA,trainNA)
trainFinal=trainComplete[,c(2,3,5,6,7,8,10,12)]

#Fill in missing Age and Fare in test data
test=read.csv('test.csv',header=T)
test1=test
test1$Pclass=as.factor(test1$Pclass)
Survived=rep('None',nrow(test1))
test2=data.frame(test1,Survived)

test2[153,]$Fare=8.05

Title=NULL
> for (i in 1:nrow(test2)){
+ Title=c(Title,extractTitle(test2[i,'Name']))
+ }
test2.title=data.frame(test2,Title)
test2.na=test2.title[is.na(test2.title$Age),]
test2.na[test2.na$Title=='Miss',]$Age=21.00
test2.na[test2.na$Title=='Master',]$Age=3.500
test2.na[test2.na$Title=='Mrs',]$Age=35.00
test2.na[test2.na$Title=='Mr',]$Age=30.00
test2.na[test2.na$Title=='other',]$Age=44.00
test2.a=test2.title[complete.cases(test2.title$Age),]
test2.complete=rbind(test2.a,test2.na)
levels(test2.complete$Embarked)=c("","C","Q","S")
testFinal=test2.complete[,c(12,2,4,5,6,7,9,11)]

#Final model with "trainFinal" and "testFinal"
library(randomForest)
rf=randomForest(Survived~.,data=trainFinal,mtyr=2,importance=TRUE)
pred=predict(rf,testFinal)
final=data.frame(test2.complete$PassengerId,pred)
final1=final[order(final$test2.complete.PassengerId),]
names(final1)=c('PassengerId','Survived')
write.csv(final1,file='submission.csv',row.names=FALSE)


#' humrat
#'
#' Calculates humidity ratio in vapor-air mixture.
#'
#' @param p numeric  Water pressure in hPa.
#' @param pair numeric Air pressure in hPa.
#' @return humidity ratio
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  humrat
#'
#' @export
#'
#'
#'
#'

humrat=function(p,pair) {
                         ct$assign("p", as.array(p))
                         ct$assign("pa", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=p.length; i < len; i++){ res[i]=humrat(p[i],pa[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


label_train<-read.csv('../input/pbmc_5k_atac_label_v1.txt',sep = "\t",header = TRUE)

label_test<-read.csv('../input/pbmc_5k_atac_label_nextgem.txt',sep = "\t",header = TRUE)

Cross_Validation <- function(trainLabelsPath,testLabelsPath, col_Index = 1, OutputDir){
    "
    Cross_Validation
    Function returns train and test indices for 5 folds stratified across unique cell populations,
    also filter out cell populations with less than 10 cells.
    It return a 'CV_folds.RData' file which then used as input to classifiers wrappers.
    Parameters
    ----------
    TrainLabelsPath : Cell population annotations file path for trianing (.csv).
    TestLabelsPath: Cell population annotations file path for testing (.csv)
    col_Index : column index (integer) defining which level of annotation to use,
    in case of multiple cell type annotations (default is 1)
    OutputDir : Output directory defining the path of the exported file.
    "

    trainLabels <- as.matrix(trainLabelsPath)
    trainLabels <- as.vector(trainLabels[,col_Index])
    testLabels <- as.matrix(testLabelsPath)
    testLabels <- as.vector(testLabelsPath[,col_Index])

    Removed_classes <- !(table(trainLabels) > 10)
    Cells_to_Keep_train <- !(is.element(trainLabels,names(Removed_classes)[Removed_classes]))
    trainLabels <- trainLabels[Cells_to_Keep_train]

    Removed_classes <- !(table(testLabels) > 10)
    Cells_to_Keep_test <- !(is.element(testLabels,names(Removed_classes)[Removed_classes]))
    testLabels <- testLabels[Cells_to_Keep_test]

    # Split data by cell-type
    Test_Idx<- which(testLabels != '')  #all cell
    Train_Idx<- which(trainLabels != '') #all cell
    # print(Test_Idx)

    #   print(Train_Idx)
    #   print(Test_Idx)
    #   print(col_Index)
    save(Train_Idx,Test_Idx,col_Index,Cells_to_Keep_train,Cells_to_Keep_test,file = paste0(OutputDir, '/CV_folds_v1Train_nextgemTest.RData'))
}

Cross_Validation(label_train,label_test, 2, "../tmp")


if (!require("RColorBrewer")) {
install.packages("RColorBrewer")
library(RColorBrewer)
}
library(reshape2)
require(gplots)
library(gplots)
require(RColorBrewer)
args <- commandArgs()
print(args[7])
ll <- read.csv(args[5],sep=",",check.names=FALSE)
frac <- read.csv(args[10],sep=",",check.names=FALSE)
row.names(ll) <- ll[,1]
nc <-ncol(ll)-1
ll <- ll[,2:nc]
frac <- frac[,2:nc]
ll_matrix <- data.matrix(ll)
frac_matrix <- data.matrix(frac)
col = brewer.pal(11,"RdYlGn")
myBreaks=c(0, 33, 50, 75, 85, 97, 103, 110, 130, 150, 200, 1000000)
#now to save in pdf
pdf(file=args[6])
hm <- heatmap.2(ll_matrix, scale="none", Rowv=NA, Colv=NA,
                col =col, ## using your colors,
                cellnote=frac,
                notecol="black",
                notecex=0.75,
                breaks = myBreaks, ## using your breaks
                dendrogram = "none",  ## to suppress warnings
                margins=c(5,5), cexRow=1.0, cexCol=1.0,
                ylab=args[9], xlab=args[8], main=args[7],
                key=FALSE,
                lhei = c(1.5,10),
                lwid = c(1.5,10),
                trace="none")
dev.off()


testLK <- c("LK Rems-Murr-Kreis","SK Erlangen","SK Lübeck","SK Braunschweig","SK Bremerhaven","LK Heinsberg","SK Kassel",
            "SK Ludwigshafen","LK Sankt Wendel","SK Potsdam","LK Rostock","SK Leipzig","SK Halle","SK Jena")
length(testLK)

input <- testLK[c(1,7,14)];

dates
names(pDat)
names(tsE)

pDat <- tsACountry %>% filter(Country %in% input) #%>% left_join(tsE)
dTime <- as.matrix(doubTime(pDat,dates));dTime
dTime[!is.finite(dTime)]<-NA
clrs<-pDat$plotcol
dates10 <- dates[(length(pDat)-10+1):length(pDat)]
counts <- table(dTime)
barplot(dTime,
        main="Doubling time",
        xlab="Date",
        ylab="Doubling time (days)",
        beside=TRUE,
        col = clrs,
        legend = input$countryGrowthRate,
        args.legend = list(bty = "n", x = "topleft"))

RKI_JSON$features$type

length(ddReg)

pDat <- tsSub(tsACountry, tsACountry$Country %in% input)
x<-tsACountry
subset<- tsACountry$Country  %in% input
xSub<-x[subset, dateCols(x)]
colSums(xSub)

dTime <- round(doubTime(pDat, dates), 1)


context("tree calculations")

test_that("balanced tree order calculations return correct results", {
  r_vals <- c(3,4,5)
  h_vals <- c(3,4,5)
  expected <- c(40, 341, 3906)
  observed <- orderBalancedTree(r_vals, h_vals)

  expect_equal(expected, observed)
})


# From David Norris

require(Hmisc)

df <- upData(mtcars,
             cyl=factor(cyl,levels=2*(2:4),labels=paste(2*(2:4),"cyl", sep="-")),
             am=factor(am,levels=0:1,labels=c("automatic","manual")),
             gear=factor(gear,levels=3:5,labels=paste(3:5,"speed", sep="-")),
             labels=c(
               mpg="Miles per gallon"
               ,cyl="Number of cylinders"
               ,disp="Displacement"
               ,hp="Gross horsepower"
               ,drat="Rear axle ratio"
               ,wt="Weight"
               ,qsec="1/4 mile time"
               ,am="Transmission type"
               ,gear="Number of forward gears"
               ,carb="Number of carburetors"
               ),
             units=c(
               wt="lb/1000"
               ,disp="in^3"
               ,qsec="sec"
               ),
             drop='vs'
             )
contents(df)


# map-el-salv-gsheet.r
# andy south 201907

# script to load data referenced by municipio from a googlesheet and make a map from them
# you should be able to edit data in the googlesheet and rerun to get a different map

# this could be first steps to a simple surveillance system

# next steps
# ODK form to modify the googlesheet
# shinyapp to allow replotting of map from the web
# add date column to the googlesheet

# possible to get shinyapp to check for changes in the gsheet ?
# but even as it is, is great

library(sf)
library(tidyverse)
library(tmap)
library(googledrive)

folder <- 'data\\'
# uses gadm polygons, there are also some local ones available that may be more accurate
poly_file <- paste0(folder,'gadm36_SLV_2.shp') #or could load data from GADM package

# read polygons into R
sfpolys <- sf::st_read(poly_file)

# url of googlesheet containing data referenced by municipio name
# should be able to go to this url and modify data to change the map
gsheet_url <- "https://docs.google.com/spreadsheets/d/1C8RkT5XeD4F7gL35yJQzyxgrzvf1OymoZkO04ahOdjg/edit?usp=sharing"

# wow this worked and sorted authentication for me
# saves csv locally - but do I need to save, can I just read directly into R object ?
googledrive::drive_download("el-salvador-municipios-r-test", type = "csv",overwrite=TRUE)

#read data from the saved csv
df_munis <- read_csv("el-salvador-municipios-r-test.csv")

# join data to polygons
sfcases <- df_munis %>%
  left_join(sfpolys, by = c(Municipio = 'NAME_2')) %>%
  st_sf()

# static plot
# plot borders first then polygons with cases
tmap_mode(mode = "plot")
tmap::tm_shape(sfpolys) + tm_borders() +
  tm_shape(sfcases) + tm_polygons("dengue")

# or create interactive plot (here via tmap, could use mapview too)
# popupvars show when you click on hover
tmap_mode(mode = "view")
tm <- tmap::tm_shape(sfpolys) + tm_borders() +
            tm_shape(sfcases) + tm_polygons("dengue", popup.vars = c("dengue","zika"))

print(tm)


nodedepth <- function(tree, node){
  # Count number of nodes of each 'node' to root of 'tree'

  depth <- c()
  for(i in node){
    ct <- 0
    nb <- tree$edge[tree$edge[ ,2] == i,1]
    if(length(nb) > 0) ct <- 1
    while(length(nb) > 0){
      nb <- tree$edge[tree$edge[ ,2] %in% nb,1]
      if(length(nb) > 0) ct <- ct + 1
    }
    depth <- c(depth, ct)
  }
  return(depth)
}


library("ROCR")
library("nnet")
library("ResourceSelection")

data = read.csv("datasets/CardiacDataAdj.csv",header = T)
data.continous = keep(data, function(x) {!(all(x %in% c(0,1,0.5)))})
data.categorical = keep(data, function(x) {all(x %in% (c(0,1,1.5)))})
for (i in c(14,17:31)){
  data[[i]] = factor(data[[i]])
} #cast to factor
for (i in names(data.continous)){
  outliers[[i]] = boxplot.stats(data.continous[,i])$out
} #ensure that no outliers exist

training = head(data,471)
testing = tail(data,117)

# start with all variables minus collineary variables
start_back_any = glm(any.event ~ . -basedp -pkhr -dp -X.mphr.b. -dpmaxdo -newMI -newCABG - newPTCA - death, data = training, family = 'binomial',control = list(maxit = 50))
end_back_any = step(start_back_any)

start_forw_any = glm(any.event ~ 1 , data = training, family = 'binomial',control = list(maxit = 50))
end_forw_any = step(start_forw_any, direction='forward',scope=formula(start_back_any))

start_both_any = glm(any.event ~ 1 , data = training, family = 'binomial',control = list(maxit = 50))
end_both_any = step(start_forw_any, direction='both',scope=formula(start_back_any))

car::vif(end_back_any) #check collinearity
#check linearity between  independent variables and log odds.
probabilities <- end_back_any %>% predict(training, type = "response")
mydata <- training %>%
  select("dobEF")
predictors <- c("dobEF")
mydata <- mydata %>%
  mutate(logit = log(probabilities/(1-probabilities))) %>%
  gather(key = "predictors", value = "predictor.value", -logit)
ggplot(mydata, aes(logit, predictor.value))+
  geom_point(size = 0.5, alpha = 0.5) +
  geom_smooth(method = "loess") +
  theme_bw() +
  facet_wrap(~predictors, scales = "free_y")

#Mc Fadden Pseudo R^2
ll.null <- end_back_any$null.deviance/-2
ll.proposed <- end_back_any$deviance/-2
(ll.null - ll.proposed) / ll.null
1 - pchisq(2*(ll.proposed - ll.null), df=(length(end_back_any$coefficients)-1)) # pseudo R^2 p-value
hoslem.test(end_back_any$y, fitted(end_back_any), g=10) #we canno't reject H0

#ROC curve training data
pred_back =  prediction(end_back_any$fitted.values,training$any.event)
eval_back = performance(pred_back,"acc")
plot(eval_back)
roc = performance(pred_back, "tpr","fpr")
plot(roc,colorize = T,main="ROC curve, any event, training data",ylab="True Positive",xlab="False Positive")
abline(a=0,b=1)
auc = performance(pred_back,"auc")
auc = unlist(slot(auc,"y.values"))
auc = round(auc,4)
legend(.7,.2,auc,title="AUC")

#ROC curve testing data
pred_back =  predict(end_forw_any,testing,type='response')
pred_back = prediction(pred_back,testing$any.event)
roc = performance(pred_back, "tpr","fpr")
plot(roc,colorize = T,main="ROC curve, any event, testing data",ylab="True Positive",xlab="False Positive")
abline(a=0,b=1)
auc = performance(pred_back,"auc")
auc = unlist(slot(auc,"y.values"))
auc = round(auc,4)
legend(.7,.2,auc,title="AUC")

-basebp -pkhr -dp -dobEF -X.mphr.b. -dpmaxdo


library(ggplot2)
library(grid)
library(bigWig)

preprocess<-TRUE
norm<-FALSE
if(norm==TRUE){
    print("Using normalised data!")
    normstring<-'.window250norm'
}else{
    normstring<-NULL
}
hw<-3000
stepp<-1

get_metaplot<-function(bedfile,bw,hw,stepp,region_name){
    cat("Metaplotting! (",region_name,")\n")
    res<-meta.subsample(bedfile,bw,NULL,halfWindow=hw,step=stepp)
    lv<-colMeans(res[[1]])
    uq<-res[[2]]
    lq<-res[[3]]
    d<-seq(-length(lv)/2,length(lv)/2-1)
    region<-rep(region_name,length(lv))
    dl<-data.frame(d,lv,uq,lq,region_name)
    return(dl)
}

plot_metaplot<-function(dl,dataname){
    cat("Plotting!(",dataname,")!\n")
    mytheme<-theme(plot.margin=unit(c(2,2,2,2),"cm"),axis.title.x=element_text(vjust=-0.2),axis.title.y=element_text(angle=90,vjust=0.2),plot.title=element_text(size=15,vjust=1.4))+theme_bw()
    region_cols<-c("firebrick1","orange1","turquoise3","gray")

    ggplot(dl,aes(x=d,y=lv,colour=region_name,group=region_name))+geom_point(cex=0.5,show_guide=FALSE)+facet_grid(~region_name)+mytheme+xlab("Distance to centre (bp)")+ylab("Average ChIP-seq signal")+scale_colour_manual(values=region_cols)+ggtitle(paste0("Metagene plot (",dataname,")"))+geom_ribbon(aes(ymin=lq,ymax=uq,alpha=0.3,color=NULL,fill=region_name),show_guide=FALSE)+scale_fill_manual(values=region_cols)
    ggsave(paste0(dataname,normstring,".pdf"),width=10)
}

if(!preprocess){

    H3K4me1_data<-read.table(file="H3K4me1_metaplot.txt",header=TRUE,as.is=TRUE)
    H3K4me1_data$region_name<-factor(H3K4me1_data$region_name,c("gene_start","gene_body","non_gene"))
    plot_metaplot(H3K4me1_data,"H3K4me1")

    H3K4me3_data<-read.table(file="H3K4me3_metaplot.txt",header=TRUE,as.is=TRUE)
    H3K4me3_data$region_name<-factor(H3K4me3_data$region_name,c("gene_start","gene_body","non_gene"))
    plot_metaplot(H3K4me3_data,"H3K4me3")

    H3K27ac_data<-read.table(file="H3K27ac_metaplot.txt",header=TRUE,as.is=TRUE)
    H3K27ac_data$region_name<-factor(H3K27ac_data$region_name,c("gene_start","gene_body","non_gene"))
    plot_metaplot(H3K27ac_data,"H3K27ac")

    H3_data<-read.table(file="H3_metaplot.txt",header=TRUE,as.is=TRUE)
    H3_data$region_name<-factor(H3_data$region_name,c("gene_start","gene_body","non_gene"))
    plot_metaplot(H3_data,"H3")
} else{
    gene_start<-read.table('/Users/stephanie/ll/results/40m_SVM/metaplot/dREG_gs.bed')
    gene_body<-read.table('/Users/stephanie/ll/results/40m_SVM/metaplot/dREG_gb.bed')
    non_gene<-read.table('/Users/stephanie/ll/results/40m_SVM/metaplot/dREG_ng.bed')

    cat("H3K4me1!\n")
    H3K4me1<-load.bigWig(paste0('/Users/stephanie/ll/data/ChIPseq/bw/H3K4me1_Meiss.sorted',normstring,'.bw'))
    gs_dat<-get_metaplot(gene_start,H3K4me1,hw,stepp,"gene_start")
    gb_dat<-get_metaplot(gene_body,H3K4me1,hw,stepp,"gene_body")
    ng_dat<-get_metaplot(non_gene,H3K4me1,hw,stepp,"non_gene")
    H3K4me1_data<-rbind(gs_dat,gb_dat,ng_dat)
    H3K4me1_data$region_name<-factor(H3K4me1_data$region_name,c("gene_start","gene_body","non_gene"))
    write.table(H3K4me1_data,row.names=F,col.names=T,quote=F,file=paste0("H3K4me1_metaplot",normstring,".txt"))
    plot_metaplot(H3K4me1_data,"H3K4me1")

    cat("H3K4me3!\n")
    H3K4me3<-load.bigWig(paste0('/Users/stephanie/ll/data/ChIPseq/bw/H3K4me3_Marson.sorted',normstring,'.bw'))
    gs_dat<-get_metaplot(gene_start,H3K4me3,hw,stepp,"gene_start")
    gb_dat<-get_metaplot(gene_body,H3K4me3,hw,stepp,"gene_body")
    ng_dat<-get_metaplot(non_gene,H3K4me3,hw,stepp,"non_gene")
    H3K4me3_data<-rbind(gs_dat,gb_dat,ng_dat)
    H3K4me3_data$region_name<-factor(H3K4me3_data$region_name,c("gene_start","gene_body","non_gene"))
    write.table(H3K4me3_data,row.names=F,col.names=T,quote=F,file=paste0("H3K4me3_metaplot",normstring,".txt"))
    plot_metaplot(H3K4me3_data,"H3K4me3")

    cat("H3K27ac!\n")
    H3K27ac<-load.bigWig(paste0('/Users/stephanie/ll/data/ChIPseq/bw/H3K27Ac.sorted',normstring,'.bw'))
    gs_dat<-get_metaplot(gene_start,H3K27ac,hw,stepp,"gene_start")
    gb_dat<-get_metaplot(gene_body,H3K27ac,hw,stepp,"gene_body")
    ng_dat<-get_metaplot(non_gene,H3K27ac,hw,stepp,"non_gene")
    H3K27ac_data<-rbind(gs_dat,gb_dat,ng_dat)
    H3K27ac_data$region_name<-factor(H3K27ac_data$region_name,c("gene_start","gene_body","non_gene"))
    write.table(H3K27ac_data,row.names=F,col.names=T,quote=F,file=paste0("H3K27ac_metaplot",normstring,".txt"))
    plot_metaplot(H3K27ac_data,"H3K27ac")

    cat("H3!\n")
    H3<-load.bigWig('/Users/stephanie/ll/data/ChIPseq/bw/H3_align.sorted.bw')
    gs_dat<-get_metaplot(gene_start,H3,hw,stepp,"gene_start")
    gb_dat<-get_metaplot(gene_body,H3,hw,stepp,"gene_body")
    ng_dat<-get_metaplot(non_gene,H3,hw,stepp,"non_gene")
    H3_data<-rbind(gs_dat,gb_dat,ng_dat)
    H3_data$region_name<-factor(H3_data$region_name,c("gene_start","gene_body","non_gene"))
    write.table(H3_data,row.names=F,col.names=T,quote=F,file="H3_metaplot.txt")
    plot_metaplot(H3_data,"H3")

    cat("p300!\n")
    p300<-load.bigWig('/Users/stephanie/ll/data/ChIPseq/bw/p300_fastq_align.sorted.bw')
    gs_dat<-get_metaplot(gene_start,p300,hw,stepp,"gene_start")
    gb_dat<-get_metaplot(gene_body,p300,hw,stepp,"gene_body")
    ng_dat<-get_metaplot(non_gene,p300,hw,stepp,"non_gene")
    p300_data<-rbind(gs_dat,gb_dat,ng_dat)
    p300_data$region_name<-factor(p300_data$region_name,c("gene_start","gene_body","non_gene"))
    write.table(p300_data,row.names=F,col.names=T,quote=F,file="p300_metaplot.txt")
    plot_metaplot(p300_data,"p300")
}


bornMinCN <- function(data, cl, markers_cutoff_pval_anovatest = 0.05, markers_pval_anovatest_fdr = TRUE){
    cl = as.factor(as.character(cl))
    names(cl) = colnames(data)
    resAnova <- resanova(data, cl)
    if (markers_pval_anovatest_fdr) colpval = "anova.adjpvalues" else colpval = "anova.pvalues"
    signifAnova = rownames(resAnova)[resAnova[, colpval] < markers_cutoff_pval_anovatest]
    allp1 <- unlist(lapply(levels(cl), function(i) {
        thiscl = (cl == i) * 1
        names(thiscl) = names(cl)
        a <- sapply(signifAnova, function(g){stats::t.test(unlist(data[g,]) ~ thiscl, alternative="greater")$p.value})
        names(a) = signifAnova
        h1Proportion(a)
    }))
    names(allp1) <- levels(cl)
    minp1 <- allp1[which.min(allp1)]
    if(minp1 < markers_cutoff_pval_anovatest){ bornMIN <- 5 ; warning("At least one population has very few markers") } else bornMIN <- 20
    bornMIN
}


require(matrixStats)
setwd("~/Dokumenty/studijni_materialy/Edu-hoc/src")

dat1 = read.delim("RssiApp/values4.txt", header = FALSE, sep = ";", comment.char = "&")
dat2 = read.delim("RssiApp2/values4.txt", header = FALSE, sep = ";", comment.char = "&")
dat3 = read.delim("RssiAppSniffer/values4.txt", header = FALSE, sep = ";", comment.char = "&")

basicStats <- function(x){
  m = mean(x)
  sd = sd(x)

  qp = m + alpha * sd
  qm = m - alpha * sd

  result <- list("mean"=m, "sd"=sd, "qp"=qp, "qm"=qm)
  return(result)
}

quantization <- function(stats, values){
  y = c(NA)
  x = c(NA)
  for(i in  1:length(values)){
    if(values[i] > stats$qp){
      y <- c(y,1)
      x <- c(x,i)
    } else if (values[i] < stats$qm){
      y <- c(y,0)
      x <- c(x,i)
    }
  }
  return(list("x"=na.omit(x),"y"=na.omit(y)))
}

mapLocations <- function(locations, bits){
  result = c(NA)

  for(i in locations){
    result = c(result, bits$y[which(bits$x == i)])
  }
  return(na.omit(result))
}

inc <- function(x){
  eval.parent(substitute(x <- x + 1))
}

distance <- function( a, b){
  d <- 0;
  if(length(a) == 0 || length(b) == 0){
    return(max(length(a), length(b)))
  }
  a <- na.omit(a)
  b <- na.omit(b)
  if(length(a) <= length(b)){
    for(i in 1:length(a)){
      if(a[i] != b[i]){
        inc(d)
      }
    }
  } else {
    for(i in 1:length(b)){
      if(a[i] != b[i]){
        inc(d)
      }
    }
  }
  return(d)
}

plotBits <- function(){
  plot(r1$x, r1$y, col = "red", pch=0,  ylim=c(-0.1,1.1))
  points(r2$x, r2$y+0.02, col = "blue", pch=1)
  points(r3$x, r3$y+0.04, col = "green", pch=2)
  points(x_locations, bits1 -0.02, col = "red", pch=15)
  points(x_locations, bits2 -0.04, col = "blue", pch=16)
  points(s_locations, bits3 -0.06, col = "green", pch=17)
}

plotValues <- function(top, down, line){
  plot(c(-10:1010), y=rep_len(s1$mean, length.out = 1021), type = 'l', col = 'blue',  ylim = c(max(values1)+top, min(values1)-down),
       xlab = "message counter value", ylab="dB")
  lines(c(-10:1010), y=rep_len(s2$mean, length.out = 1021), col = 'red')
  lines(c(-10:1010), y=rep_len(s3$mean, length.out = 1021), col = 'green' )

  lines(c(-10:1010), y=rep_len(s1$qp, length.out = 1021), col = 'blue', lty = 3 )
  lines(c(-10:1010), y=rep_len(s2$qp, length.out = 1021), col = 'red' , lty = 3)
  lines(c(-10:1010), y=rep_len(s3$qp, length.out = 1021), col = 'green' , lty = 3)

  lines(c(-10:1010), y=rep_len(s1$qm, length.out = 1021), col = 'blue', lty = 3 )
  lines(c(-10:1010), y=rep_len(s2$qm, length.out = 1021), col = 'red' , lty = 3)
  lines(c(-10:1010), y=rep_len(s3$qm, length.out = 1021), col = 'green' , lty = 3)

  points(c(1:1000),type="p", y=values1, col = 'blue', lty = 2, pch=16 )
  points(c(1:1000),type="p", y=values2, col = 'red' , lty = 2, pch=16)
  points(c(1:1000),type="p", y=values3, col = 'green', lty = 2, pch=20)

  #same <- getSamePoints(x_locations, bits1, bits2)
  #diff <- getDiffPoints(x_locations, bits1, bits2)
  #other <- setdiff(setdiff(c(1:1000), same), diff)
  #points(other, y=rep_len(line, length.out = length(other)), col = "black", pch=20, cex=0.1)
  #points(na.omit(same), y=rep_len(line, length.out = length(na.omit(same))), col = "green", pch=20, cex=0.1)
  #points(diff, y=rep_len(line, length.out = length(diff)), col = "red", pch=20, cex=0.1)
  #text(-10, line, "AB", cex = 0.5)

  same <- getSamePoints(x_locations, bits1, bits2)
  diff <- getDiffPoints(x_locations, bits1, bits2)
  sniff <- getSamePoints(s_locations, bits1, bits3)
  print(sniff)
  other <- setdiff(setdiff(c(1:1000), same), diff)
  points(same, y=rep_len(line, length.out = length(same)), col = "green", pch=20, cex=0.1)
  points(diff, y=rep_len(line, length.out = length(diff)), col = "orange", pch=20, cex=0.1)
  points(other, y=rep_len(line, length.out = length(other)), col = "black", pch=20, cex=0.1)
  points(sniff, y=rep_len(line, length.out = length(sniff)), col = "red", pch=20, cex=0.1)
  points(same, y=rep_len(line-0.025, length.out = length(same)), col = "green", pch=20, cex=0.1)
  points(diff, y=rep_len(line-0.025, length.out = length(diff)), col = "orange", pch=20, cex=0.1)
  points(other, y=rep_len(line-0.025, length.out = length(other)), col = "black", pch=20, cex=0.1)
  points(sniff, y=rep_len(line-0.025, length.out = length(sniff)), col = "red", pch=20, cex=0.1)
  points(same, y=rep_len(line-0.05, length.out = length(same)), col = "green", pch=20, cex=0.1)
  points(diff, y=rep_len(line-0.05, length.out = length(diff)), col = "orange", pch=20, cex=0.1)
  points(other, y=rep_len(line-0.05, length.out = length(other)), col = "black", pch=20, cex=0.1)
  points(sniff, y=rep_len(line-0.05, length.out = length(sniff)), col = "red", pch=20, cex=0.1)

  #same <- getSamePoints(s_locations, bits1, bits3)
  #diff <- getDiffPoints(s_locations, bits1, bits3)
  #other <- setdiff(setdiff(c(1:1000), same), diff)
  #points(other, y=rep_len(line-0.2, length.out = length(other)), col = "black", pch=20, cex=0.1)
  #points(na.omit(same), y=rep_len(line-0.2, length.out = length(na.omit(same))), col = "green", pch=20, cex=0.1)
  #points(diff, y=rep_len(line-0.2, length.out = length(diff)), col = "red", pch=20, cex=0.1)
  #text(-10, line-0.2, "AS", cex = 0.5)

  #same <- getSamePoints(s_locations, bits3, bits2)
  #diff <- getDiffPoints(s_locations, bits3, bits2)
  #other <- setdiff(setdiff(c(1:1000), same), diff)
  #points(other, y=rep_len(line - 0.4, length.out = length(other)), col = "black", pch=20, cex=0.1)
  #points(na.omit(same), y=rep_len(line - 0.4, length.out = length(na.omit(same))), col = "green", pch=20, cex=0.1)
  #points(diff, y=rep_len(line - 0.4, length.out = length(diff)), col = "red", pch=20, cex=0.1)
  #text(-10, line - 0.4, "BS", cex = 0.5)

  legend("topleft",  legend = c("node A", "node B", "sniffer","mean", "q+ & q-"),
         col=c("red", "blue", "green","black","black"),pch=c(20,20,20,NA,NA), lty = c(NA,NA,NA,1,2), cex=0.8, title = "rssi values")
  legend("topright", legend = c("no excursions", "AB bit match", "AB bit error", "compromised bit"),
         col=c("black", "green", "orange","red"),lty=1, cex=0.8, title = "bit sequences")
}

getSamePoints <- function(locations, bitsA, bitsB){
  result <- c(NA)
  if(length(locations)==0){
    return(na.omit(result))
  }
  for(i in 1:length(locations)){
    if(bitsA[i] == bitsB[i]){
      result <- c(result, locations[i])
    }
  }
  #print(result)
  return(result)
}

getDiffPoints <- function(locations, bitsA, bitsB){
  result <- c(NA)
  if(length(locations)==0){
    return(na.omit(result))
  }
  for(i in 1:length(locations)){
    if(bitsA[i] != bitsB[i]){
      result <- c(result, locations[i])
    }
  }
  return(na.omit(result))
}

lengths <- c(NA)
h  <- c(NA)
hS <- c(NA)

alpha <- 0.5

  i<-256
  values1 <- as.numeric(dat1[i,1:1000]) -256
  values2 <- as.numeric(dat2[i,1:1000]) -256
  values3 <- as.numeric(dat3[i,1:1000]) -256

  s1 <- basicStats(values1)
  r1 <- quantization(s1, values1)

  s2 <- basicStats(values2)
  r2 <- quantization(s2, values2)

  s3 <- basicStats(values3)
  r3 <- quantization(s3, values3)

  x_locations = intersect(r1$x,r2$x)
  s_locations = intersect(x_locations,r3$x)

  bits1 <- mapLocations(x_locations, r1)
  bits2 <- mapLocations(x_locations, r2)
  bits3 <- mapLocations(s_locations, r3)

  lengths <- c(lengths, length(bits1))
  if(length(bits1) != 0){
    h <- c(h, distance(bits1, bits2))
    hS <- c(hS, distance(bits1, bits3))
  }


"
Исследовать правила неявного преобразования типов, выполнив примеры, аналогичные примерам из п.8.
Определить правила преобразования для переменных следующих типов:
integer и double
integer и logical
logical и character
double и logical
double и character
По результатам исследования сформулировать общее правило преобразования типов в R.
"

result <- 1 + 1.3
typeof(result)

result <- 1 + TRUE
typeof(result)

result <- TRUE + "MEOW"
typeof(result)


library(Seurat)
library(qusage)

seurat_recipet = function(expr){
expr_obj = CreateSeuratObject(expr)
expr_obj = NormalizeData(expr_obj, normalization.method = "LogNormalize", scale.factor = 10000)
expr_obj = ScaleData(expr_obj)
expr_obj = FindVariableFeatures(expr_obj, selection.method = "vst", nfeatures = 2000)
expr_obj = RunPCA(expr_obj, features = VariableFeatures(object = expr_obj), npcs = 100)
expr_obj
}

write_csv = function(df, fn){
write.table(df, file = fn, append = FALSE, sep = ",",
                eol = "\n", na = "NA", dec = ".", row.names = TRUE,
                col.names = TRUE, qmethod = c("escape", "double"),
                fileEncoding = "")
}

folder_to_read = paste0('../processed_data/clean_data/')
exprs=read.csv(paste0(folder_to_read, 'gene_expression.csv'), row.names=1, header=T , check.names = F)
exprs=t(exprs)

meta=read.csv(paste0(folder_to_read, 'metadata.csv'), row.names=1, header=T, check.names = F)

expr_obj = seurat_recipet(exprs)

gss = read.gmt('./h.all.v7.1.symbols.gmt')

res = c()
for (i in  seq_along(gss))
{
gs = list(gss[[i]])
expr_obj = AddModuleScore(expr_obj, gs, name = 'mod')
res = rbind(res, expr_obj$mod1)
}

rownames(res) = names(gss)

write_csv(res, 'hallmark/score.csv')

gss = read.gmt('./c2.cp.kegg.v7.1.symbols.gmt')

res = c()
for (i in  seq_along(gss))
{
gs = list(gss[[i]])
expr_obj = AddModuleScore(expr_obj, gs, name = 'mod')
res = rbind(res, expr_obj$mod1)
}

rownames(res) = names(gss)
write_csv(res, 'kegg/score.csv')


# plot_interaction generic function ----
plot_interaction <- function(input, ...) UseMethod("plot_interaction", input)

# plot_interaction mod_vcov method ----
plot_interaction.mod_vcov <- function(input, iv, moderator, ci = 0.9, ...) {

  # run checks ----
  if (!is.character(iv) | !is.character(moderator)) stop("iv and moderator must be character variables!")
  if (!is.numeric(ci) | ci >= 1) {
    ci <- 0.9
    warning("ci must be a numeric value < 1! Default for ci is 0.9.")
  }

  # get data ----
  model <- input$model
  vcov_mat <- input$vcov_mat
  data <- margins::cplot(model, x = moderator, dx = iv, what = "effect", data = model$model, level = ci, vcov = vcov_mat, draw = FALSE)

  # draw plot ----
  data_rug <- model$model
  data_rug$rug <- data_rug[,moderator]

  if (attr(input, "type") == "standard") {
    caption <- NULL
  } else if (attr(input, "type") == "robust") {
    caption <- "Clustered standard errors"
  } else if (attr(input, "type") == "robust_boot") {
    caption <- "Clustered standard errors with bootstrapping"
  }

  out <- ggplot2::ggplot(data, ggplot2::aes(x = xvals)) +
    ggplot2::geom_line(ggplot2::aes(y = yvals)) +
    ggplot2::geom_hline(yintercept = 0) +
    ggplot2::geom_line(ggplot2::aes(y = upper), linetype = 2) +
    ggplot2::geom_line(ggplot2::aes(y = lower), linetype = 2) +
    ggplot2::geom_rug(data = data_rug, ggplot2::aes(rug), sides = "b") +
    ggplot2::labs(title = paste0("marginal effect ", iv), subtitle = paste0(ci * 100, "% confidence interval"), x = moderator, y = "marginal effect", caption = caption)

  return(out)
}

# plot_interaction lm and glm method ----
plot_interaction.lm <- plot_interaction.glm <- function(input, iv, moderator, ci = 0.9, type = 0, var_cluster = NULL, ...) {
  out <- model_vcov(model = input, type = type, var_cluster = var_cluster)
  out <- plot_interaction(input = out, iv = iv, moderator = moderator, ci = ci)

  return(out)
}

# plot_interaction lmerMod and glmerMod method ----
plot_interaction.lmerMod <- plot_interaction.glmerMod <- function(input, iv, moderator, ci = 0.9, ...) {

  # run checks ----
  if (!is.character(iv) | !is.character(moderator)) stop("iv and moderator must be character variables!")
  if (!is.numeric(ci) | ci >= 1) {
    ci <- 0.9
    warning("ci must be a numeric value < 1! Default for ci is 0.9.")
  }

  # draw plot ----
  out <- interplot::interplot(input, var1 = iv, var2 = moderator, ci = ci, hist = TRUE) +
    ggplot2::labs(title = paste0("marginal effect ", iv), subtitle = paste0(ci * 100, "% confidence interval"), x = moderator, y = "marginal effect", caption = "Linear fixed effects model") +
    ggplot2::geom_hline(yintercept = 0)

  return(out)
}


# This script illustrate the use of DYSM in modelling and forecasting developed countries mortality.
# In order to reproduce results in the paper, you need to download data from HMD creating an account. See the  download_data folder for further instructions

# This script focuses on FEMALE population.
# The Rdata files mcmc_resFEMALE.RData and mcmc_resMALE.RData store the mcmc output
rm(list=ls())

data_fol = "../download_data/"

source(paste0(data_fol, "HMD_read.R"))
cc=sort(c("AUS","DEUTW", "CHE","GBRTENW",    "DNK",    "FIN",    "FRATNP", "ITA" ,   "NLD", "NOR",  "ESP",  "SWE" ))
cc

# LOAD data. Check the content of ../download_data for instructions
ddl = list()
for(i in 1:length(cc)){
	load(file= sprintf(paste0(data_fol, "%s.RData"),cc[i]))
	ddl[[i]] = list("deaths" = deaths,"mx" = mx$rate$female) #change here for Male pop
}
names(ddl) = cc
(Ncount = length(ddl))

Ny = 20 # number of time points
(years= as.character(seq(from  = 2017 - 2*(Ny-1), to = 2017, length.out = Ny))) # You can model year by year, even years, or longer periods

# Combine dx with D
Y = array(NA, c(Ncount,111,Ny),dimnames = list("country" = cc,"ages" = as.character(0:110), "years" = years))
Dtot = array(NA, c(Ncount,Ny),dimnames = list("country" = cc, "years" = as.character(1:Ny)))
for (p in 1:Ncount){
	for(tt in 1:length(years)) {
		(wy = which(years[tt] == (colnames(ddl[[p]]$mx))))
		# calcolo dx
		Dtot[p,tt] = sum(ddl[[p]]$deaths$Female[(ddl[[p]]$deaths$Year == years[tt])])  #Change here for male
		Y[p,,tt] = mx2dx(ddl[[p]]$mx[,wy], age = 0:110)
		Y[p,,tt] = pmax( round( (Y[p,,tt] / sum (Y[p,,tt])) * Dtot[p,tt]), 0)
	}
}

dd = list(y = Y)
(dd$N = apply(dd$y,c(1,3),sum))
hyp = list(N_countries = dim(dd$y)[1],
	   Time = dim(dd$y)[3],
	   n = 111, x = seq(0,110)+0.5)

# Informative priors
hyp$m_mu = 30
hyp$m_xi = 80
hyp$m_alpha = -2
hyp$m_lsigma = 1
hyp$m_lomega = 3
hyp$m_eta1 = 6
hyp$m_eta2 = 1

#++++++++++++++++++++++++++++++++++
# Smart initialisation really helps
#++++++++++++++++++++++++++++++++++
inits = list(mu = rep(hyp$m_mu,Ny),
	     lsigma = rep(hyp$m_lsigma,Ny),
	     xi = rep(hyp$m_xi,Ny),
	     lomega = rep(hyp$m_lomega,Ny),
	     alpha = rep(hyp$m_alpha,Ny),
	     eta1 = rep(hyp$m_eta1,Ny),
	     eta2 = rep(hyp$m_eta2,Ny)
)
inits = lapply(inits, function(x) matrix(x,nrow= hyp$N_countries, ncol = hyp$Time))

inits$drift_mu     =  rep(0, hyp$N_countries)
inits$drift_lsigma =  rep(0, hyp$N_countries)
inits$drift_xi     =  rep(0, hyp$N_countries)
inits$drift_lomega =  rep(0, hyp$N_countries)
inits$drift_alpha  =  rep(0, hyp$N_countries)
inits$drift_eta1   =  rep(0, hyp$N_countries)
inits$drift_eta2   =  rep(0, hyp$N_countries)

inits$s_mu     =  rep(2, hyp$N_countries)
inits$s_lsigma =  rep(2, hyp$N_countries)
inits$s_xi     =  rep(2, hyp$N_countries)
inits$s_lomega =  rep(2, hyp$N_countries)
inits$s_alpha  =  rep(2, hyp$N_countries)
inits$s_eta1   =  rep(2, hyp$N_countries)
inits$s_eta2   =  rep(2, hyp$N_countries)

inits$m_mu_0     =  rep(inits$m_mu, hyp$N_countries)
inits$m_xi_0     =  rep(inits$m_xi, hyp$N_countries)
inits$m_alpha_0  =  rep(inits$m_alpha, hyp$N_countries)
inits$m_lsigma_0 = rep(inits$m_lsigma, hyp$N_countries)
inits$m_lomega_0 = rep(inits$m_lomega, hyp$N_countries)
inits$m_eta1_0   = rep(inits$m_eta1, hyp$N_countries)
inits$m_eta2_0   = rep(inits$m_eta2, hyp$N_countries)

# This depends on your architecture
fPIC = F
source("./nimble_model_integral.r")
source("./post_proc_util.r")
nimbleOptions(stop_after_processing_model_code = F)
dynModel = nimbleModel(code = mod_multi_country_mixture,
		       constants = hyp,
		       data = dd,
		       inits = inits)

cat("============\n[compiling]\n============\n")
CdynModel = compileNimble(dynModel,  showCompilerOutput = TRUE)
cat("============\n[building]\n============\n")
dynMCMC = buildMCMC(dynModel,  monitors = c(names(inits)), print=T)
cat("=========\n[merging]\n============\n")
CdynMCMC = compileNimble(dynMCMC, project = dynModel, showCompilerOutput = TRUE)
CdynModel$initializeInfo()

set.seed(42)
mcmc.out = runMCMC(CdynMCMC, niter = 205000,nburnin = 5000,thin = 50)
pars = reshape_res(mcmc.out,nn = c(names(inits)))
pars = reshape_res(mcmc.out,nn = c(names(inits)))


D = data.frame(studid=c(1:5),studname=c("X","Y","Z","A","B"),
                              gender=c("M","M","F","F","M"))

print(D)
print("---------------------------")
str(D)

print(D$studid) # Prints student id column only

print(D[c(2,3),c(1)])

D$dep = c("BCE","BEC","BEE","BCL","BLC")
# TODO: Finish the VSCode Playground section.
print("Dataframe D after insertion of department column is: ")
print(D)
print("---------------------------")
Dnew = data.frame(studid = c(6:8), studname = c("G","E","F"),gender=c("M","M","F"),dep = c("BLC","BCE","BCE"))
print("Dataframe D after insertion of rows is: ")
D = rbind(D,Dnew)
print(D)
print("---------------------------")
# Video 16: Guided Practice

employee = data.frame(empid=c(1:6),empName = c("Elliot","Darlene","Tyrell","Krista","White_Rose","Leon"))

print(employee)

print("--------Structure of Employee DataFrame--------")
str(employee) # Structure not string of employee
print("---------------------------")

# By default factor is created for a dataframe.

print("--------Summary of Employee DataFrame--------")
summary(employee) # Show statistical report of some dataframe
print("---------------------------")
is.data.frame(employee) # To check if a variable is a dataframe. Returns boolean response

list = list(1,2,3,4)
is.data.frame(list)

# To print employee name
print("---------------------------")
print("All employee names are: ")
print(employee$empName)
print("---------------------------")
#  To get some specific rows
print("------------Elements at 2nd and 3rd index in second row---------------")
print(employee[c(2,3),c(2)]) # Gives us 2nd and 3rd row element of second column
print("---------------------------")

employee$empGender = c("M","F","M","F","M","F")

print(employee)

employeeNewRow = data.frame(employeeid = c(7:11),empName=c("Tokyo","Lisbon","Nairobi","Denver","Helsinki"),empGender=c("F","F","F","M","M"))

updated_df = rbind(employee,employeeNewRow)
print("------------DF after update---------------")
print(updated_df)
# ------------------------------------


line1 <- c(1,2,3,4,5,10)
line2 <- c(2,5,7,8,9,10)

plot(line1, type = "l", col = "blue")
lines(line2, type="l", col = "red")


#' Methods of tidy and glance
#'
#' @param x object
#' @param \dots other arguments
#'
#' @importFrom generics tidy
#' @export
#'
tidy.global_lm <- function(x, ...) {
  res <- x$local.ate
  data.frame(
    term = rownames(res),
    estimate = res[1, 1],
    std.error = res[1, 2],
    statistic = res[1, 3],
    p.value = res[1, 4],
    outcome = x$outcome
  )
}

#'
#' @export
#' @name tidy.global_lm
tidy.local_lm <- function(x, ...) {
  tidy.global_lm(x, ...)
}

#'
#' @export
#' @name tidy.global_lm
tidy.local_random <- function(x, ...) {
  x <- x$estimate
  data.frame(
    outcome = x$outcome,
    mean_y1 = x$observe$treat$mean,
    se_y1 = x$observe$treat$se,
    n1 = x$observe$treat$N,
    mean_y0 = x$observe$control$mean,
    se_y0 = x$observe$control$se,
    n0 = x$observe$control$N,
    mean_diff = x$local.ate$estimate,
    p = x$local.ate$p.value
  )
}

#'
#' @importFrom generics glance
#' @export
#' @name tidy.global_lm
glance.global_lm <- function(x, ...) {
  data.frame(
    nobs = x$treat$N + x$control$N,
    se = x$treat$vcov$type
  )
}

#'
#' @importFrom tibble tibble
#' @export
#' @name tidy.global_lm
glance.local_lm <- function(x, ...) {
  n <- x$treat$N + x$control$N
  efn <- x$treat$input$local.wls$effective.nobs +
    x$control$input$local.wls$effective.nobs
  tibble::tibble(
    nobs = n,
    "Effective Num.Obs." = sprintf("%1d", efn),
    se = x$treat$vcov$type,
    kernel = x$treat$input$local.wls$kernel,
    bandwidth = x$treat$input$local.wls$bandwidth
  )
}


library(ggplot2)

csvData <- read.csv("2014-03-08_household_income.csv", stringsAsFactors=FALSE)
csvData <- csvData[1:42,]
csvData$Income <- factor(csvData$Income, levels=csvData$Income, ordered=TRUE)
csvData$Number<-as.numeric(csvData$Number)

cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
myFill <- rep(cbPalette[1], 42)
myFill[13] <- cbPalette[2]
myFill[15] <- cbPalette[3]
myFill <- factor(myFill)

ggplot(data = csvData,
            aes(x = Income,y = Number),
            height=200,
            width=800) +
    geom_bar(stat="identity",
             xlab="Income",
             color="white",
             fill=myFill) +
    theme(axis.text.x=element_text(angle=60, hjust=1))

ggsave("household_income.png", width=8, height=5)


# install.packages("coin", repos = 'http://cran.us.r-project.org')
suppressMessages(library(ez))
suppressMessages(library(ggplot2))
suppressMessages(library(multcomp))
suppressMessages(library(nlme))
suppressMessages(library(pastecs))
suppressMessages(library(pgirmess))
suppressMessages(library(reshape2))
suppressMessages(library(WRS))
suppressMessages(library(e1071))
suppressMessages(library(rstatix))
suppressMessages(library(coin))

myData <- read.csv(file="input/messageAcrossData.csv", header=TRUE, sep=",")
myData$preferredVersion <- unclass(myData$preferredVersion)

print("Computing normality tests...")
print("Computing main effects based on the score system...")

# from https://www.tutorialspoint.com/r/r_mean_median_mode.htm
getmode <- function(v) {
   uniqv <- unique(v)
   uniqv[which.max(tabulate(match(v, uniqv)))]
}

processGameVar <- function(myData, yVarPre, yVarPos, scaleAdjust){
  a <- paste(yVarPre,"A",yVarPos,sep="")
  b <- paste(yVarPre,"B",yVarPos,sep="")
  c <- paste(yVarPre,"C",yVarPos,sep="")
  d <- paste(yVarPre,"D",yVarPos,sep="")
  varsToProcess = c(a,b,c,d)

  keeps <- c("playerId", varsToProcess)
  keepsData <- myData[, (names(myData) %in% keeps)]
  longData <- melt(keepsData, id.vars=c("playerId"))
  dietMyData <- na.omit(keepsData)

  a <- dietMyData[[a]]
  b <- dietMyData[[b]]
  c <- dietMyData[[c]]
  d <- dietMyData[[d]]
  colnames(dietMyData) = c("playerId","A","B","C","D")

  out <- shapiro.test(a)
  #print(out)
  capture.output(out, file = sprintf("results/normality/scoreSystem/shapiroTest %s_a.messageAcrossData",yVarPre))

  out <- shapiro.test(b)
  #print(out)
  capture.output(out, file = sprintf("results/normality/scoreSystem/shapiroTest %s_b.messageAcrossData",yVarPre))

  out <- shapiro.test(c)
  #print(out)
  capture.output(out, file = sprintf("results/normality/scoreSystem/shapiroTest %s_c.messageAcrossData",yVarPre))

  out <- shapiro.test(d)
  #print(out)
  capture.output(out, file = sprintf("results/normality/scoreSystem/shapiroTest %s_d.messageAcrossData",yVarPre))

  out <- friedman.test(longData$value, longData$variable, longData$playerId)
  #print(out)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/friedmanTest %s.messageAcrossData",yVarPre))

  out <- friedman_effsize(longData, value ~ variable | playerId)
  #print(out)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/effSize/friedmanEffSize %s.messageAcrossData",yVarPre))

  # out <- friedmanmc(longData$value, longData$variable, longData$playerId)
  out <- pairwise.wilcox.test(longData$value, longData$variable, paired= TRUE, p.adj = "none", exact=FALSE)
  #print(out)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/postHoc/friedmanTestPostHoc %s.messageAcrossData",yVarPre))

  out <- wilcoxsign_test(A~C, dietMyData)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/postHoc/willcoxonA-C %s.messageAcrossData",yVarPre))

  out <- wilcoxsign_test(B~D, dietMyData)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/postHoc/willcoxonB-D %s.messageAcrossData",yVarPre))

  out <- wilcox_effsize(longData, value ~ variable, paired = TRUE)
  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/effSize/willcoxon %s.messageAcrossData",yVarPre))

  out <- sprintf("Descriptive Statistics")

  out <- sprintf("mean(a) = %s",mean(a)+scaleAdjust)
  out <- paste(out, sprintf("mean(b) = %s",mean(b)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("mean(c) = %s",mean(c)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("mean(d) = %s",mean(d)+scaleAdjust), ";  ")

  out <- paste(out, sprintf("median(a) = %s",median(a)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("median(b) = %s",median(b)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("median(c) = %s",median(c)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("median(d) = %s",median(d)+scaleAdjust), ";  ")

  out <- paste(out, sprintf("getmode(a) = %s",getmode(a)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("getmode(b) = %s",getmode(b)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("getmode(c) = %s",getmode(c)+scaleAdjust), ";  ")
  out <- paste(out, sprintf("getmode(d) = %s",getmode(d)+scaleAdjust), ";  ")

  out <- paste(out, sprintf("stdev(a) = %s",sd(a)), ";  ")
  out <- paste(out, sprintf("stdev(b) = %s",sd(b)), ";  ")
  out <- paste(out, sprintf("stdev(c) = %s",sd(c)), ";  ")
  out <- paste(out, sprintf("stdev(d) = %s",sd(d)), ";  ")

  capture.output(out, file = sprintf("results/mainEffects/scoreSystem/descStats %s.messageAcrossData",yVarPre))
}

# processGameVar("meanNumberOfGives_","")
processGameVar(myData, "whoFocus_","",-4)
processGameVar(myData, "whatFocus_","",-4)
processGameVar(myData, "meanNumberOfTakes_","",0)
processGameVar(myData, "score_","_7",0)

varsToProcess = c("score_A_7","score_B_7","score_C_7","score_D_7")
keeps <- c("playerId", varsToProcess)
data <- myData[, (names(myData) %in% keeps)]
data$playerId <- factor(data$playerId, levels = c("121","122","125","126","84","118","9","111","124","110","136","127","62","119","100","102","82","135","3","78","31","109","33","117","67","103","91","112","70","17","88","47","130","123","113","114","83","133","48","34","107","132","24","134","18","120","46","143","146","147","150","151","129","153","154","155","148","149","144","145","116","158","160","159","69","76","156","157","141","142","161","162","87","166","168","167","164","165"))
data <- data[order(data$playerId),]
scoreData = data.frame(matrix(ncol = 0, nrow = 33))

j <- 1
for(i in  seq(from=1, to=dim(data)[1], by=2)) {
  scoreData$playerId[j] <- data$playerId[i] #assume the id of the group is the first id of the players
  scoreData$scoreDiff_A[j] <- abs(data$score_A_7[i]-data$score_A_7[i+1])
  scoreData$scoreDiff_B[j] <- abs(data$score_B_7[i]-data$score_B_7[i+1])
  scoreData$scoreDiff_C[j] <- abs(data$score_C_7[i]-data$score_C_7[i+1])
  scoreData$scoreDiff_D[j] <- abs(data$score_D_7[i]-data$score_D_7[i+1])
  j <- j+1
}

processGameVar(scoreData, "scoreDiff_","",0)

# print("Computing main effects based on personality...")
# personalityVariables <- names(myData)[20:57]

# processGameVar <- function(varToTestText){
#   # print(paste("varToTest: ",varToTest,sep=""))

#   varToTest <- myData[[varToTestText]]
#   out <- shapiro.test(varToTest)
#   #print(out)
#   capture.output(out, file = sprintf("results/normality/derivedMeasures/shapiroTest_%s.messageAcrossData", varToTestText))

#   # print("#################HERE###################")

#   for (xText in personalityVariables){
#       x <- myData[[xText]]
#       out <- shapiro.test(x)
#       capture.output(out, file = sprintf("results/normality/personality/shapiroTest_%s.messageAcrossData", xText))
#       #print(sprintf("%s-> Median(%f);Mean(%f)", xText, median(x), mean(x)))

#       out <- (cor.test(x, varToTest, method=c("spearman"), exact=F))
#       # if(test$p.value <= 0.05){
#         #print(test)
#         capture.output(out, file = sprintf("results/mainEffects/personality/%s/spearmanPersonalityResults_%s.messageAcrossData",varToTestText, xText))
#       # }
#     }
# }

# processGameVar("meanWhoFocus")
# processGameVar("meanWhatFocus")
# #processGameVar("grandMeanGives")
# processGameVar("grandMeanTakes")
# #processGameVar("ratioTakesGives")
# processGameVar("preferredVersion")

# # print("Computing interaction effects...")

# meltedData <- read.csv(file="output/meltedData.csv", header=TRUE, sep=",")

# # Compute the analysis of variance
# res.aov <- lapply(personalityVariables, function(x) {
#   aov(eval(substitute(gives ~ personality * ScoreSystem, list(personality = as.name(x)))), data = meltedData)
#   }
# )
# text <- lapply(res.aov, summary)
# #print(text)
# capture.output(text, file = "results/interactionEffects/givesMixedAnovaResults.messageAcrossData")

# # Compute the analysis of variance
# res.aov <- lapply(personalityVariables, function(x) {
#   aov(eval(substitute(takes ~ personality * ScoreSystem, list(personality = as.name(x)))), data = meltedData)
#   }
# )
# text <- lapply(res.aov, summary)
# #print(text)
# capture.output(text, file = "results/interactionEffects/takesMixedAnovaResults.messageAcrossData")

# # Compute the analysis of variance
# res.aov <- lapply(personalityVariables, function(x) {
#   aov(eval(substitute(who ~ personality * ScoreSystem, list(personality = as.name(x)))), data = meltedData)
#   }
# )
# text <- lapply(res.aov, summary)
# #print(text)
# capture.output(text, file = "results/interactionEffects/whoMixedAnovaResults.messageAcrossData")

# # Compute the analysis of variance
# res.aov <- lapply(personalityVariables, function(x) {
#   aov(eval(substitute(what ~ personality * ScoreSystem, list(personality = as.name(x)))), data = meltedData)
#   }
# )
# text <- lapply(res.aov, summary)
# #print(text)
# capture.output(text, file = "results/interactionEffects/whatMixedAnovaResults.messageAcrossData")


diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}


library(tidyverse)
library(scales)
library(R6)
library(furrr)
source("stat_qtile.r")
source("simulation.r")
source("configuration.r")

# This defines the config object
source("personal_info.r")

########################################################################
#
# Actually do it.

shiller_annual<-read_tsv("data/Shiller Data - sp500.tsv") %>%
  mutate(date=as.Date(sprintf("%s-%s-01", year, month))) %>%
  group_by(year) %>%
  arrange(month) %>%
  summarize(sp500_growth=sp500_growth[1],
            dividend_yield=dividend_yield[1],
            inflation=inflation[1],
            ten_yr_treasury_yield=ten_yr_treasury_yield[1]) %>%
  filter(year > 1871)

#debug(compute_one_rep)

plan(strategy = multisession, workers = 8)
all_reps<-list()
for (cname in names(all_configs)) {
  print(cname)
  config<-all_configs[[cname]]
  all_reps[[cname]]<-future_map_dfr(1:1000, ~compute_one_rep(shiller_annual, config, .), .options=furrr_options(seed = TRUE)) %>%
    group_by(rep_id) %>%
    mutate(failure = any(total_savings < 0),
           # Zeros mess up plots on a log scale
           total_spending = ifelse(total_savings > total_spending, total_spending, pmax(1, total_savings-1)),
           total_savings = ifelse(total_savings > 0, total_savings, 1))
  all_reps[[cname]]$cname <- cname
}

for (cname in names(all_configs)) {
  all_reps[[cname]]$cname <- cname
}

reps_big<-bind_rows(all_reps)

reps_big %>%
  group_by(cname, rep_id) %>%
  summarise(failure = any(total_savings<=1)) %>%
  count(failure) %>%
  mutate(p=n/sum(n)) %>%
  filter(failure)

ggplot(reps_big, aes(year, total_savings, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=comma, limits=c(50000,200000000)) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2)) +
  facet_wrap(~cname)

reps_big %>%
  filter(retirement_year >= 1) %>%
  ggplot(aes(year, total_spending, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=comma, limits=c(50000,2000000)) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2)) +
  facet_wrap(~cname)

reps_big %>%
  filter(retirement_year >= 1) %>%
  ggplot(aes(year, total_spending/total_savings, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  ylim(0,0.25) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2)) +
  facet_wrap(~cname)

# Probability of failure as a function of the inclusion of at least one instance of a given year
reps_big %>%
  group_by(cname, original_year, rep_id) %>%
  summarize(failure=max(failure)) %>%
  summarize(n_reps = length(rep_id),
            fail_ct = sum(failure),
            p_fail=fail_ct/n_reps) %>%
  ggplot(aes(original_year, p_fail)) +
  geom_line()+
  facet_wrap(~cname)

reps_big %>%
  group_by(cname, rep_id) %>%
  arrange(year) %>%
  summarise(end_savings = total_savings[length(total_savings)],
            inflation_effect = prod(1-inflation),
            end_savings_inflation_adjusted = end_savings * inflation_effect) %>%
  ggplot(aes(end_savings_inflation_adjusted/1e6, color=cname, group=cname)) +
  stat_ecdf() +
  coord_cartesian(xlim=c(0,100))

#############################
# Individual plots

reps<-all_reps[["keep_mortgage_6040"]]
reps<-reps_refi_mortgage_8020
reps<-reps_keep_mortgage_6040
reps<-reps_keep_mortgage_8020
reps<-reps_payoff_mortgage_6040
reps<-reps_payoff_mortgage_8020

reps %>%
  group_by(rep_id) %>%
  summarise(failure = any(total_savings<=1)) %>%
  count(failure) %>%
  mutate(p=n/sum(n))

ggplot(reps, aes(year, total_savings, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=comma, limits=c(50000,200000000)) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

reps %>%
  filter(retirement_year >= 1) %>%
  ggplot(aes(year, total_spending, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=comma, limits=c(50000,2000000)) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

reps %>%
  filter(retirement_year >= 1) %>%
  ggplot(aes(year, total_spending/total_savings, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  ylim(0,0.25) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

reps %>%
  group_by(rep_id) %>%
  arrange(year) %>%
  mutate(cumul_inflation=cumprod(1+inflation)) %>%
  ggplot(aes(year, cumul_inflation, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=percent) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

reps %>%
  group_by(rep_id) %>%
  arrange(year) %>%
  mutate(cumul_sp500_growth=cumprod(1+sp500_growth)) %>%
  ggplot(aes(year, cumul_sp500_growth, group=rep_id)) +
  geom_line(aes(color=failure, alpha=failure)) +
  stat_qtile(aes(group=1)) +
  scale_y_log10(labels=comma) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

reps %>%
  group_by(rep_id) %>%
  arrange(year) %>%
  mutate(cumul_inflation=cumprod(1+inflation),
         cumul_sp500_growth=cumprod(1+sp500_growth)) %>%
  ggplot(aes(cumul_inflation, cumul_sp500_growth, group=rep_id)) +
  geom_path(aes(color=failure, alpha=failure)) +
  scale_x_log10(labels=percent) +
  scale_y_log10(labels=percent) +
  scale_color_manual(values=c("black","red")) +
  scale_alpha_manual(values=c(1/20, 1/2))

#ggplot(reps, aes(year,total_savings/1e6, group=rep_id)) + geom_line() + facet_wrap(~rep_id)

# The top 10 years included in replicates that fail (TRUE) vs. those
# that don't (FALSE)
reps %>%
  group_by(failure, original_year) %>%
  summarize(ct=length(original_year)) %>%
  mutate(rank = rank(-ct, ties.method = "random")) %>%
  filter(rank<10) %>%
  select(-ct) %>%
  spread(failure, original_year)

# The years that are commonest in repliactes that fail,
# along with their average count per replicate
reps %>%
  filter(failure) %>%
  group_by(original_year) %>%
  summarize(ct=length(original_year),
            avg=ct/length(unique(rep_id))) %>%
  arrange(desc(ct)) %>%
  head()

reps %>%
  group_by(rep_id) %>%
  arrange(year) %>%
  summarise(end_savings = total_savings[length(total_savings)],
            inflation_effect = prod(1-inflation),
            end_savings_inflation_adjusted = end_savings * inflation_effect) %>%
  ggplot(aes(end_savings_inflation_adjusted/1e6)) +
  stat_ecdf() +
  coord_cartesian(xlim=c(0,100))

reps %>% filter(failure) %>% View()


# get the clean RNA-seq table
source("code/setup.r")
sign.set.effect <- lapply(sign.set.effect <- vector(mode = 'list',7), function(x) x <- vector(mode='list',100))

seq.test <- c(2,3,5,10,15,20,40)

for(i in 1:7){
    print(seq.test[i])
    for(j in 1:100){
        print(j)
        # subset d.good by random sampling
        d.sample <- cbind(d.good[,sample( WT.g$good, seq.test[i])], d.good[,sample( SNF.g$good, seq.test[i])])
        conds.i <- c(rep("C", seq.test[i]), rep("E", seq.test[i]))

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


#' ---
#' title: "Uvod u R"
#' subtitle: Kontrola toka i oblikovanje podataka
#' author:
#'    - "Milutin Pejovic, Petar Bursac"
#' date: "`r format(Sys.time(), '%d %B %Y')`"
#' output:
#'    html_document:
#'      keep_md: true
#'      theme: "simplex"
#'      highlight: tango
#'      toc: true
#'      toc_depth: 5
#'      toc_float: true
#'      fig_caption: yes
#' ---
#'
#' # Kontrola toka u R-u
#'
#' U okviru ovog predavanja upoznaćemo se sa mogućnostima kontrole toka i automatizacije izvršavanja komandi primenom komandi `if` i `for`.
#'
#' ## `if` - grananje toka
#'
#' Komanda `if` omogućava da postavimo uslov kojim će izvršavanje neke komande zavisiti od rezultata nekog logičkog upita. Na taj način moguće je stvoriti razgranatu strukturu toka izvršavanja komandi (algoritma). Komanda `if` se koristi na sledeći način:
#'
#' $$if(condition) \quad \textrm{{true_expression}} \quad elsе \quad \textrm{{false_expression}}$$
#'
#' Na primer, ukoliko promenljiva `x` sadrži numerički podatak, podeliti ga sa 2, a ukoliko je neki drugi podatak ispisati "Nije moguće izvršiti komandu jer x ne sadrži numerički podatak"
#'
#'
x <- 5
if(is.numeric(x)) x/2 else print("Nije moguće izvršiti komandu jer x ne sadrži numerički podatak")

x <- "a"
if(is.numeric(x)) x/2 else print("Nije moguće izvršiti komandu jer x ne sadrži numerički podatak")
#'
#' Ukoliko ne postoji određena operacija koja se uzvršava u slučaju `else`, nije potrebno pisati taj deo. Na primer:
#'
x <- 5
if(is.numeric(x)) x/2

x <- "a"
if(is(x, "numeric")) x/2

#'
#' Međutim, pravi smisao `if` komande se vidi tek kada očekujemo da prilikom izvršavanja niza komandi računar sam odluči šta treba uraditi u određenom trenutku u zavisnosti od ulazinih parametara.
#'
#'
#' ## `for` petlja
#'
#' `for` petlja se koristi kada želimo da automatizujemo izvršavanje neke komande ili niza komandi određeni broj puta. `for` petlja se koristi na sledeći način:
#'
#' $$ for(i \quad in \quad list) \quad \textrm{{expression}} $$
#'
#' Na primer, ako želimo da podacima `studenti` dodamo jednu kolonu pod nazivom "ispit" u vidu logičkog vektora koji će sadržati vrednost TRUE za studente koji su položili oba ispita (IG1 i Praksu) i FALSE za one koji nisu.
#'
#'
#'
studenti <- read.csv(file = "D:/R_projects/Nauka_R/Slides/data/Students_IG1.txt", header = TRUE, stringsAsFactors = FALSE)

studenti$ispit <- NA # Prvo cemo kreirati kolonu "ispit" koja ima sve NA vrednosti

# Komanda dim(studenti) vraca broj dimenzija, prvi se odnosi na broj vrsta.
dim(studenti)

for(i in 1:dim(studenti)[1]){
  # Sekvenca `1:dim(studenti)[1]` sadrzi niz brojeva od 1 do ukupnog broja vrsta u data.frame-u studenti.
  # i ide kroz svaku vrstu data.frame-a `studenti`
  studenti$ispit[i] <- if(is.na(studenti$Ocena[i]) | is.na(studenti$Praksa[i])){FALSE}else{TRUE}
}

head(studenti, 15)

sum(studenti$ispit) # Koliko studenata je polozilo oba ispita

#'
#'
#' >
Zadatak

#'
#' > Potrebno je oblikovati fajl sa podacima nivelanja geometrijskim nivelmanom. Fajl sadrži sledeće informacije:
#'
#' > > + Prva kolona: tacka - sadrzi imena repera i veznih tačaka. Reperi su B1, B3, B4 i B5, a vezne tacke su 1:n.
#'
#' > > + Druga kolona: merenje - sadrži čitanja na letvi.
#'
#' > > + Treća kolona: duzina - sadrži merenu dužinu od instrumenta do letve.
#'
#' > U zadatku se traži sledeće:
#' > 1. Učitati podatke
#'
#' > 2. Kreirati `data.frame` sa sledećim kolonama: od, do, dh i dužina. Pri tome, treba imati u vidu da je na svakoj stanici merena visinska razlika po principu zadnja-prednja-prednja-zadnja. To znači da svakoj stanici pripada po četiri reda izvornih podataka. Rezultujući `data.frame` treba da sadrži po jedan red po stanici, koji će u prvoj koloni ("od") imati "zadnju" tačku, u drugoj koloni ("do") imati prednju tačku, u trećoj koloni ("dh") imati srednju visinsku razliku sračunatu iz čitanja na letvi i u poslednjoj koloni ("duzina") imatu srednju dužinu od letve do letve sračunatu iz merenih dužina. Prilikom rada, pokušajte da se vodite sledećim principima:
#'
#'
#' > > *Generalna preporuka je da podelite zadatak na više manjih zadataka. Na primer, izdvojite podatke za samo jednu stanicu i pokušajte da kreirate željeni `data.frame` sa podacima samo jedne stanice. Uvidite šta su problemi u tom slučaju. Na početku, napravite rezultujući `data.frame` koji će sadržati samo `NA` vrednosti koje će biti zamenjene vrednostima koje treba da sadrži. Taj `data.frame` će imati broj redova onoliko koliko ima stanica i četiri kolone. Za te potrebe možete koristiti komandu `rep(NA, broj stanica)` za svaku kolonu `data.frame`-a. Komanda `rep` (repeat) pravi vektor određene dužine od vektora (sa jednom ili više) vrednosti. Za tim u taj `data.frame` upišite vrednosti koje izračunate ili isčitate iz ulaznih podataka. Kada rešite problem za jednu stanicu, razmislite kako ćete to automatizovati koristeći petlju `for`. Tu je preporuka da u ulaznim podacima napravite još jednu kolonu (faktorsku) koja će označiti koji red pripada kojoj stanici. Pa zatim, transformisati ulazne podatke u `list`-u prema toj promenljivoj i onda u okviru petlje `for`, na svaki član liste primeniti korake koje ste smislili kada ste rešavali samo jednu stanicu.*
#'
#' > 3. Za tim, potrebno je rezultujući `data.frame` dodatno transformisati (sumirati) tako da sadrži samo merenja od repera do repera, sa sledećim kolonama: od (reper), do (reper), dh (ukupna visinska razlika između repera), n (broj stanica od repera do repera) i duzina (ukupna duzina od repera do repera).
#'
#' ## Prvi način - korišćenjem petlje `for`
#'
#' ### Kreiranje prve tabele - visinske razlike po stanici
#'
#+ eval = TRUE, include = TRUE

# Ucitavanje merenja
merenja <- read.table(file = "D:/R_projects/Nauka_R/Slides/data/nivelman.txt", header = TRUE, sep = ",", stringsAsFactors = FALSE)

# Kreiranje pomocne kolone (faktorske) koja pokazuje pripadnost redova stanici
merenja$stanica <- factor(rep(1:(dim(merenja)[1]/4), each = 4))

# Kreiranje liste prema pomocnoj faktorskoj promenljivoj (stanica)
merenja_list <- split(merenja, merenja$stanica)

# Kreiranje praznog data.frame-a
merenja_df <- data.frame( od = rep(NA, length(merenja_list)),
                          do = rep(NA, length(merenja_list)),
                          dh = rep(NA, length(merenja_list)),
                          duzina = rep(NA, length(merenja_list)))

# popunjavanje data.frame-a
for(i in 1:length(merenja_list)){
  merenja_df$od[i] <- as.character(merenja_list[[i]]$tacka[1])
  merenja_df$do[i] <- as.character(merenja_list[[i]]$tacka[2])
  merenja_df$dh[i] <- ((merenja_list[[i]]$merenje[1]-merenja_list[[i]]$merenje[2])+(merenja_list[[i]]$merenje[4]-merenja_list[[i]]$merenje[3]))/2
  merenja_df$duzina[i] <- sum(merenja_list[[i]]$duzina)/2
}

merenja_df

#' Kreiranje fajla
#+ eval = FALSE
writexl::write_xlsx(merenja_df, path = "merenja_df.xlsx")

#'
#' ### Kreiranje sumarne tabele - visinske razlike od repera do repera

reperi <- c("B1", "B3", "B4", "B5")

merenja_df$isReperOD <- merenja_df$od %in% reperi
merenja_df$isReperDO <- merenja_df$do %in% reperi

# broj vis razlika izmedju repera
ndh <- sum(merenja_df$isReperOD)

#indeks pozicije "od" repera,
ind.od <- which(merenja_df$isReperOD == T)
# indeks pozicije "do" repera
ind.do <- which(merenja_df$isReperDO == T)

# Visinske razlike

# Naziv "od" repera
od <- merenja_df$od[ind.od]

# Naziv "do" repera
do <- merenja_df$do[ind.do]

# Racunanje visinskih razlika od repera do repera
dh <- rep(NA, ndh)

for(i in 1:ndh){
  dh[i] <- sum(merenja_df$dh[ind.od[i]:ind.do[i]])
}

# Racunanje broja stanica od repera do repera
n <- rep(NA, ndh)

for(i in 1:ndh){
  n[i] <- length(ind.od[i]:ind.do[i])
}

# Racunanje duzina od repera do repera
duzina <- rep(NA, ndh)

for(i in 1:ndh){
  duzina[i] <- sum(merenja_df$duzina[ind.od[i]:ind.do[i]])
}

# Kreiranje data.frame-a
merenja_df_sum <- data.frame(od = od, do = do, dh = dh, n = n, duzina = duzina)

merenja_df_sum

#' Kreiranje fajla
#+ eval = FALSE
writexl::write_xlsx(merenja_df_sum, path = "merenja_df_reperi.xlsx")

#'
#' # Transformacija podataka korišćenjem `dplyr` paketa
#'
#'
#'
#' Kao što ste već videli, oblikovanje podataka često podrazumeva kreiranje novih promenljivih (atribute ili kolone), sumiranje podataka u novu tabelu, reimenovati ili rasporediti podatke u tabeli. Za te potrebe razvijeni su brojni alati koji omogućavaju laku manupulaciju podacima, a najpoznatiji paket u R okruženju je `dplyr` paket iz `tidyverse` famijije paketa. Da bi se koristio paket `dplyr` neophodno ga je instalirati. Medjutim, preporučuje se instalacija celog `tidyverse` paketa, koji uključuje celu grupu korisnih paketa.
#'
#+ echo = FALSE, fig.align="center", out.width = '25%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/tidyverse-logo.png")
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/tidyverse_website.png")
#'
#'
#' Instalacija `tidyverse` paketa
#+ eval = FALSE
install.packages("tidyverse")
library(tidyverse)
#'
#'
#' `dplyr` paket ima nekoliko osnovnih funkcionalnosti koje rešavaju najčešće probleme, kao što su:
#'
#' **selekcija pojedinačnih merenja (instanci ili vrsta u tabeli) komandom `dplyr::filter()`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/filter.png")
#'
#' **selekcija atributa (kolona) komandom `dplyr::select()`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/rstudio-cheatsheet-select.png")
#'
#'
#' **Kreiranje novih promenljivih komandom `dplyr::mutate()`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/mutate.png")
#'
#'
#' **Sumiranje podataka komandom `dplyr::summarise()`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/summarise.png")
#'
#'
#' **Grupisanje podataka `dplyr::group_by()` (često u kombinaciji sa `summarise`)**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/group_by.png")
#'
#'
#' **Kombninovanje (spajanje) tabela komandom `dplyr::_join`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/combine-options1.png")
#'
#'
#' **Sortiranje podataka komandom `dplyr::arrange()`**
#'
#+ echo = FALSE, fig.align="center", out.width = '70%'
knitr::include_graphics("D:/R_projects/Nauka_R/Slides/Figures/reorder-data-frame-rows-in-r.png")
#'
#'
#'
#' ## Drugi način - korišćenjem `dplyr` paketa
#'
#'
#'
#+ warning = FALSE, message = FALSE
library(tidyverse)
library(magrittr)

# Ucitavanje merenja
merenja <- read.table(file = "D:/R_projects/Nauka_R/Slides/data/nivelman.txt", header = TRUE, sep = ",", stringsAsFactors = FALSE)

merenja_df <- merenja %>%
  dplyr::mutate(stanica = factor(rep(1:(dim(merenja)[1]/4), each = 4))) %>%  # Kreiranje novih kolona
  dplyr::group_by(stanica) %>% # grupisanje podataka prema nekoj promenljivoj
  dplyr::summarise(od = as.character(tacka[1]), # sumiranje podataka
                   do = as.character(tacka[2]),
                   dh = ((merenje[1]-merenje[2])+(merenje[4]-merenje[3]))/2,
                   duzina = sum(duzina)/2)

merenja_df

#'
#'
#' >
Obrati pažnju na `%>%`

#' > Operator `%>%` (`pipe`) je moćan operator koji nam omogućava da sekvencijalno povezujemo operacije i da na taj način izbegnemo kreiranje nepotrebnih promenljivih. `Pipe` je dostupan preko paketa `magrittr`, što znači da je potrebno instalirati paket `magrittr` ako želimo da koristimo `pipe`. Međutim, `pipe` je takođe dostupan preko `tidyverse` paketa. Više detalja na [linku](https://r4ds.had.co.nz/pipes.html).
#'

#'
#' ### Kreiranje sumarne tabele - visinske razlike od repera do repera
#'
reperi <- c("B1", "B3", "B4", "B5")

merenja_df <- merenja_df %>% dplyr::mutate(isReperOD = merenja_df$od %in% reperi,
                             isReperDO = merenja_df$do %in% reperi)

#indeks pozicije "od" repera,
ind.od <- which(merenja_df$isReperOD == T)
# indeks pozicije "do" repera
ind.do <- which(merenja_df$isReperDO == T)

# broj vis razlika izmedju repera
ndh = sum(merenja_df$isReperOD)

# Promenljiva koja pokazuje koja merenja pripadaju odredjenom nivelmanskom vlaku
vlak <- c()
for(i in 1:ndh){
  vlak <- c(vlak, rep(i, ind.do[i]-(ind.od[i]-1)))
}

merenja_df$vlak <- factor(vlak)

# Sumiranje visinskih razlika po vlaku
merenja_df %>% dplyr::select(od, do, dh, duzina, vlak) %>%
               dplyr::group_by(vlak) %>%
               dplyr::summarize(dh_mean = sum(dh))

# Sumiranje visinskih razlika po vlaku sa dodatnim kolonama
merenja_df_sum <- merenja_df %>% dplyr::select(od, do, dh, duzina, vlak) %>%
                                 dplyr::group_by(vlak) %>%
                                 dplyr::summarize(od = od[1],
                                                  do = do[length(vlak)],
                                                  dh = sum(dh),
                                                  stanica = n())

merenja_df_sum

#' # Kreiranje funkcija
#'
#' R omogućava kreranje funkcija koje nam omogućavaju da automatizujemo određene korake u našem algoritmu. Kreiranje funkcija je poželjno u slučajevima kada imamo određeni deo koda koji je potrebno ponoviti više puta. Na taj način, umesto da kopiramo kod više puta, moguće je kreirati funkciju koja će izvršiti taj deo koda pozivanjem kreirane funkcije. Generalno, kreiranje funkcija se sastoji iz tri koraka:
#'
#' + Dodeljivanje `imena`
#' + Definisanje `argumenata`
#' + Programiranje `tela` funckije (body) koje se sastoji od koda koji treba da se izvrši
#'
#' Na primer ukoliko zelimo da napravimo funkciju koja pretvara decimalni zapis ugla u stepenima u radijane, to ćemo učiniti na sledeći način
#'
#+

step2rad <- function(ang_step){
  ang_step*pi/180
}

step2rad(180)

#' Ukoliko zelimo da napravimo funkciju koja pretvara decimalni zapis ugla u zapis step-min-sec to ćemo uraditi na sledeći način:

dec2dms <- function(ang){ # ime funkcije je `dec2dms`, a argument `ang`
  deg <- floor(ang)
  minut <- floor((ang-deg)*60)
  sec <- ((ang-deg)*60-minut)*60
  return(paste(deg, minut, round(sec, 0), sep = " "))
}

dec2dms(ang = 35.26589)

dec2dms(45.52658)

#'
#' Ukoliko želimo da napravimo funkciju od koda koji smo kreirali za potrebe oblikovanja ulaznih podataka to ćemo uraditi na sledeći način.
#'

merenja <- read.table(file = "D:/R_projects/Nauka_R/Slides/data/nivelman.txt", header = TRUE, sep = ",", stringsAsFactors = FALSE)

nivelman <- function(niv_merenja, reperi){ # ime funkcije je nivelman, a argumenti niv_merenja (ulazna merenja) i reperi (naziv repera)

  # kopiramo kod koji smo kreirali ()
  merenja_df <- niv_merenja %>% dplyr::mutate(stanica = factor(rep(1:(dim(niv_merenja)[1]/4), each = 4))) %>%
    dplyr::group_by(stanica) %>%
    dplyr::summarise(od = as.character(tacka[1]),
                     do = as.character(tacka[2]),
                     dh = ((merenje[2]-merenje[1])+(merenje[3]-merenje[4]))/2,
                     duzina = sum(duzina)/2)

  merenja_df <- merenja_df %>% dplyr::mutate(isReperOD = merenja_df$od %in% reperi,
                                             isReperDO = merenja_df$do %in% reperi)

  #indeks pozicije "od" repera,
  ind.od <- which(merenja_df$isReperOD == T)
  # indeks pozicije "do" repera
  ind.do <- which(merenja_df$isReperDO == T)

  # broj vis razlika izmedju repera
  ndh = sum(merenja_df$isReperOD)

  # Promenljiva koja pokazuje koja merenja pripadaju odredjenom nivelmanskom vlaku
  vlak <- c()
  for(i in 1:ndh){
    vlak <- c(vlak, rep(i, ind.do[i]-(ind.od[i]-1)))
  }

  merenja_df$vlak <- factor(vlak)

  merenja_df_sum <- merenja_df %>% dplyr::select(od, do, dh, duzina, vlak) %>%
    dplyr::group_by(vlak) %>%
    dplyr::summarize(od = od[1],
                     do = do[length(vlak)],
                     dh = sum(dh),
                     stanica = length(vlak))

  merenja_df <- merenja_df %>% dplyr::select(od, do, dh, duzina)

  results <- list(tabela_1 = merenja_df, tabela_2 = merenja_df_sum)
  return(results) # Ukoliko je u okviru funkcije kreirano više promenljivih, komandom `return` biramo koja promenljiva će biti rezultat naše funkcije
}

nivelman(niv_merenja = merenja, reperi = c("B1", "B3", "B4", "B5"))

#'
#'
#'
#' >
Zadatak 1

#' > + Učitati excel fajl sa svim merenjima u mreži (`niv_merenja.xlsx`). Fajl je organizovan tako  da su merenja u pojedinačnim vlakovima smeštena u odvojenim excel sheet-ovima. Za učitavanje excel fajla sa više sheet-ova koristiti uputstva data na linku `readxl` paketa: https://readxl.tidyverse.org/articles/articles/readxl-workflows.html#iterate-over-multiple-worksheets-in-a-workbook. Rezultat učitanih merenja je lista!
#' > + Primeniti funkciju na svim elementima liste.
#' > + Spojiti odgovarajuće tabele u jednu, tako da na kraju imamo dve tabele, jednu koja se odnosi na merenja na stanici i jednu sumarnu tabelu.

#'
#'
#' >
Zadatak 1 - Resenje 1

# Imena svih repera u mrezi:
reperi <- c("B1", "B3", "B4", "B5", "B6", "B7", "B8", "B9", "S1", "S2", "S3", "D1", "H1", "J1", "M1", "P1", "D7", "H7", "N7", "D10", "E10", "I10", "P10", "P13", "L116",	"D19", "G19", "J19", "M19", "P19", "E26", "P26", "D29", "J29", "M29", "P29", "D32", "H32", "D38", "G38", "J38", "M38", "P38", "A11", "A12", "A13", "A14", "A21", "A22",	"A23", "A24")

# Putanja ka fajlu (3 nacina)
merenja_path <- "D:/R_projects/Nauka_R/Slides/data/niv_merenja.xlsx"
merenja_path <- here::here("data", "niv_merenja.xlsx")
files_data <- list.files("D:/R_projects/Nauka_R/Slides/data/", full.names = TRUE)
merenja_path <- files_data[6]

# Nazivi sheet-ova
nazivi_sheets <- merenja_path %>%
  readxl::excel_sheets()

# Ucitavanje svakog sheet-a i smestanje u listu
lista_sheets <- list()
for(i in 1:length(nazivi_sheets)){
  lista_sheets[[i]] <- readxl::read_excel(path = merenja_path, sheet = nazivi_sheets[i])
}
names(lista_sheets) <- nazivi_sheets # postavljanje naziva elemenata liste
# lista_sheets

# Primena funkcije nivelman
lista_nivelman <- list()
for(i in 1:length(lista_sheets)){
  lista_nivelman[[i]] <- nivelman(niv_merenja = lista_sheets[[i]], reperi = reperi)
}
# lista_nivelman

# Visinske razlike po stanici - Tabela 1
tabela_1 <- data.frame()
for(i in 1:length(lista_nivelman)){
  tabela_1 <- rbind(tabela_1, lista_nivelman[[i]][[1]])
}
# tabela_1

# Visinske razlike od repera do repera - Tabela 2
tabela_2 <- data.frame()
for(i in 1:length(lista_nivelman)){
  tabela_2 <- rbind(tabela_2, lista_nivelman[[i]][[2]])
}
# tabela_2

#' >
Zadatak 1 - Resenje 2

# Imena svih repera u mrezi:

library(tidyverse)
library(magrittr)
library(here)
library(readxl)
library(purrr)

reperi <- c("B1", "B3", "B4", "B5", "B6", "B7", "B8", "B9", "S1", "S2", "S3", "D1", "H1", "J1", "M1", "P1", "D7", "H7", "N7", "D10", "E10", "I10", "P10", "P13", "L116",	"D19", "G19", "J19", "M19", "P19", "E26", "P26", "D29", "J29", "M29", "P29", "D32", "H32", "D38", "G38", "J38", "M38", "P38", "A11", "A12", "A13", "A14", "A21", "A22",	"A23", "A24")

merenja_path <- here::here("data", "niv_merenja.xlsx")

merenja <- merenja_path %>%
  readxl::excel_sheets() %>%
  purrr::set_names() %>%
  purrr::map(read_excel, path = merenja_path)

# Drugi nacin
# https://stackoverflow.com/questions/12945687/read-all-worksheets-in-an-excel-workbook-into-an-r-list-with-data-frames
library(rio)
data_list <- import_list("D:/R_projects/Nauka_R/Slides/data/niv_merenja.xlsx", rbind = TRUE) # parametrom rbind (row bind - spojiti redove) dobijamo sve clanove liste spojene u jedan data.frame

# Nazivi repera
Tacke <- unique(data_list$tacka)
substr(Tacke,1,1)
toupper(substr(Tacke,1,1))
Tacke_sve <- tapply(Tacke, toupper(substr(Tacke,1,1)),identity)
# tapply() is a very powerful function that lets you break a vector into pieces and then apply some function to each of the pieces
Reperi <- unlist(Tacke_sve[9:21][]) %>% as.data.frame() %>% dplyr::rename(tac = ".")
reperi <- as.vector(Reperi$tac)

# Primena funkcije nivelman nad svim clanovima liste
mreza_all <- lapply(merenja, function(x) nivelman(niv_merenja = x, reperi = reperi))

# Visinske razlike po stanici - Tabela 1
mreza_by_station <- lapply(mreza_all, function(x) x[[1]])

# Visinske razlike od repera do repera - Tabela 2
mreza_oddo <- lapply(mreza_all, function(x) x[[2]])

# Tabela merenja po stanici
mreza_by_station <- do.call(rbind, mreza_by_station)
mreza_by_station %<>% as.data.frame()

# Sumarna tabela
mreza_oddo <- do.call(rbind, mreza_oddo)
mreza_oddo %<>% dplyr::mutate(vlak = row_number()) %>% as.data.frame()

#'


#' dmrff
#'
#' Identifying differentially methylated regions efficiently with power and control.
#'
#' @param estimate Vector of association effect estimates
#' (corresponds to rows of \code{methylation}).
#' @param se Vector of standard errors of the effect estimates.
#' @param p.value Vector of p-values.
#' @param methylation Methylation matrix (rows=features, columns=samples).
#' @param chr Feature chromosome (corresponds to rows of \code{methylation}).
#' @param pos Feature chromosome position.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#'
#' dmrs <- dmrff(estimate, ## effect estimate for each CpG site
#'               se,       ## standard error of the estimate for each CpG site
#'               p.value,  ## p-value
#'               methylation, ## methylation matrix
#'               chr,      ## chromosome of each CpG site
#'               pos)      ## position of each CpG site
#'
#' dmrs[which(dmrs$p.adjust < 0.05),
#'      c("chr","start","end","n","B","S","z","p.value","p.adjust")]
#'
#' @export
dmrff <- function(estimate, se, p.value, methylation, chr, pos,
                  maxgap=500, p.cutoff=0.05, verbose=T) {
    stopifnot(is.vector(estimate))
    stopifnot(is.vector(se))
    stopifnot(is.vector(p.value))
    stopifnot(is.matrix(methylation))
    stopifnot(length(estimate) == length(se))
    stopifnot(length(estimate) == nrow(methylation))
    stopifnot(length(estimate) == length(p.value))
    stopifnot(length(estimate) == length(chr))
    stopifnot(length(estimate) == length(pos))

    candidates <- dmrff.candidates(estimate=estimate,
                                   p.value=p.value,
                                   chr=chr,
                                   pos=pos,
                                   maxgap=maxgap,
                                   p.cutoff=p.cutoff,
                                   verbose=verbose)

    stats <- shrink.candidates(candidates$start.idx, candidates$end.idx,
                               function(start.idx,end.idx) {
                                   idx <- start.idx:end.idx
                                   ivwfe.getz(estimate[idx], se[idx], methylation[idx,,drop=F])
                               })

    full <- do.call(rbind, mclapply(1:nrow(stats), function(i) {
        idx <- stats$start.idx[i]:stats$end.idx[i]
        ivwfe.stats(estimate[idx], se[idx], methylation[idx,,drop=F])
    }))

    stats$estimate <- stats$B <- full[,"B"]
    stats$se <- stats$S <- full[,"S"]

    collate.stats(stats, chr, pos)
}

collate.stats <- function(stats, chr, pos) {
    stats <- with(stats, data.frame(chr=chr[start.idx],
                                    start=pos[start.idx],
                                    end=pos[end.idx],
                                    n=end.idx-start.idx+1,
                                    start.idx=start.idx,
                                    end.idx=end.idx,
                                    start.orig=start.orig,
                                    end.orig=end.orig,
                                    z.orig=z.orig,
                                    p.orig=2*pnorm(-abs(z.orig), lower.tail=T),
                                    B=B,
                                    S=S,
                                    estimate=estimate,
                                    se=se,
                                    z=z,
                                    p.value=2*pnorm(-abs(z), lower.tail=T)))
    number.tests <- length(chr) + calculate.number.shrink.tests(stats)
    stats$p.adjust <- pmin(1, stats$p.value * number.tests)
    stats
}


# load libraries
source("./00_functions_library.r")

library(foreign)
library(coda)
library(rjags)

load.module('dic')

# paths
path.stata <- file.path('data', 'database_counts_all.dta', sep='')
path.model.joint <- file.path('model_joint_nocorrelations_all.r', sep='')
res.path <- file.path('bayes_results', sep='')
stem <- 'joint_nocorrelations'

# jags fitting
model.file <- path.model.joint
n.adapt <- 50000
n.burn.in <- 100000
n.record <- 400000

#########################################
# DATA
#########################################

data <- read.dta(path.stata)

# Organize the data into 4 categories:
# 1. Both tests, crosstabs for TPR AND FPR
# 2. Both tests, crosstabs for TPR BUT NOT FOR FPR
# 3. Both tests, no crosstabs
# 4. Only femur

both.tests.tpr <- (!is.na(data["down_n_1dot"]) & !is.na(data[,"down_n_dot1"]))
miss.crosstab.tpr <- (both.tests.tpr==TRUE & is.na(data[,"down_n_00"]))
with.crosstab.tpr <- (both.tests.tpr==TRUE & !is.na(data[,"down_n_00"]))

both.tests.fpr <- (!is.na(data["nodown_n_1dot"]) & !is.na(data[,"nodown_n_dot1"]))
miss.crosstab.fpr <- (both.tests.fpr==TRUE & is.na(data[,"nodown_n_00"]))
with.crosstab.fpr <- (both.tests.fpr==TRUE & !is.na(data[,"nodown_n_00"]))

only.femur <- (both.tests.tpr==FALSE) # true also for fpr in the dataset

## Group 1
# observational part of the model
# x order is 11 10 01 00
# first humerus, second femur
#
x.down.11.G1 <- as.vector(data[with.crosstab.fpr, 'down_n_11'])
x.down.1dot.G1 <- as.vector(data[with.crosstab.fpr, 'down_n_1dot'])
x.down.dot1.G1 <- as.vector(data[with.crosstab.fpr, 'down_n_dot1'])

x.nodown.11.G1 <- as.vector(data[with.crosstab.fpr, 'nodown_n_11'])
x.nodown.1dot.G1 <- as.vector(data[with.crosstab.fpr, 'nodown_n_1dot'])
x.nodown.dot1.G1 <- as.vector(data[with.crosstab.fpr, 'nodown_n_dot1'])

N.down.G1 <- as.vector(data[with.crosstab.fpr, 'down_n'])
N.nodown.G1 <- as.vector(data[with.crosstab.fpr, 'nodown_n'])

K.G1 <- length(N.down.G1)

## Group 4
# observational part of the model
#
x.down.dot1.G4 <- as.vector(data[only.femur, 'down_n_dot1'])
x.nodown.dot1.G4 <- as.vector(data[only.femur, 'nodown_n_dot1'])

N.down.G4 <- as.vector(data[only.femur, 'down_n'])
N.nodown.G4 <- as.vector(data[only.femur, 'nodown_n'])

K.G4 <- length(N.down.G4)

I <- diag(rep(1,6))
P.G4 <- I[,c(2, 5, 1, 3, 4, 6)]

# Priors
## priors -- flat
mu0 <- rep(0, 6)
prec.mu0 <- rep(10^-6, 6)
s.lower <- rep(10^-3, 6)
s.upper <- rep(5, 6)
chol.r.lower <- rep(10^-3, 15)
chol.r.upper <- rep(pi-10^-3, 15)

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

jags.data <- list('K.G1' = K.G1, 'K.G4' = K.G4, 'P.G4' = P.G4,
                  'x.down.11.G1' = x.down.11.G1, 'x.down.1dot.G1' = x.down.1dot.G1,
                  'x.down.dot1.G1' = x.down.dot1.G1, 'N.down.G1' = N.down.G1,
                  'x.nodown.11.G1' = x.nodown.11.G1, 'x.nodown.1dot.G1' = x.nodown.1dot.G1,
                  'x.nodown.dot1.G1' = x.nodown.dot1.G1, 'N.nodown.G1' = N.nodown.G1,
                  'x.down.dot1.G4' = x.down.dot1.G4, 'N.down.G4' = N.down.G4,
                  'x.nodown.dot1.G4' = x.nodown.dot1.G4, 'N.nodown.G4' = N.nodown.G4,

                  'mu0' = mu0, 'prec.mu0' = prec.mu0,
                  's.lower' = s.lower, 's.upper' = s.upper,
                  'chol.r.lower' = chol.r.lower, 'chol.r.upper' = chol.r.upper)

#########################################
# RUN THE MODEL AND MONITOR RESULTS
#########################################

the.jags.model <- jags.model(file=model.file,
                data=jags.data,
                n.chains=3, n.adapt=n.adapt)

update(the.jags.model, n.iter=n.burn.in)

the.mcmc.res <- my.coda.samples(the.jags.model,
                              c('deviance', 'pD','tpr.hum', 'fpr.hum', 'jtpr', 'jfpr',
                              'tpr.fem', 'fpr.fem', 'diff.tpr', 'diff.fpr',
                              'or.tpr', 'or.fpr', 'Eta.Xi', 'diff.eta', 'diff.xi',
                              'S[1,1]', 'S[2,2]', 'S[3,3]', 'S[4,4]', 'S[5,5]', 'S[6,6]',
                              'R[1,2]', 'R[1,3]', 'R[1,4]', 'R[1,5]', 'R[1,6]',
                                        'R[2,3]', 'R[2,4]', 'R[2,5]', 'R[2,6]',
                                                  'R[3,4]', 'R[3,5]', 'R[3,6]',
                                                            'R[4,5]', 'R[4,6]',
                                                                      'R[5,6]'),
                              n.iter=n.record, thin=20)

#########################################
# SPIT RESULTS TO STATA
#########################################

## collect stats -- the first part in the list is the non-pD chains
stats <- summary(the.mcmc.res[[1]])

pD <- c("pD", summary(the.mcmc.res[[2]], mean)$stat, NA, NA, NA)
stats.m <- cbind(rownames(stats[[1]]), stats[[1]])
stats.m <- rbind(stats.m, pD)
colnames(stats.m)[1:5]<-c("node", "mean", "sd", "naivese", "timeseriesse")

problist <- c(0.025, 0.25, 0.50, 0.75, 0.975)
pD <- c("pD", quantile(the.mcmc.res[[2]], probs=problist))
stats.q <- cbind(rownames(stats[[2]]), stats[[2]])
stats.q <- rbind(stats.q, pD)
colnames(stats.q)[1:6] <- c("node","p025","p250", "p500", "p750", "p975")

write.table(stats.m, file=paste(res.path,"/","stats_m_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)
write.table(stats.q, file=paste(res.path,"/","stats_q_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)

# save the trace plots
png(paste(res.path, "/", stem, "_%02d.png", sep=""))
plot(the.mcmc.res[[1]])
dev.off()

# collect diagnostics
gelman <- gelman.diag(the.mcmc.res[[1]])

gelman.row.names <- rownames(gelman[[1]])
gelman.table <-cbind(gelman.row.names, gelman[[1]], rep(gelman[[2]], length(gelman.row.names)))
colnames(gelman.table)<- c("node", "prsf500", "prsf975", "prsf975_multi")
write.table(gelman.table, file=paste(res.path,"/","gelman_", stem, ".txt", sep=''), sep='\t',row.names = FALSE)


library(data.table)

setwd("~/Dropbox/liverpool/retail_typology/data/income")

pop_probs_sc <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_dz15_probs.csv")
pop_probs_ew <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_msoa15_probs.csv")

income_sc <- fread("income_estimates_scotland_2014.csv")[,.(dz11, income_pw_mean)]
setnames(income_sc, names(income_sc), c("lsoa11", "income_mean"))

income_ew <- fread("income_estimates_ew_2014.csv")[,.(msoa11cd, total_income_pw)]
setnames(income_ew, names(income_ew), c("msoa11", "income_mean"))

# lsoa_probs <- fread("~/Dropbox/liverpool/retail_typology/data/lsoa_probs.csv")
# msoa_probs <- fread("~/Dropbox/liverpool/retail_typology/data/msoa_probs.csv")

pop_probs_sc_income <- pop_probs_sc[income_sc, on = "lsoa11", nomatch = 0]
pop_probs_sc_income[,lsoa11 := NULL]
pop_probs_ew_income <- pop_probs_ew[income_ew, on = "msoa11", nomatch = 0]
pop_probs_ew_income[,msoa11 := NULL]

income_probs <- rbindlist(list(pop_probs_sc_income, pop_probs_ew_income))
setkey(income_probs, cluster_id)

pop_total <- income_probs[, sum(weighted_pop), by = "cluster_id"]
setnames(pop_total, "V1", "resident_pop")
fwrite(pop_total, "~/Dropbox/liverpool/retail_typology/analysis/indicators/pop_catchments_weighted.csv")

income_probs[, weight := weighted_pop / total_pop]
mean_weighted_income <- income_probs[, weighted.mean(income_mean, weight), by = "cluster_id"]
setnames(mean_weighted_income, "V1", "mean_income")
fwrite(mean_weighted_income, "~/Dropbox/liverpool/retail_typology/analysis/indicators/mean_income.csv")


#' Shiny app server function
#'
#' Server function to run the deterministic model
#'
#' @param input provided by shiny
#' @param output provided by shiny
#' @import shiny

det_mod_server <- function(input, output, session){

  #Create the reactive parameter set and run the model:
  react.params <- reactive({
    list(
         ini.prev = input$ini.prev,
         n.age.cats = 10,
         n.i.cats = input$n.i.cats,
         n.e.cats = input$n.e.cats,
         e.move = input$e.move,
         i.move = input$i.move,
         beta = input$beta,
         theta = 1,

         k.k.c = input$k.k.c,
         a.a.c = input$a.a.c,
         k.a.c = input$k.a.c,
         eld.c = input$eld.c,
         red.c = input$red.c,

         #future change here
         s.lo = input$s.lo,
         s.hi = input$s.hi,

         n0 = input$n0,
         n.days = input$n.days,
         d.no = input$d.no,
         d.yes = input$d.yes,
         beds = input$beds
         )
  })

  simout <- reactive({
    params <- react.params()

    #Calculate some of the derived parameters

    # calculate severity vector as an exponential model from lo to hi
    # based on x_t = x_0(1+r)^t
    r <- (params$s.hi / params$s.lo)^(1/params$n.age.cats) - 1
    params$severity <- params$s.lo * (1+r) ^ seq(1,params$n.age.cats, 1)

    #browser()
    #contact matrix
    contacts <- matrix(1, nrow = 10, ncol = 10)
    diagonal <- c(params$k.k.c, params$k.k.c, params$a.a.c, params$a.a.c, params$a.a.c,
                  params$a.a.c, params$a.a.c, params$eld.c, params$eld.c, params$eld.c)
    diag(contacts) <- diagonal
    contacts[8:10, ] <- params$eld.c
    contacts[ ,8:10] <- params$eld.c
    contacts[1, 3:4] <- params$k.a.c
    contacts[3:4, 1] <- params$k.a.c
    contacts[3:7, 3:7] <- params$a.a.c

    params$contacts <- contacts * (1-params$red.c)

    #run model
    out <- det_model(params)
    out
  })

  output$TotalPlot <- renderPlot({
    out <- simout()
    p1 <- plot_totals_time(out$counts)
    p2 <- plot_prev_time(out$counts)
    plot_grid(p1, p2, nrow = 1)
  })

  output$CasesPlot <- renderPlot({
    out <- simout()
    p1 <- plot_cases_time(out$counts$It, total = T)
    p2 <- plot_cases_time(out$counts$It, total = F)
    plot_grid(p1, p2, nrow = 1)
  })

  output$HospitalPlot <- renderPlot({
    out <- simout()
    p1 <- plot_hos_time(out$outcomes$Ht, total = T)
    p2 <- plot_hos_time(out$outcomes$Ht, total = F)
    plot_grid(p1, p2, nrow = 1)
  })

  output$DeathsPlot <- renderPlot({
    out <- simout()
    p1 <- plot_deaths_time(out$outcomes$Dt, total = T)
    p2 <- plot_deaths_time(out$outcomes$Dt, total = F)
    plot_grid(p1, p2, nrow = 1)
  })

  output$ParamPlot <- renderPlot({
    params <- react.params()
    p1 <- plot_periods(e.move = params$e.move, i.move = params$i.move,
                 n.e.cats = params$n.e.cats, n.i.cats = params$n.i.cats)
    p2 <- plot_severity(s.lo = params$s.lo, s.hi = params$s.hi,
                        n.age.cats = params$n.age.cats)
    plot_grid(p1, p2, nrow = 1)

  })

  output$AgePlot <- renderPlot({
    out <- simout()
    plot_age_dist(out$counts)
  })

  output$ContactPlot <- renderPlot({
    params <- react.params()

    #contact matrix
    contacts <- matrix(1, nrow = 10, ncol = 10)
    diagonal <- c(params$k.k.c, params$k.k.c, params$a.a.c, params$a.a.c, params$a.a.c,
                  params$a.a.c, params$a.a.c, params$eld.c, params$eld.c, params$eld.c)
    diag(contacts) <- diagonal
    contacts[8:10, ] <- params$eld.c
    contacts[ ,8:10] <- params$eld.c
    contacts[1, 3:4] <- params$k.a.c
    contacts[3:4, 1] <- params$k.a.c
    contacts[3:7, 3:7] <- params$a.a.c
    params$contacts <- contacts * ( 1- params$red.c)# percent reduction overall

    p1 <- plot_contacts(params$contacts)

    out <- simout()
    p2 <- plot_exposed_age_end(out$counts)
    plot_grid(p1, p2, nrow = 2)
    })
}