# prepare
# data from last ten seasons on data.vti.be
# only selected collaborations between people with functions 11571, 11741, 11933, 11971, 11977, 12009, 12014, 12018, 12019, 12092, 12156
# where production is not a rerun of anything

library(igraph)
library(jsonlite)

#setwd("C:/Users/ruet/Documents/datasets/data-vti-be/")
df = read.delim("edgelist.el", sep="\t", header=F)
df$V1 = as.character(df$V1)
df$V2= as.character(df$V2)
g = graph.edgelist(as.matrix(df), directed = FALSE)
E(g)$weight <- 1
g.simple = simplify(g, remove.loops=TRUE) # simplify graph by mapping duplicate edges onto each other, sum weight

# remove passanten
g.simple = delete.edges(g.simple, which(E(g.simple)$weight < 2))
g.simple = delete.vertices(g.simple, which(degree(g.simple) < 2))

# read in persontable
persontable = read.delim("person.table", sep="\t", header=F)
persontable$V1 = as.character(persontable$V1)

# how many actors in this sample?
vcount(g.simple)

# make plot, may take a while...
png("report/full_graph.png", width=5000, height=2500, res=200)
plot(g.simple,
  layout = layout.fruchterman.reingold,
  vertex.label = NA,
  vertex.size = 1.5
)
dev.off()

# how many actors play how often together
png("report/samenwerkingsfrequentiedistributie.png", width=1000, height=600, res=100)
hist(E(g.simple)$weight, breaks=seq(1, max(E(g.simple)$weight), 1), freq=FALSE)
dev.off()

# get subgraphs
V(g.simple)$cluster <- clusters(g.simple)$membership

# biggest group of connected actors make up 72% of whole community
sort(clusters(g.simple)$csize, decreasing=TRUE)[1] / sum(clusters(g.simple)$csize)

# who is in the sizeable seperate subgraphs?
# let's look at unconnected groups of 5 people and more
tenplusgroups = c(1:length(clusters(g.simple)$csize))[clusters(g.simple)$csize < 100 & clusters(g.simple)$csize >= 10]
for (i in tenplusgroups){
  print(i)
  for (j in (V(g.simple)[V(g.simple)$cluster == i])$name) {
    print(as.character(persontable[persontable$V1 == j, ]$V2))
  }
}

# Now select only the biggest connected cluster
g.simple.trim = induced.subgraph(g.simple, V(g.simple)[V(g.simple)$cluster == which.max(clusters(g.simple)$csize)])
vcount(g.simple.trim)

# how many actors play how often together
png("report/samenwerkingsfrequentiedistributie_mainstream.png", width=1000, 600, res=100)
hist(E(g.simple.trim)$weight, breaks=seq(min(E(g.simple.trim)$weight), max(E(g.simple.trim)$weight), 1), freq=FALSE)
dev.off()

# let us see if there are any communities in this
fgc = fastgreedy.community(g.simple.trim)

# plot
V(g.simple.trim)$color <- rainbow(max(fgc$membership))[fgc$membership]
png("report/biggest_cluster_graph_FGCcoloring.png", width=5000, height=3000, res=300)
plot(g.simple.trim,
  layout = layout.fruchterman.reingold,
  vertex.label = NA,
  vertex.size = 2.5
)
dev.off()

# can we interpret the clusters by looking at who is in them?
bet = betweenness(g.simple.trim)
communities = c(1:max(fgc$membership))
for (i in communities){
  print(i)
  for (j in fgc$name[fgc$membership == i]) {
    name = as.character(persontable[persontable$V1 == j, ]$V2)
    print(name)
  }
}

# let's add some network properties of the nodes
metrics <- data.frame(
  deg = degree(g.simple.trim), # number of adjacent edges
  bet = betweenness(g.simple.trim), # number of shortest paths through vertex
  clo = closeness(g.simple.trim), # how many steps is required to access every other vertex
  eig = evcent(g.simple.trim)$vector, # the eigenvector centralities of positions (most important vertices)
  tra = transitivity(g.simple.trim, type=c("local")) # the probability that the adjacent vertices of a vertex are connected
)

# table of nodes
fgc.simple = fastgreedy.community(g.simple)
## id, label, value (centrality), group
nodes = persontable[persontable$V1 %in% V(g.simple)$name, ]
colnames(nodes) = c("id", "label")
nodes$title = nodes$label
values = evcent(g.simple)$vector[nodes$id]
values.norm = ((values - min(values)) / (max(values) - min(values)) * 10) + 10
nodes$value = values.norm
names(fgc.simple$membership) <- fgc.simple$names
nodes$group = fgc.simple$membership[nodes$id]
nodes$id = as.numeric(nodes$id)
write(jsonlite::toJSON(nodes), "report/nodes.js")

# table of edges
## from, to, value (weight)
edges = get.edgelist(g.simple)
colnames(edges) <- c("from", "to")
edges = as.data.frame(edges)
edges$value <- as.vector(E(g.simple)$weight)
edges$from = as.numeric(as.vector(edges$from))
edges$to = as.numeric(as.vector(edges$to))
write(jsonlite::toJSON(edges), "report/edges.js")


    get.over.identify <- function(dy,
                                  dx,
                                  dz,
                                  robust = 0,
                                  cl=NULL,
                                  df.cl=NULL,
                                  u.hat,
                                  inv.z=NULL,
                                  en.var.x,
                                  exclude.iv,
                                  orthog=NULL){
        if(is.null(orthog)==FALSE){
            if(length(orthog)>(length(exclude.iv)-length(en.var.x))){
                stop("Collinearity/identification problems in orthog conditions.\n")
            }
            for(var in orthog){
                if(!var%in%colnames(dz)){
                    stop(paste0(var," is not an excluded instrument nor an included instrument variables.\n"))
                }
            }
            new.dx <- dx
            new.dz <- dz[,colnames(dz)[which(!colnames(dz)%in%orthog)]]
            new.dz <- matrix(new.dz,ncol=dim(dz)[2]-length(orthog))
            colnames(new.dz) <- colnames(dz)[which(!colnames(dz)%in%orthog)]
        }
        over.identify <- list()
        if(is.null(cl)){
            if(robust==FALSE){ #Sargan's Statistic
                #egmm.coef <- model.iv$coefficients
            }else{ #Hansen's Test
                #meat <- dz * matrix(rep(c(u.hat), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                #meat <- t(meat) %*% meat
                #meat <- meat*dim(dz)[1]/sub.df
                #egmm.coef <- solve(t(dx)%*%dz%*%solve(meat)%*%t(dz)%*%dx)%*%t(dx)%*%dz%*%solve(meat)%*%t(dz)%*%dy
                #hansen.meat <- meat
                #colnames(hansen.meat) <- rownames(hansen.meat) <- colnames(dz)
                #u.hat.egmm <- dy - dx%*%egmm.coef
                get.gmm <- solvegmm(Y=dy,X=dx,Z=dz, u_hat=u.hat)
                hansen.meat <- meat <- get.gmm[['meat']]
                inv.hansen.meat <- get.gmm[['invmeat']]
                colnames(inv.hansen.meat) <- rownames(inv.hansen.meat) <- colnames(hansen.meat) <- rownames(hansen.meat) <- colnames(dz)
                egmm.coef <- get.gmm[['coef']]
                u.hat.gmm <- get.gmm[['u_hat']]
            }
        }else{
            if (dim(cl)[2] == 1) {
                stderror <- cluster.se(cl = cl, x = NULL, res = u.hat, dx =dz,
                                       sfe.index = NULL,
                                       cfe.index = NULL,
                                       ind = NULL, df = NULL, invx = inv.z,
                                       df.cl = df.cl)
                meat <- stderror$meat
            }
            if (dim(cl)[2] == 2) {
                stderror1 <- cluster.se(cl = as.matrix(cl[,1]), x = NULL, res = u.hat, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = df.cl[1])
                meat1 <- stderror1$meat

                stderror2 <- cluster.se(cl = as.matrix(cl[,2]), x = NULL, res = u.hat, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = df.cl[2])
                meat2 <- stderror2$meat

                cl_inter <- as.numeric(as.factor(paste(cl[,1], "-:-", cl[,2], sep = "")))
                #if cl_inter is unique; then stderror3 is robust standard error
                cl_inter.count <- table(cl_inter)

                if(max(cl_inter.count)==1){
                    meat3 <- dz * matrix(rep(c(u.hat), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                    meat3 <- as.matrix(t(meat3) %*% meat3)
                }else{
                    stderror3 <- cluster.se(cl = as.matrix(cl_inter), x = NULL, res = u.hat, dx =dz,
                                            sfe.index = NULL,
                                            cfe.index = NULL,
                                            ind = NULL, df = NULL, invx = inv.z,
                                            df.cl = df.cl[3])
                    meat3 <- stderror3$meat
                }
                meat <- meat1 + meat2 - meat3
            }
            #egmm.coef <- solve(t(dx)%*%dz%*%solve(meat)%*%t(dz)%*%dx)%*%t(dx)%*%dz%*%solve(meat)%*%t(dz)%*%dy
            #hansen.meat <- meat
            #colnames(hansen.meat) <- rownames(hansen.meat) <- colnames(dz)
            #u.hat.egmm <- dy - dx%*%egmm.coef
            meat <- as.matrix(meat)
            get.gmm <- solvegmm_meat(Y=dy,X=dx,Z=dz,meat=meat)
            hansen.meat <- meat <- get.gmm[['meat']]
            inv.hansen.meat <- get.gmm[['invmeat']]
            colnames(inv.hansen.meat) <- rownames(inv.hansen.meat) <- colnames(hansen.meat) <- rownames(hansen.meat) <- colnames(dz)
            egmm.coef <- get.gmm[['coef']]
            u.hat.gmm <- get.gmm[['u_hat']]
        }

        if(length(en.var.x)<length(exclude.iv)){
            #overidentification
            if(is.null(cl)){
                if(robust==FALSE){ #Sargan's Statistic
                    sargan <- (t(u.hat)%*%dz%*%inv.z%*%t(dz)%*%u.hat/(t(u.hat)%*%u.hat))*dim(dz)[1]
                    p.sargan <- pchisq(sargan, df=length(exclude.iv)-length(en.var.x), lower.tail=FALSE)
                    sargan.statistic <- c(sargan,length(exclude.iv)-length(en.var.x),p.sargan)
                    names(sargan.statistic) <- c("Sargan Statistic","df","P value")
                    over.identify$sargan <- sargan.statistic
                }else{ #Hansen's Test
                    J.hansen <- get.gmm[["hansen"]]
                    p.hansen <- pchisq(J.hansen, df=length(exclude.iv)-length(en.var.x), lower.tail=FALSE)
                    hansen.statistic <- c(J.hansen,length(exclude.iv)-length(en.var.x),p.hansen)
                    names(hansen.statistic) <- c("Hansen Statistic","df","P value")
                    over.identify$hansen <- hansen.statistic
                }
            }else{
                J.hansen <- get.gmm[["hansen"]]
                p.hansen <- pchisq(J.hansen, df=length(exclude.iv)-length(en.var.x), lower.tail=FALSE)
                hansen.statistic <- c(J.hansen,length(exclude.iv)-length(en.var.x),p.hansen)
                names(hansen.statistic) <- c("Hansen Statistic","df","P value")
                over.identify$hansen <- hansen.statistic
            }

            if(is.null(orthog)==FALSE){ # get C statistics
                                        # use old sigma^2 & S
                #new.inv.z <- solve(t(new.dz)%*%new.dz)
                #new.Pz <- new.dz%*%new.inv.z%*%t(new.dz)
                #new.inv.xPzx <- solve(t(new.dx)%*%new.Pz%*%new.dx)
                #new.inv.z.zx <- new.inv.z%*%t(new.dz)%*%new.dx
                #new.iv.coef <- matrix(new.inv.xPzx%*%t(new.dx)%*%new.Pz%*%dy,ncol=1)
                #rownames(new.iv.coef) <- colnames(new.dx)
                #new.u.hat <- matrix(dy-new.dx%*%new.iv.coef,ncol=1)

                iv.solve.new <- solveiv(Y=dy,X=new.dx,Z=new.dz)
                new.u.hat <- iv.solve.new[["residual"]]
                new.iv.coef <- iv.solve.new[["coef"]]
                rownames(new.iv.coef) <- colnames(new.dx)
                new.inv.z <- iv.solve.new[["invzz"]]

                if(is.null(cl)){
                    if(robust==FALSE){ #Sargan's Statistic
                        new.sargan <- (t(new.u.hat)%*%new.dz%*%new.inv.z%*%t(new.dz)%*%new.u.hat/(t(u.hat)%*%u.hat))*dim(dz)[1] #use original sigma^2 (u.hat)
                        C.value <- sargan-new.sargan
                        C.p.value <- pchisq(C.value, df=length(orthog), lower.tail=FALSE)
                        C.statistic <- c(C.value,length(orthog),C.p.value)
                        names(C.statistic) <- c("C Statistic","df","P value")
                        over.identify$C.statistic <- C.statistic
                    }else{ #Hansen's Test
                           #Use original meat
                        new.meat <- as.matrix(hansen.meat[colnames(new.dz),colnames(new.dz)])
                        new.get.gmm <- solvegmm_meat(Y=dy,X=new.dx,Z=new.dz,meat=new.meat)
                        new.J.hansen <- new.get.gmm[['hansen']]
                        #new.egmm.coef <- solve(t(new.dx)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%new.dx)%*%t(new.dx)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%dy
                        #new.u.hat.egmm <- dy - new.dx%*%new.egmm.coef
                        #new.J.hansen <- t(new.u.hat.egmm)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%new.u.hat.egmm
                        C.value <- J.hansen-new.J.hansen
                        C.p.value <- pchisq(C.value, df=length(orthog), lower.tail=FALSE)
                        C.statistic <- c(C.value,length(orthog),C.p.value)
                        names(C.statistic) <- c("C Statistic","df","P value")
                        over.identify$C.statistic <- C.statistic
                    }
                }else{
                    new.meat <- as.matrix(hansen.meat[colnames(new.dz),colnames(new.dz)])
                    new.get.gmm <- solvegmm_meat(Y=dy,X=new.dx,Z=new.dz,meat=new.meat)
                    new.J.hansen <- new.get.gmm[['hansen']]
                    #new.egmm.coef <- solve(t(new.dx)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%new.dx)%*%t(new.dx)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%dy
                    #new.u.hat.egmm <- dy - new.dx%*%new.egmm.coef
                    #new.J.hansen <- t(new.u.hat.egmm)%*%new.dz%*%solve(new.meat)%*%t(new.dz)%*%new.u.hat.egmm
                    C.value <- J.hansen-new.J.hansen
                    C.p.value <- pchisq(C.value, df=length(orthog), lower.tail=FALSE)
                    C.statistic <- c(C.value,length(orthog),C.p.value)
                    names(C.statistic) <- c("C Statistic","df","P value")
                    over.identify$C.statistic <- C.statistic
                }
            }
        }
        return(over.identify)
    }


################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

epidic <- function(burnin, niter, LLchain, LLpostmean) {

 # loglikelihood values after burn-in
  loglike <- LLchain[burnin:niter]
  D.bar   <- -2 * mean(loglike)
  D.hat   <- -2 * LLpostmean
  pD      <- D.bar - D.hat
  dic     <- pD + D.bar
  return(dic = dic)
}


R
library(immuneSIM)

# first obtain BCR fasta sequences with different amount of mutations in the variable domains (15, 30, 45, 60).
# here an example for IGH BCR with 15 somatic hypermutations (SHM):

sim_repertoire_IGL_shm15 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "l",
                                        shm.mode="data",
                                        shm.prob=15/350)

write.table(sim_repertoire_IGL_shm15,"igl_shm15.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGL_shm30 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "l",
                                        shm.mode="data",
                                        shm.prob=30/350)

write.table(mm_igl_30_mutations,"igh_shm30.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGL_shm45 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "l",
                                        shm.mode="data",
                                        shm.prob=45/350)

write.table(mm_igh_15_mutations,"igl_shm45.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGL_shm60 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "l",
                                        shm.mode="data",
                                        shm.prob=60/350)

write.table(sim_repertoire_IGL_shm60,"igl_shm60.tsv",quote=F,col.names=T,row.names=F,sep="\t")
q()


# importing libraries
library(plyr)
library(foreign)
library(RWeka)
library(tree)
library(dplyr)
library(caret)
library(gbm)
library(randomForest)

# reading datasets
esl = read.arff("esl.arff")
era = read.arff("era.arff")
lev = read.arff("lev.arff")
swd = read.arff("swd.arff")

# function to create dataset train and test partitions
createPartitions = function(dataset){
  set.seed (20)
  # let's change class attribute name to "class"
  colnames(dataset)[length(dataset)] = "class"
  # we use 66% for train an the rest for test
  trainIndex = sample(1:nrow(dataset), (66*nrow(dataset))/100)
  # returning train and test
  list(as.data.frame(dataset[trainIndex,]),as.data.frame(dataset[-trainIndex,]))
}

# function to create n-1 models to ordinal classification
ordinalDatasets = function(dataset, model)
{
  # extracting the original class attribute
  # (assuming that class attribute is in the end)
  originalClassAttribute = dataset[,length(dataset)]

  # inspecting which classes contains class attribute of the dataset
  classes = sort(unique(originalClassAttribute))

  # we select the first one as current class
  currentClasses = classes[1]

  # let's remove it from classes
  classes = classes[-1]

  # we only need to make numberOfClasses-1 models, so last "classes"
  # item won't be considered.
  # we create a list containing each class combination attribute.
  newClassAttributes = originalClassAttribute
  for(class in classes){
    newClassAttributes = cbind(newClassAttributes,Newclass = ifelse(originalClassAttribute%in%currentClasses, 0, 1))
    currentClasses = c(currentClasses,class)
  }

  # we remove the original class attribute
  newClassAttributes = newClassAttributes[,-1]

  # let's create the models
  models = apply(newClassAttributes, 2, function(class){
        dataset[,length(dataset)] = as.factor(class)
        model(class~., data = dataset)
    })
}

# function to predict an instance (or set of instances) class
ordinalPrediction = function(models, newInstances,classes){
  # firstly we get the probabilities of each instance
  probabilities = lapply(models, function(model){predict(model,newInstances,type="prob")})

  # we transform the list into data.frame
  probs = do.call("cbind",probabilities)

  # let's remove columns that we aren't going to use
  probs = probs[,-seq(1,dim(probs)[2],2)]

  indexOfPredictedClasses = apply(probs, 1, function(p){
    # we store probability of the first class
    # to use it in the next probabilities calculations
    previous = p[1]

    # we store the set of probabilities
    probsSet = 1-previous

    # now we calculate the rest of the probabilities between the first one and the last one
    if(length(p)>2){
      for(i in p[2:length(p)-1]){
        probsSet=c(probsSet,previous[length(previous)] * (1-i))
        previous = c(previous,i)
      }
      #lapply(p[seq(4,length(p)-1,2)], function(pi){ probsSet=c(probsSet,probsSet[length(probsSet)] * (1-pi))})
    }

    # and the last item calculation:
    probsSet = c(probsSet,p[length(p)])

    # finally we get the class with major probability
    classOfMaxProbability = which(probsSet == max(probsSet))
  })

  classes[indexOfPredictedClasses]
}

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

# firstly we partition datasets
# <datasetName>Partitiors[[1]] will contain train partition
# <datasetName>Partitiors[[2]] will contain test partition
eslPartitions = createPartitions(esl)
eraPartitions = createPartitions(era)
levPartitions = createPartitions(lev)
swdPartitions = createPartitions(swd)

# let's create the models with the train datasets
eslModels = ordinalDatasets(eslPartitions[[1]],randomForest)
eraModels = ordinalDatasets(eraPartitions[[1]],randomForest)
levModels = ordinalDatasets(levPartitions[[1]],randomForest)
swdModels = ordinalDatasets(swdPartitions[[1]],randomForest)

# we predict using test dataset without class attribute
eslPredictedResults = ordinalPrediction(eslModels, eslPartitions[[2]][,-length(eslPartitions[[2]])], sort(unique(esl$out1)))
eraPredictedResults = ordinalPrediction(eraModels, eraPartitions[[2]][,-length(eraPartitions[[2]])], sort(unique(era$out1)))
levPredictedResults = ordinalPrediction(levModels, levPartitions[[2]][,-length(levPartitions[[2]])], sort(unique(lev$Out1)))
swdPredictedResults = ordinalPrediction(swdModels, swdPartitions[[2]][,-length(swdPartitions[[2]])], sort(unique(swd$Out1)))

# now we get the accuracy results
eslAccuracy <- sum(eslPredictedResults == eslPartitions[[2]]$class)/length(eslPredictedResults)
eraAccuracy <- sum(eraPredictedResults == eraPartitions[[2]]$class)/length(eraPredictedResults)
levAccuracy <- sum(levPredictedResults == levPartitions[[2]]$class)/length(levPredictedResults)
swdAccuracy <- sum(swdPredictedResults == swdPartitions[[2]]$class)/length(swdPredictedResults)

# let's see how this model fits the datasets
eslAccuracy
eraAccuracy
levAccuracy
swdAccuracy

# as we can see, accuracy values using ordinal classification method is not really good, so
# it may be because datasets are note made to apply this classification technique


#a function similar to pegas::MMD(), and more stable, more pretty,
#but accept x as a numeric vector. which is c(dist.dna(x))

#get dependency
if(FALSE){
  require(magrittr); require(tibble); require(dplyr);
  require(ggplot2)
}

MMD2 <- function(x, output_directory=tempfile(fileext="_MMD2")){
  #control the input of x-------------------------------------------------------
  if(!is.numeric(x)){stop("invalid x");}
  if(length(x) == 0){stop("invalid x");}
  if(anyNA(x)){stop("invalid x");}
  if(any(x < 0)){stop("invalid x");}
  #control the input of output--------------------------------------------------
  if(!is.character(output_directory)){stop("invalid output");}
  if(length(output_directory) != 1){stop("invalid output");}
  if(anyNA(output_directory)){stop("invalid output");}
  output_directory %<>% base::normalizePath(winslash="/", mustWork=FALSE)
  if(!dir.exists(output_directory)){dir.create(output_directory);}
  #plot-------------------------------------------------------------------------
  x_backup <- x
  f_ans <- function(datum, n){
    if(length(datum) != 1){stop("invalid input");}
    if(length(n) == 0){stop("invalid input");}
    #result <- (datum^i) / (datum + 1)^(i + 1)#function used in pegas::MMD()
    result <- (datum / (datum + 1))^n / (datum + 1)
    return(result)
  }
  for(i in c("smooth", "moderate", "steep")) for(j in 10:30){
    #change the scale of x
    x <- x_backup * j / diff(range(x_backup))
    #prepare data
    msu <- switch(i, smooth=2, moderate=4.5, steep=7) %>% {sqrt(var(x)) / .} %>%
      stats::density(x=x, bw=., kernel="gaussian", from=0, to=max(x) * 1.2) %>%
      {tibble(x=.$x, y=.$y, group="msu", alpha="placeholder")}
    spbu <- base::seq(from=0, to=max(x) * 1.2, length.out=2^9) %>%
      {tibble(x=., y=f_ans(datum=mean(x), n=.), group="spbu", alpha="placeholder")}
    itmo <- dplyr::bind_rows(msu, spbu)
    remove(msu, spbu)
    #plot
    result <- ggplot() +
      ggplot2::geom_histogram(mapping=aes(x=distance, y=after_stat(density)),
                              size=0, colour=NA_character_,#colour="#FFFFFF00" is also okay
                              fill=grDevices::gray(level=0.5, alpha=0.6),
                              data=tibble(distance=x), bins=j, show.legend=FALSE) +
      ggplot2::geom_line(mapping=aes(x=x, y=y, group=group, colour=group,
                                     linetype=group, alpha=alpha),
                         show.legend=c(colour=TRUE, linetype=TRUE, alpha=FALSE),
                         data=itmo, size=1) +
      ggplot2::scale_colour_manual(values=c(msu="blue", spbu="red"), name="",
                                   labels=c("observed", "expected")) +#name should be NULL
      ggplot2::scale_linetype_manual(values=c(msu="solid", spbu="dashed"), name="",
                                     labels=c("observed", "expected")) +#name should be NULL
      ggplot2::scale_alpha_manual(values=c(placeholder=0.7)) +#should contain parameter "name=NULL"
      ggplot2::theme(text=element_text(size=30),
                     legend.position=c(0.72, 0.85),
                     #legend.position="right",
                     legend.title=element_blank(),#maybe omitted when setting "name=NULL" instead of "name=\"\""
                     #legend.spacing=grid::unit(x=0, units="mm"),#inheritation error
                     legend.spacing.y=grid::unit(x=0, units="mm"),
                     legend.margin=ggplot2::margin(t=3, r=3, b=3, l=3, unit="mm"),
                     legend.key=element_rect(fill=gray(level=0.9)),
                     legend.key.height=grid::unit(x=10, units="mm"),
                     legend.key.width=grid::unit(x=30, units="mm"),
                     plot.margin=grid::unit(x=c(5, 5, 5, 5), units="mm"))
    ggsave(filename=paste0(output_directory, "/", i, ", ", j, " bins.png"),
           plot=result, device="png", width=20, height=15, units="cm", dpi=300)
    remove(itmo, result)
  }; remove(i, j);
  remove(f_ans)
  #clean environment and invisible(NULL)----------------------------------------
  remove(x, x_backup, output_directory)
  invisible(NULL)
}

#here are the test codes
if(FALSE){
  x <- runif(n=20, min=10, max=60) %>% base::rep(., times=sample(x=2:6, size=20, replace=TRUE)) %>%
    base::round(digits=2)
  MMD2(x=x)
}


#--------------------------------------------#
# Welsh infant entry to care                 #
#--------------------------------------------#

#-------------------#
# set up  ----
#-------------------#

# packages:
library(readr)
library(readxl)
library(tidyr)
library(dplyr)
library(tibble)
library(janitor)
library(snakecase)
library(purrr)
library(ggplot2)

#-------------------#
# get data files ----
#-------------------#

# download file from: https://www.ons.gov.uk/peoplepopulationandcommunity/populationandmigration/populationestimates/datasets/populationestimatesforukenglandandwalesscotlandandnorthernireland/mid2001tomid2017detailedtimeseries

setwd("YOUR FILEPATH")
pop_dat <- read.csv("mid_year_population_estimates_series_UK_2000_to_2017.csv", header = TRUE) %>%
  gather(key = variables, value = value, population_2001:population_2017) %>%  # transform data from wide to long
  filter(country == "W") %>%  # welsh pop estimates
  clean_names() %>%
  mutate(year = as.numeric(substr(variables, nchar(variables)-3, nchar(variables))) + 1) %>%
  filter(age == 0) %>% # under 1s
  group_by(year) %>%
  summarise(pop_U1 = sum(value)) %>%  # sum by year to create under 1 pop estimate for Wales for all years
  ungroup()

# download cleaned welsh cla data from github
# https://github.com/RachelPearson/Public-Data-Viz/blob/master/UK/Wales/clean_wales_CLA_31MAR_2003_2018.rds

# create counts of infants in care in Wales (as at 31st March), by year:
cla_wales_clean_U1 <- readRDS("clean_wales_CLA_31MAR_2003_2018.rds") %>%
  filter(count_type %in% c("female_U1", "male_U1") & la_code == "W92000004") %>%  # take under 1 yr old counts only
  group_by(year) %>%
  summarise(count_U1 = sum(as.numeric(count))) %>%  # count under 1s in care at 31st March, by year
  ungroup() %>%
  left_join(pop_dat, by = "year") %>%   # merge on population estimates
  mutate(rate = count_U1*10000/pop_U1)

#--------------------------------#
# sensitivity - rounding ----
#--------------------------------#
# all counts published by welsh gov on infants in care have been rounded to nearest 5
# come up with range of all possible rates of infants in care at 31 march, by year

# create all possible combinations of unrounded counts:
cla_wales_clean_U1_sim <- readRDS("clean_wales_CLA_31MAR_2003_2018.rds") %>%
  filter(count_type %in% c("female_U1", "male_U1") & la_code == "W92000004" & year %in% seq(2003,2018,3)) %>%
  group_by(year) %>%
  summarise(count_U1 = sum(as.numeric(count))) %>% # add male U1 and female U1 counts together (both have error of between -2 to +2)
  ungroup() %>%
  mutate(count_1 = count_U1 - 4,  # adding two rounded counts together - new count has error of between -4 to +4
         count_2 = count_U1 - 3,
         count_3 = count_U1 - 2,
         count_4 = count_U1 - 1,
         count_5 = count_U1,
         count_6 = count_U1 + 1,
         count_7 = count_U1 + 2,
         count_8 = count_U1 + 3,
         count_9 = count_U1 + 4) %>%
  dplyr::select(-count_U1) %>%
  gather(key = "type", value = "count", count_1:count_9) %>% # reformat data set
  spread(key = year, value = count) %>% # data set now has 6 columns (col per year) containing 9 rows of all poss values
  dplyr::select(-type) %>%
  expand.grid() %>% #   # create all possible combinations of yearly values
  mutate(id = row_number()) %>% # add id number to distinguish between diff combinations
  gather(key = "year", value = "count_U1", `2003`:`2018`, convert = TRUE) %>% # reformat data for merging on pop estimates
  left_join(pop_dat, by = "year") %>%
  mutate(rate = count_U1*10000/pop_U1)  # create rates

#--------------------------------------------------#
# plot all possible rate trajectories over time ----
#--------------------------------------------------#
# rather than plot all possible rates, get min, max and median per year (for error bars):
plot_dat <- cla_wales_clean_U1_sim %>%
  group_by(year) %>%
  summarise(rate_min = round(min(rate/10000),4),
           rate_max = round(max(rate/10000),4),
           rate_med = round(median(rate/10000),4)) %>%
  ungroup()

# plot as bar chart:
ggplot(data = plot_dat, aes(x = year)) +
  geom_col(aes(y = rate_med, fill = as.factor(year))) +   # bars (up to median rate per yr)
  geom_errorbar(aes(ymin = rate_min, ymax = rate_max), width = 0.4, colour = "black") + # error bars (min-max)
  scale_x_continuous("", breaks = seq(2003,2018,3)) +
  scale_y_continuous("", labels = scales::percent_format(accuracy = 0.1),  # format y-axis as percentage
                     breaks = seq(0,0.012,0.004), limits = c(0,0.012)) +
  scale_fill_brewer() +
  guides(fill = "none") +
  theme_classic() +
  theme(panel.background = element_rect(fill = "grey90",
                                        colour = "grey90",
                                        size = 0.5, linetype = "solid"),
        plot.caption = element_text(hjust = 0, size = 11),
        plot.title = element_text(size = 18),
        axis.text = element_text(size = 14),
        panel.grid.minor.y = element_line(colour = "white"),
        panel.grid.major.y = element_line(colour = "white")) +
  labs(title = "The proportion of infants in care in Wales (at 31st March), by year (2003 - 2018)\n",
       caption = "Data sources:\n1) http://gov.wales/statistics-and-research/children-looked-after-local-authorities/?lang=en (numerator) \n2) ONS UK mid-year population estimates (denominator) ")


#mirror_repo <- 'https://www.stats.bris.ac.uk/R/'
#packagename <- 'lattice'
#if (!require(packagename)) install.packages(packagename, repos=mirror_repo, dependencies = TRUE)

#packagename <- 'plot3D'
#if (!require(packagename)) install.packages(packagename, repos=mirror_repo, dependencies = TRUE)

#if (!require("lattice")) install.packages("lattice")
#library(lattice) ##xyplot
#library(latticeExtra)  ##overlay xyplots a + as.layer(b)
#require(rgl)

#RSS <- function(Embedded_Matrix)
#{
#.
#.
#.
#  #####  Area Under the Curve
#  auc_cumEigv <- AUC(cumEigv)
#
# #output<-list(  [1] ,      [2]  ,            [3]  ,          [4]  ,      [5],   [6],   [7],     [8] )
#  output<-list(  PC , singular_values  ,  rotateddata  ,   Eigen$values  ,  POV, cumEigv, twoPC, auc_cumEigv )
#}

#
#################################################################################
#################################################################################
#################################################################################
##-------------------- Area Under the Curve -------------------------
#AUC<-function(ce_vector){
#
#  L <- length(ce_vector)
#  dim <- L-1
#
#  x_eigenvalue_number <- (0:dim)
#  y_randomvector <- (0:dim)/dim
#
#
#  #START TRIANGLE
#  d11<-distance_twovectors(x_eigenvalue_number[1],y_randomvector[1] ,x_eigenvalue_number[2],y_randomvector[2])
#  d12<-distance_twovectors(x_eigenvalue_number[2],y_randomvector[2] ,x_eigenvalue_number[2], ce_vector[2])
#  d13<-distance_twovectors(x_eigenvalue_number[2], ce_vector[2]     ,x_eigenvalue_number[1],y_randomvector[1])
#  s1 <- (1/2 )*(d11+d12+d13)
#
#  area_star_triangle <- triangle_area(s1,d11,d12,d13)
#
#
#  #END TRIANGLE
#  d21<-distance_twovectors(x_eigenvalue_number[L],y_randomvector[L] ,x_eigenvalue_number[L-1],y_randomvector[L-1])
#  d22<-distance_twovectors(x_eigenvalue_number[L-1],y_randomvector[L-1] ,x_eigenvalue_number[L-1], ce_vector[L-1])
#  d23<-distance_twovectors(x_eigenvalue_number[L-1], ce_vector[L-1]     ,x_eigenvalue_number[L],y_randomvector[L])
#  s2 <- (1/2 )*(d21+d22+d23)
#
#  area_end_triangle <- triangle_area(s2,d21,d22,d23)
#
#
#
#  # area_of_irregular_polygon
#  areas_of_irregular_polygons  = c()
#  for (pol_i in ( 2:(L-2) )) {
#
#    #message("pol ",pol_i)
#
#    area_of_fist_irregular_polygon <- area_of_irregular_polygon(x_eigenvalue_number[pol_i+1],x_eigenvalue_number[pol_i],
#                                                                y_randomvector[pol_i+1], y_randomvector[pol_i],
#                                                                ce_vector[pol_i+1], ce_vector[pol_i])
#
#    areas_of_irregular_polygons[length(areas_of_irregular_polygons)+1] = area_of_fist_irregular_polygon
#    #message("area ",areas_of_irregular_polygons)
#  }
#
#
#  auc <- area_star_triangle + area_end_triangle + sum(areas_of_irregular_polygons)
#  auc <- round(auc, digits=2)
#
#  return(auc)
#}
#
#
#distance_twovectors <- function (x1,y1,x2,y2){
#  dist <- sqrt( (x2 - x1)^2 +  (y2 - y1)^2   )
#  #dist <- sqrt( (x_eigenvalue_number[1] - x_eigenvalue_number[2])^2 +  (y_randomvector[1] - y_randomvector[2])^2   )
#  return(dist)
#}
#
#
#triangle_area <- function(s,a,b,c){
#  area <- sqrt(  s*(s-a)*(s-b)*(s-c) )
#  return(area)
#}
#
#
#
#################################################################################
#################################################################################
#################################################################################
#area_of_irregular_polygon <-function(xB,xA,yB,yA,pcB,pcA){
#
#    ## area of triangule one
#    bt1 <- xB - xA
#    ht1 <- pcB - pcA
#    at1 <- (1/2) * bt1 * ht1
#
#
#    bt2 <- xB - xA
#    ht2 <- yB - yA
#    at2 <- (1/2) * bt2 * ht2
#
#    # area of rectangle
#    s1 <- pcB - yA
#    s2 <- xB - xA
#    ar <- s1*s2
#
#      area <- ar - (at1+at2)
#
##
##   #FIRST polygon
##   ## area of triangule one
##
##   bt1 <- x_eigenvalue_number[3] - x_eigenvalue_number[2]
##   ht1 <- ce_vector[3] - ce_vector[2]
##   at1 <- (1/2) * bt1 * ht1
##
##   ## area of triangel two
##
##   bt2 <- x_eigenvalue_number[3] - x_eigenvalue_number[2]
##   ht2 <- y_randomvector[3] - y_randomvector[2]
##   at2 <- (1/2) * bt2 * ht2
##
##   # area of rectangle
##
##   s1 <- ce_vector[3] - y_randomvector[2]
##   s2 <- x_eigenvalue_number[3] - x_eigenvalue_number[2]
##   ar <- s1*s2
##
##   area_of_fist_irregular_polygon <- ar - (at1+at2)
##  0.2687141
#  return(area)
#}
## Usage
## area_of_fist_irregular_polygon <- area_of_irregular_polygon(x_eigenvalue_number[3],x_eigenvalue_number[2],
##                                                             y_randomvector[3], y_randomvector[2],
##                                                             ce_vector[3], ce_vector[2])
##
## message("area ",area_of_fist_irregular_polygon)
##
#

#
#################################################################################
#################################################################################
#################################################################################
##-------------------- Percentage of Cumulative Energy -------------------------
#plot_CE<-function(e_cum , i_cum,n_cum,dim){
#
#  ploting <-
#    xyplot(e_cum + i_cum + n_cum +c (0:dim)/dim ~  c(0:dim),
#           col.line = c("red","blue","green3","black"), type = c("b"), lwd=4, lty=c(2,3,4,1),
#           pch=1:4,cex=3, # control the characther expansion for characters
#           main=list(label="", cex=2.5),
#           xlab=list(label="Eigenvalue number",font=2, cex=1.5),
#           ylab=list(label="Cumulative Energy %",font=2, cex=1.5),
#           grid = TRUE,
#           scales=list(font=1, cex=1.5,
#                       y=list(at=seq(0,1,.5)),x=list(at=seq(0,dim,1))  ),
#
#           key=list(
#             text = list(c(expression("x"),
#                           expression("y"),
#                           expression("z")
#             ), cex=2 ),
#             corner=c(0.95,0.05), # position
#             lines = list(pch=c(1:3), col= c('red','blue','green3') ),
#             type="b", lwd=6,lty=c(2,3,4),
#             cex=3 # control the character expansion  of the symbols
#           )
#    )
#
#
#
#  print(ploting)
#
#}
#
#
#################################################################################
#################################################################################
#################################################################################
#plot_CE_xyz<-function(x_cum,x_area,y_cum,y_area,z_cum,z_area,dim,tau){
#
#  ploting <-
#    xyplot(x_cum + y_cum + z_cum +c (0:dim)/dim ~  c(0:dim),
#           col.line = c("red","blue","green3","black"), type = c("b"), lwd=4, lty=c(2,3,4,1),
#           pch=1:4,cex=3, # control the characther expansion for characters
#           main=list(label= paste0("m=", dim, " T=", tau),font=1, cex=1),
#           xlab=list(label="Eigenvalue number",font=2, cex=1.5),
#           ylab=list(label="Cumulative Energy %",font=2, cex=1.5),
#           grid = TRUE,
#           scales=list(font=1, cex=1.5,
#                       y=list(at=seq(0,1,.5)),x=list(at=seq(0,dim,1))  ),
#
#           key=list(
#             text = list(c( paste0("x auc:", x_area),
#                            paste0("y auc:", y_area),
#                            paste0("z auc:", z_area)
#             ), cex=2 ),
#             corner=c(0.95,0.05), # position
#             lines = list(pch=c(1:3), col= c('red','blue','green3') ),
#             type="b", lwd=6,lty=c(2,3,4),
#             cex=3 # control the character expansion  of the symbols
#           )
#    )
#
#
#
#  print(ploting)
#
#}
#
#
#################################################################################
#################################################################################
#################################################################################
#plot_CE_testing<-function(cumEigv,area,dim,tau){
#
#  ploting <-
#    xyplot(cumEigv +c (0:dim)/dim ~  c(0:dim),
#           col.line = c("red","black"), type = c("b"), lwd=4, lty=c(4,1),
#           pch=c(4,1),cex=3, # control the characther expansion for characters
#           main=list(label= paste0("m=", dim, " T=", tau),font=1, cex=1),
#           xlab=list(label="Eigenvalue number",font=2, cex=1.5),
#           ylab=list(label="Cumulative Energy %",font=2, cex=1.5),
#           grid = TRUE,
#           scales=list(font=1, cex=1.5,
#                       y=list(at=seq(0,1,.5)),x=list(at=seq(0,dim,1))  ),
#
#           key=list(
#             text = list(c(expression("CEC"),
#                           expression("")
#             ), cex=2 ),
#             corner=c(0.95,0.05), # position
#             lines = list(pch=c(4,1), col= c('red','black') ),
#             type="b", lwd=6,lty=c(4,1),
#             cex=3 # control the character expansion  of the symbols
#           ),
#           panel = function(...) {
#             panel.text(dim/3, 1/2, paste0("AUC: ", area), cex=2, srt = 45)
#             panel.xyplot(...)
#           }
#    )
#
#  print(ploting)
#
#}
## Usage of plot_CE_testing(cumEigv,area,dim,tau)
## plot_CE_testing(RSS[[6]],RSS[[8]],dim_i,tau_j)
#
#
#
#################################################################################
#################################################################################
#################################################################################
##-------------------- Plot Percentage of Variances --------------------------
#Plot_PV_testing  <- function(PCAMatrix,dim,tau){
#
#  maxdim <- length(PCAMatrix)
#
#
#  df.eig <- data.frame(dim = factor(1:maxdim), eig=PCAMatrix, pov=paste0(  round(PCAMatrix,0), ""))  ## 22 %
#  #df.eig <- data.frame(dim = factor(1:maxdim), eig=PCAMatrix, pov=paste0(  round(PCAMatrix,1), "%")) ## 22.1 %
#
#
#
#
#  plotPV <-
#    ggplot(data=df.eig, aes(dim, eig, group=1)) +
#    geom_bar(stat="identity", fill="steelblue") +
#    geom_text( aes(label= pov), vjust=-0.5, hjust=0.5, color="black", size=10 ) + #text over bars
#    geom_line() +
#    geom_point(colour = "black", size = 3) +
#    labs(title = paste0("m=", dim, ", T=",tau), x = "Dimension", y = "Percentage of variances", size=12) +
#    theme(axis.text=element_text(color="black",size=15),
#           axis.title = element_text(family = "Trebuchet MS", color="#666666", face="bold", size=25),
#           panel.background = element_rect(fill = "white",
#                                           colour = "white",
#                                           size = 0.5, linetype = "solid"),
#           panel.grid.major = element_line(size = 0.5, linetype = 'solid',
#                                           colour = "gray"),
#           panel.grid.minor = element_line(size = 0.25, linetype = 'solid',
#                                           colour = "gray")) +
#  coord_cartesian(xlim=c(-0.1,maxdim+1),ylim=c(0,100))
#
#
#  print(plotPV)
#}
## Usage of Plot_PV_testing(PCAMatrix,dim,tau)
## Plot_PV_testing(pcamatrix[[5]],dim_i,tau_j)
#
#

#
#################################################################################
#################################################################################
#################################################################################
##-------------------- Plot State Space  --------------------------
#Plot_2D_Embedded_State_Space <- function(X1,X2, dim, tau, colour, maxplotlenght){
#
#  N <- length(X1)
#
#
#  phasespaceplot <- xyplot(X1 ~ X2,
#                           type = c("o"),
#                           col.line = c(colour),
#                           lwd=2,
#                           xlab=list(label="x(t)", cex=1.5, fontfamily="Times"),
#                           ylab=list(label="x(t-T)", cex=1.5, fontfamily="Times"),
#                           scales = list(font=1, cex=1
#                                         ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                         ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                           ),
#                           key=list(
#
#                             text = list( paste( "[",N,"x",dim,"]","   m=",dim," T=",tau,sep="")   ),
#                             cex=2, # control the character expansion  of the symbols
#                             corner=c(0,0.95) # position
#                           ),
#
#
#                           panel = function(...) {
#                             panel.abline(h = 0, v = 0, lwd=0.5, lty = 1)
#                             panel.xyplot(...)
#                           }
#
#  )
#
#  print(phasespaceplot)
#
#
#}
#

#################################################################################
#################################################################################
#################################################################################
## Plot_3D_Embedded_State_Space
#Plot_3D_Embedded_State_Space  <- function(X1,X2,X3,dim,tau,colour){
#
#  rgl.open()
#  rgl.clear()
#  bg3d("white") # background color
#  light3d()
#  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,],color=c(colour), alpha=0.9, lwd =1)
#  #rgl.viewpoint( theta = 0, phi = 15, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
#  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[3,],PCAMatrix[5,],color=c(colour), alpha=0.9, lwd =2)
#
#
#  rgl.spheres(X1,X2,X3, r = 0.05, color =c(colour))
#
#  #rgl.linestrips(X1,X2,X3,color=c(colour), alpha=0.9, lwd =1)
#  rgl.viewpoint( theta = 270, phi = 1, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
#
#
#  #axis labels
#  rgl.material(
#    color = c("black")
#  )
#
#  axes3d()
#  #   #axis3d('x',pos=c(NA, 0, 0))
#
#
#
#  title3d(paste("embed, m=",dim," T=",tau,sep=""),'','x(t)','x(t-T)','x(t-2T)')
#
#  rgl.bringtotop()
#  #  rgl.snapshot("hola.jpg")
#
#}
##
#

#################################################################################
#################################################################################
#################################################################################
## Plot _2D_State Space
#Plot_2D_State_Space <- function(PCAMatrix, colour, maxplotlenght){
#
#
#  phasespaceplot <- xyplot(PCAMatrix[1,] ~ PCAMatrix[2,],
#                     type = c("l"),
#                     col.line = c(colour),
#                     lwd=2,
#                     xlab=list(label="PC2", cex=1.5, fontfamily="Times"),
#                     ylab=list(label="PC1", cex=1.5, fontfamily="Times"),
#                     scales = list(font=1, cex=1
#                                   ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                   ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                     ),
#                     panel = function(...) {
#                       panel.abline(h = 0, v = 0, lwd=0.5, lty = 1)
#                       panel.xyplot(...)
#                     }
#
#                     )
#
#  print(phasespaceplot)
#
#
#}
#

#################################################################################
#################################################################################
#################################################################################
## Plot _2D_State Space
#Plot_2D_State_Space_testing <- function(PCAMatrix, colour, maxplotlenght){
#
#  N <- length(PCAMatrix[[1]][1,])
#
#
#  phasespaceplot <- xyplot(PCAMatrix[[1]][1,] ~ PCAMatrix[[1]][2,],
#                           type = c("o"),
#                           cex=1.4,
#                           col.line = c(colour),
#                           lwd=4,
#                           xlab=list(label="", cex=1, fontfamily="Times"), #PC2
#                           ylab=list(label="", cex=1, fontfamily="Times"), #PC1
#                           scales = list(font=1, cex=.7
#                                         ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                         ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                           ),
#
##                           key=list(
##                             text = list( paste( "[",N,"x",dim,"]","   m=",dim," T=",tau,sep="")   ),
##                             cex=2, # control the character expansion  of the symbols
##                             corner=c(0,0.95) # position
##                           ),
#
#                           panel = function(...) {
#                             panel.abline(h = 0, v = 0, lwd=0.5, lty = 1)
#                             panel.xyplot(...)
#                           }
#
#  )
#
#  print(phasespaceplot)
#
#}
##
##   #output<-  list(  [1] ,      [2]  ,            [3]  ,          [4]  ,      [5],   [6],   [7],     [8] )
## PCA output   list(  P , singular_values  ,  rotateddata  ,   Eigen$values  ,  POV, cumEigv, twoPC, auc_cumEigv )
##
## Usage of Plot_2D_State_Space_testing(PCAMatrix,colour, maxplotlenght). Examples
## Plot_2D_State_Space_testing(RSS,'red', 5)
## Plot_2D_State_Space_testing(tempepca, "red",0.3)
#

#################################################################################
#################################################################################
#################################################################################
#Plot_2D_State_Space_testing_two <- function(PCAMatrix,dim,tau, colour, maxplotlenght){
#
#  N <- length(PCAMatrix[[1]][1,])
#
#
#  phasespaceplot <- xyplot(PCAMatrix[[1]][1,] ~ PCAMatrix[[1]][2,],
#                           type = c("o"),
#                           cex=1.4,
#                           col.line = c(colour),
#                           lwd=4,
#                           xlab=list(label="", cex=1, fontfamily="Times"), #PC2
#                           ylab=list(label="", cex=1, fontfamily="Times"), #PC1
#                           scales = list(font=1, cex=.7
#                                         ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                         ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                           ),
#
#                          key=list(
#                            text = list( paste( "[",N,"x",dim,"]","   m=",dim," T=",tau,sep="")   ),
#                            cex=2, # control the character expansion  of the symbols
#                            corner=c(0,0.95) # position
#                          ),
#
#                           panel = function(...) {
#                             panel.abline(h = 0, v = 0, lwd=0.5, lty = 1)
#                             panel.xyplot(...)
#                           }
#
#  )
#
#  print(phasespaceplot)
#
#
#}
## Usage of Plot_2D_State_Space_testing_two (PCAMatrix,dim,tau, colour, maxplotlenght). Examples
## Plot_2D_State_Space_testing_two(RSS,dim_i,tau_j, 'red', 5)
#
#

#################################################################################
#################################################################################
#################################################################################
## Plot_2D_State Space XYZ
#Plot_2D_State_Space_XYZ <- function(PCAMatrix_X,PCAMatrix_Y,PCAMatrix_Z, maxplotlenght, Sensor){
#
#
#  #phasespaceplot <- xyplot(PCAMatrix_X[1,] ~ PCAMatrix_X[2,]+PCAMatrix_Y[1,] ~ PCAMatrix_Y[2,],
#  phasespaceplot_x <- xyplot(PCAMatrix_X[1,] ~ PCAMatrix_X[2,],
#                           type = c("l"),
#                           col.line = "red",
#                           lwd=2,
#                           xlab=list(label="PC2", cex=1.5, fontfamily="Times"),
#                           ylab=list(label="PC1", cex=1.5, fontfamily="Times"),
#                           scales = list(font=1, cex=1
#                                         ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                         ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                           ),
#                           key=list(
#                             #border= "grey",
#                             text = list(c(   paste(Sensor,"x",sep="") , paste(Sensor,"y",sep=""),  paste(Sensor,"z",sep="") )),
#                             #text = list(c(   paste(Sensor,"[x]",sep="") , expression(  A[y]    ), expression(  A[z]  ))),
#                             lines = list(pch=c(1,2,3), col= c('red','blue','yellow3')),
#                             type="l", lwd=2,
#                             cex=1, # control the character expansion  of the symbols
#                             corner=c(1,0) # position
#                           )
#                           ,
#                           panel = function(...) {
#                             panel.abline(h = 0, v = 0, lwd=0.5, lty = 1)
#                             panel.xyplot(...)
#                           }
#  )
#
#
#
#
#  phasespaceplot_y <- xyplot(PCAMatrix_Y[1,] ~ PCAMatrix_Y[2,],
#                             type = c("l"),
#                             col.line = "blue",
#                             lwd=2,
#                             xlab=list(label="PC2", cex=1.5, fontfamily="Times"),
#                             ylab=list(label="PC1", cex=1.5, fontfamily="Times"),
#                             scales = list(font=1, cex=1
#                                           ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                           ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                             )
#  )
#
#
#  phasespaceplot_z <- xyplot(PCAMatrix_Z[1,] ~ PCAMatrix_Z[2,],
#                             type = c("l"),
#                             col.line = "yellow3",
#                             lwd=2,
#                             xlab=list(label="PC2", cex=1.5, fontfamily="Times"),
#                             ylab=list(label="PC1", cex=1.5, fontfamily="Times"),
#                             scales = list(font=1, cex=1
#                                           ,x=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                                           ,y=list(at=seq(-maxplotlenght,maxplotlenght,maxplotlenght/2),limits=c(-maxplotlenght-(0.1*maxplotlenght),maxplotlenght+(0.1*maxplotlenght)))
#                             )
#)
#
#
#  print(
#  phasespaceplot_x + as.layer(phasespaceplot_y) + as.layer(phasespaceplot_z)
#  )
#}
## Usage of Plot_2D_State_Space_XYZ(PCAMatrix_X,PCAMatrix_Y,PCAMatrix_Z, maxplotlenght, Sensor)
#
#

#################################################################################
#################################################################################
#################################################################################
##  Plot_State Space function
##
#Plot_3D_State_Space  <- function(PCAMatrix,dim,tau,colour,imu,axis){
#
#  rgl.open()
#  rgl.clear()
#  bg3d("white") # background color
#  light3d()
#  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,],color=c(colour), alpha=0.9, lwd =1)
#  #rgl.viewpoint( theta = 0, phi = 15, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
#  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[3,],PCAMatrix[5,],color=c(colour), alpha=0.9, lwd =2)
#
#
#  rgl.linestrips(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,],color=c(colour), alpha=0.9, lwd =1)
#  rgl.viewpoint( theta = 270, phi = 1, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
#
#
#  #axis labels
#  rgl.material(
#    color = c("black")
#  )
#
#  axes3d()
#  #   #axis3d('x',pos=c(NA, 0, 0))
#
#
#
#  title3d(paste(imu,"_",axis," m=",dim,"t=",tau,sep=""),'','PC1','PC2','PC3')
#
#  rgl.bringtotop()
#  #  rgl.snapshot("hola.jpg")
#
#}
##      Plot_State_Space(pcamatrix[[3]],dim_i,tau_j, colour,imu,axis)
#
#
#

#
##################################################################################
##################################################################################
##################################################################################
##Plot_3D_State_Space_testing  <- function(PCAMatrix,dim,tau,colour){
##
##  rgl.open()
##  rgl.clear()
##  bg3d("white") # background color
##  light3d()
##  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,],color=c(colour), alpha=0.9, lwd =1)
##  #rgl.viewpoint( theta = 0, phi = 15, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
##  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[3,],PCAMatrix[5,],color=c(colour), alpha=0.9, lwd =2)
##
##
##  #rgl.linestrips(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,],color=c(colour), alpha=0.9, lwd =1)
##
##  rgl.spheres(PCAMatrix[1,],PCAMatrix[2,],PCAMatrix[3,], r = 0.05, color =c(colour))
##  rgl.viewpoint( theta = 270, phi = 1, fov = 60, zoom = .8, scale = par3d("scale"), interactive = TRUE)
##
##
##  #axis labels
##  rgl.material(
##    color = c("black")
##  )
##
##  axes3d()
##  #   #axis3d('x',pos=c(NA, 0, 0))
##
##
##
##  title3d(paste(" pca, m=",dim,"t=",tau,sep=""),'','PC1','PC2','PC3')
##
##  rgl.bringtotop()
##  #  rgl.snapshot("hola.jpg")
##
##}
###
###   #output<-  list(  [1] ,      [2]  ,            [3]  ,          [4]  ,      [5],   [6],   [7],     [8] )
### PCA output   list(  P , singular_values  ,  rotateddata  ,   Eigen$values  ,  POV, cumEigv, twoPC, auc_cumEigv )
###
### Usage of Plot_3D_State_Space_testing(PCAMatrix,dim,tau,colour). Examples:
###
### Plot_State_Space(pcamatrix[[3]],dim_i,tau_j, colour,imu,axis)
### Plot_3D_State_Space_testing(RSS[[3]],dim_i,tau_j,'red')
##
##
#
#

#################################################################################
#################################################################################
#################################################################################
#
#library(plot3D)
#plotRSS2D <-function (PCAMatrix,maxlimit)
#{
#
#
#  #   #output<-  list(  [1] , ...
#  # PCA output   list(  P , ...
#
#### Principal Components
#N <- length(PCAMatrix[[1]][1,])
#col.v <- 1:N
#x <- PCAMatrix[[1]][1,]
#y <- PCAMatrix[[1]][2,]
#
#
#scatter2D(
#     x, y, colvar = col.v, bty = "n", pch = ".",
#     type='l', lwd=5,
#     cex = 5,
#     main = "",
#     xlab = 'PC1', ylab ='PC2',
#     colkey = list(side = 4, plot = TRUE, length = 1, width = 0.5),
#     xlim = c(-maxlimit,maxlimit), ylim=c(-maxlimit,maxlimit)
#     )
#
#}
##
##
## Usage of plotRSS3D2D(PCAMatrix). Example
## plotRSS2D(RSS, 0.3)
#
#
#

#
#
#
#
#
#
#
#
#
#################################################################################
#################################################################################
#################################################################################
#
#library(plot3D)
#plotRSS3D2D <-function (PCAMatrix)
#{
#
#par(mfrow = c(1, 4), mar = c(5, 3, 5, 3))
#
#### Principal Components
#N <- length(PCAMatrix[[1]][1,])
#col.v <- 1:N
#x <- PCAMatrix[[1]][1,]
#y <- PCAMatrix[[1]][2,]
#z <- PCAMatrix[[1]][3,]
#
#### rotateddata
## N <- length(PCAMatrix[[3]][1,])
## col.v <- 1:N
## x <- PCAMatrix[[3]][1,]
## y <- PCAMatrix[[3]][2,]
## z <- PCAMatrix[[3]][3,]
#
#
#scatter3D(
#  	x, y, z, colvar = col.v,
#	bty = "b2",
#	type = "l",
#	lwd=5,
# 	axis.scales = TRUE,
## 	# xlim=c(-1,1),ylim= c(-1,1),zlim=c(-10,30),
#   main = "XYZ",
#   xlab = 'PC1', ylab ='PC2', zlab = 'PC3'
#  #  colkey = list(length = 0.3, width = 0.8, cex.clab = 0.75)
#   )
#
#scatter2D(
#     x, y, colvar = col.v, bty = "n", pch = ".",
#     type='l', lwd=5,
#     cex = 5, colkey = TRUE,
#     main = "PC1~PC2",
#     xlab = 'PC1', ylab ='PC2'
#     )
#
#scatter2D(
# y, z, colvar = col.v, bty = "n", pch = ".",
# type='l', lwd=5,
# cex = 5, colkey = TRUE,
# main = "PC2~PC3",
# xlab = 'PC2', ylab ='PC3'
# )
#
#scatter2D(
# x, z, colvar = col.v, bty = "n", pch = ".",
# type='l', lwd=5,
# cex = 5, colkey = TRUE,
# main = "PC1~PC3",
# xlab = 'PC1', ylab ='PC3'
# )
#
#
#
#}
##
##   #output<-  list(  [1] ,      [2]  ,            [3]  ,          [4]  ,      [5],   [6],   [7],     [8] )
## PCA output   list(  P , singular_values  ,  rotateddata  ,   Eigen$values  ,  POV, cumEigv, twoPC, auc_cumEigv )
##
## Usage of plotRSS3D2D(PCAMatrix). Example
## plotRSS3D2D(RSS)
#
#

#

##--------------------  split_path function  --------------------------
## Usage of split_path
## >  paths[3]
## [1] "./gestures/continuous"
## > split_path(paths[3])
## [1] "."          "gestures"   "continuous"
##
##http://stackoverflow.com/questions/29214932/split-a-file-path-into-folder-names-vector
#split_path <- function(path) {
#   (setdiff(strsplit(path,"/|\\\\")[[1]], ""))
#}

#
#
#
#
#################################################################################
#################################################################################
#################################################################################
#euclidean.distances <- function(PCAMatrix){
#
#  N <- length(PCAMatrix[[1]][1,])
#
#
#  euc.dist <- function(x2, y2){
#      sqrt(  sum (  (x2)^2 + (y2)^2   ))
#    }
#
#  distances <- c()
#    for (i in 1:N)
#    {
#      distances <- c(distances, euc.dist( PCAMatrix[[1]][1,i], PCAMatrix[[1]][2,i] ))
#    }
#
#    return <- distances
#
#}
#
#
#
#################################################################################
#################################################################################
#################################################################################
#euclidean.distances_rotateddata <- function(PCAMatrix){
#
#
#  #   #output<-  list(  [1] ,      [2]  ,            [3]  ,    ...
#  # PCA output   list(  P , singular_values  ,  rotateddata  , ...
#
#
#  N <- length(PCAMatrix[[3]][1,])
#
#
#  euc.dist <- function(x2, y2){
#      sqrt(  sum (  (x2)^2 + (y2)^2   ))
#    }
#
#  distances <- c()
#    for (i in 1:N)
#    {
#      distances <- c(distances, euc.dist( PCAMatrix[[3]][1,i], PCAMatrix[[3]][2,i] ))
#    }
#
#    return <- distances
#}
## Usage
## euclidean.distances_rotateddata(RSS)
#
#
#
#


# Syntax Highlighting test file for R
# Comments look like this

options(digits=7)

## powers
outer(a <- -4:12,     -2:7, "^")

for (n1 in 1:7)
    print(zapsmall(polyroot(1:n1), digits = 10))

## lowess() {incl. sort, etc}:
options(digits = 5)

lowess(c(3,2,6,3,8,4))$y # this used to differ on Linux

y1 <- c(3,1:2,5:2,4,1:3,3)
lowess(y1)$y
lowess(y1, f = .4)$y

lowess(c(y1,100), f = .4)$y

## this is the test sample from Cleveland's original lowess.doc:
x <- c(1:5, rep(6,10),8,10,12,14,50)
y <- c(18,2,15,6,10,4,16,11,7,3,14,17,20,12,9,13,1,8,5,19)
lowess(x,y, f = .25, iter = 0, delta = 0)$y
lowess(x,y, f = .25, iter = 0, delta = 3)$y
lowess(x,y, f = .25, iter = 2, delta = 0)$y


library(arrow)
library(data.table)
setDTthreads(12)

main <- function () {
    start_time <- Sys.time()
    files <- Sys.glob('/data/performance-benchmark-data/*.parquet')
    dataframes <- lapply(files, function(x) { read_parquet(x) })
    dataframe <- do.call(rbind, dataframes)
    setDT(dataframe)
    dataframe[, sales := quantity * price]
    result = dataframe[,
                    .(total_spend = sum(sales),
                      avg_basket_size = mean(sales),
                      avg_price = mean(price),
                      n_transactions = .N,
                      n_visits = uniqueN(date),
                      n_brands = uniqueN(`brand-id`),
                      n_styles = uniqueN(`style-id`)),
                    by = `member-id`]
    write_parquet(result, "datatable.parquet")
    end_time <- Sys.time()
    print(end_time - start_time)
}

main()

df <- read_parquet("datatable.parquet")
dim(df)
head(df)
colnames(df)

# 1 Part
# Time difference of 27.56955 secs

# 12 Parts
# Time difference of 2.378997 mins


# 4. faza: Analiza podatkov

## Uvozimo funkcijo za uvoz spletne strani.
#source("lib/xml.r")

# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()

#1.) Normiran zemljevid Števila športnikov iz posameznih držav na OI 2012

#najprej izračunamo vektor ki vsebuje podatek o športnikih/število prebivalcev
nn<-sportniki*1000000 #število športnikov pomnoženo z 10^6, da vsa števila v legendi niso enaka 0
pop<-svet$pop_est #populacija, podatki iz zemljevida svet

#uredimo
l <- match(svet$name_long, rownames(nn))
norm.sp.svet <- nn[l,]

podatki.za.norm.zemlj<-norm.sp.svet/pop #podatki ki jih bomo uporabili za zemljevid

# Izračunamo max, min, povprečje
#druzine$povprecje <- apply(druzine[1:4], 1, function(x) sum(x*(1:4))/sum(x))
min.norm <- min(podatki.za.norm.zemlj, na.rm=TRUE)
max.norm <- max(podatki.za.norm.zemlj, na.rm=TRUE)
povp.norm<-sum(podatki.za.norm.zemlj,na.rm=TRUE)/length(podatki.za.norm.zemlj)
norm.norm <- (podatki.za.norm.zemlj-min.norm)/(max.norm-min.norm)

# Narišimo zemljevid v PDF.
cat("Rišem normiran zemljevid za OI...\n")
pdf("slike/normiranzemljevid.pdf")

n = 100
barve.norm=rgb(0, 0, 1, (1:n)/n)[unlist(1+(n-1)*norm.norm)]

plot(svet, col = barve.norm)

#naslov
title("Št. športnikov na milijon prebivalcev iz posameznih držav na OI 2012")
#legenda
legend("left", legend = round(seq(min.norm, max.norm, (max.norm-min.norm)/5)),
       fill = rgb(0, 0, 1, (1:6)/6), bg = "white")

#Dodamo imena drzav
#najprej poberemo iz zemljevida svet tiste države ki bi jih radi označili
oznacene<-svet[c(9,23,28,31,136,169),]
#dodamo imena na zemljevid
text(coordinates(oznacene),labels=c("Avstralija","Brazilija","Kanada","Kitajska","Rusija","ZDA"),cex=0.55,col="black")

dev.off()

#2.) Krivulje, ki se najbolj prilegajo številu dogodkov na poletnih in zimskih OI
attach(OI)
pdf("slike/naprednigrafi.pdf",paper="a4r")

#2.1.)modeli: krivulje za št dogodkov poletnih OI

letop<-OI$Leto[Vrsta=="poletne"] #leta poletnih OI
dogp<-OI$Stevilo.dogodkov[Vrsta=="poletne"] #st dogodkov poletnih OI

   #graf
plot(letop,dogp, xlim=c(1896,2050),ylim=c(0,500),
     xlab="Leto",ylab="Število dogodkov",
     main="Napoved za število dogodkov na poletnih OI",pch=20,col="red",type="p",lwd=3.5)

   #premica
linp<-lm(dogp~letop)
abline(linp,col="green")
   #parabola
kvp<-lm(dogp~I(letop^2)+letop)
curve(predict(kvp, data.frame(letop=x)), add = TRUE, col = "purple")
   #loess
loep<-loess(dogp~letop)
curve(predict(loep, data.frame(letop=x)),add=TRUE,col="orange")
   #legenda
legend("topleft", c("Linerana metoda", "Kvadratna metoda","Loess"),lty=c(1,1,1), col = c("green","purple","orange"))
   #Ocenimo prileganje krivulj tako, da izračunamo vsote kvadratov razdalj od napovedanih do dejanskih vrednosti
ostp<-sapply(list(linp, kvp, loep), function(x) sum(x$residuals^2))

#2.2.)modeli: krivulje za št dogodkov zimskih OI

letoz<-OI$Leto[Vrsta=="zimske"] #leta zimskih OI
dogz<-OI$Stevilo.dogodkov[Vrsta=="zimske"] #st dogodkov zimskih OI

   #graf
plot(letoz,dogz,xlim=c(1924,2050),ylim=c(0,200),
     xlab="Leto",ylab="Število dogodkov",
     main="Napoved za število dogodkov na zimskih OI",pch=20,col="blue",type="p",lwd=3.5)

   #premica
linz<-lm(dogz~letoz)
abline(linz,col="green")
   #parabola
kvz<-lm(dogz~I(letoz^2)+letoz)
curve(predict(kvz, data.frame(letoz=x)), add = TRUE, col = "purple")
   #loess
loez<-loess(dogz~letoz)
curve(predict(loez, data.frame(letoz=x)),add=TRUE,col="orange")
   #legenda
legend("topleft", c("Linerana metoda", "Kvadratna metoda","Loess"),lty=c(1,1,1), col = c("green","purple","orange"))
   #Ocenimo prileganje krivulj tako, da izračunamo vsote kvadratov razdalj od napovedanih do dejanskih vrednosti
ostz<-sapply(list(linz, kvz, loez), function(x) sum(x$residuals^2))

detach(OI)
dev.off()

#3.) Razvrstimo države v skupine glede na število športnikov

pdf("slike/skupine.pdf",paper="a4r")

#tabela, ki za države na zemljevidu pove, koliko šprtnikov na milijon prebivalcev so poslale na OI 2012
za10<-data.frame(row.names=svet$name_long,podatki.za.norm.zemlj)
#znebimo se NA vrstic
za10<-za10[-c(7,8,24,39,55,66,89,114,138,141,146,164),]
drz<-svet$name_long[-c(7,8,24,39,55,66,89,114,138,141,146,164)]
#končna tabela, ki jo bom uporabila za razvrščanje v skupine
tab.za.skupine<-data.frame(row.names=drz,za10)

#normaliziramo
X <- scale(as.matrix(tab.za.skupine))
t <- hclust(dist(X),method = "ward")
#narišemo graf
plot(t, hang=-1, cex=0.2, lwd=0.1,main = "Skupine držav")
legend("topleft", c("Skupina 1", "Skupina 2","Skupina 3","Skupina 4","Skupina 5","Skupina 6"),lty=c(1,1,1), col = c("red","yellow","orange","blue","magenta","green"))
text(20,30,"Skupina 1 predstavlja")
text(20,27.7,"državo z najmanj,")
text(20,25.4,"skupina 6 državo z")
text(20,23.1,"največ športniki")
text(20,20.8,"na milijon prebivalcev.")
#določimo skupine
rect.hclust(t,k=6,border=c("red","yellow","magenta","green","orange","blue"))

cutree(t, k=6)

dev.off()


#dod方法下的射出频率与参数之间的关系
#########说明########
#乙二醇液体
#voltage_pluse，说明高峰电压和基准电压下的射出时间ms
#duty_pluse，随着fv电压频率上升，占空比不同时的射出时间
#height，不同占空比下，随fv上升，弯月面高度的变化
#angle，同上，弯月面锥角的变化
#flowrate_pulse，不同占空比下，随流量变化的射出时间
#flowrate_height，此时的弯月面高度
#flowrate_angle，弯月面角度的变化
#setduty_pulse, 固定占空比为50%时，不同电压频率下，不同流量下的射出时间
#setduty_height，同上，弯月面高度
#setduty_angle，同上，弯月面锥角

#####第一组：随电压频率上升，不同占空比下的射出时间和弯月面信息#####
#####第二组：固定电压频率下，不同流量，不同占空比下的射出时间和弯月面信息####
#####第三组：固定占空比下，不同流量，不同电压频率的射出时间和弯月面信息####

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据
vp<-read.xlsx("dod_v_pulse.xls", sheetName= "voltage_pulse", header=TRUE)
dp<-read.xlsx("dod_v_pulse.xls", sheetName= "duty_pulse", header = TRUE)
hei<-read.xlsx("dod_v_pulse.xls", sheetName = "height", header = TRUE)
ang<-read.xlsx("dod_v_pulse.xls", sheetName = "angle", header = TRUE)

#规划区域
par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(2,1,1,1))

#保存pdf
#pdf("dod_fv.pdf")

################################画图-高峰电压与基准电压曲线###########################
plot(vp$voltage, vp$X1.6, col=0, xaxs="i", xlim=c(1.8, 2.5), ylim=c(0.3, 1.2),
xlab="Hight voltage (HV)", cex.lab=1, ylab="Pulse time (ms)", main="Pulse time in voltage groups")

lines(lowess(vp$voltage, vp$X1.6), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(vp$voltage, vp$X1.65), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(vp$voltage, vp$X1.7), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

legend("topright", c("1.6kv", "1.65kv", "1.7kv"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000"), pch=c(21,22,23), lwd=1.5, lty=2, cex=1.2, bty="n")

################################画图-占空比改变配合fv改变的pulse时间###########################
plot(dp$fv, dp$X0.1, col=0, xaxs="i", xlim=c(0, 105), ylim=c(0.05, 0.6),
xlab="Voltage frequency (Hz)", cex.lab=1, ylab="Pulse time (ms)", main="Pulse time in various fv & k")

lines(lowess(dp$fv, dp$X0.1), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(dp$fv, dp$X0.2), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(dp$fv, dp$X0.3), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(dp$fv, dp$X0.5), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

lines(lowess(dp$fv, dp$X0.8), col="#27408B", pch=25, lwd=2.5, type="b", lty=2)

legend("bottomleft", c("k=0.1", "k=0.2", "k=0.3", "k=0.5", "k=0.8"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=1.5, lty=2, cex=1.2, bty="n")

#################################画图--弯月面高度#############################
plot(hei$fv, hei$X0.1, col=0, xaxs="i", xlim=c(0, 105), ylim=c(0.2, 0.4),
xlab="Voltage frequency (Hz)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Meniscus height in various fv & k")

lines(lowess(hei$fv, hei$X0.1), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(hei$fv, hei$X0.2), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(hei$fv, hei$X0.3), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(hei$fv, hei$X0.5), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

lines(lowess(hei$fv, hei$X0.8), col="#27408B", pch=25, lwd=2.5, type="b", lty=2)

legend("bottomright", c("k=0.1", "k=0.2", "k=0.3", "k=0.5", "k=0.8"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=1.5, lty=2, cex=1.2, bty="n")

###############################画图--弯月面角度#############################
plot(ang$fv, ang$X0.1, col=0, xaxs="i", xlim=c(0, 105), ylim=c(65, 100),
xlab="Voltage frequency (Hz)", cex.lab=1, ylab="Taylor Angle (°)", main="Meniscus Angle in various fv & k")

lines(lowess(ang$fv, ang$X0.1), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(ang$fv, ang$X0.2), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(ang$fv, ang$X0.3), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(ang$fv, ang$X0.5), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

lines(lowess(ang$fv, ang$X0.8), col="#27408B", pch=25, lwd=2.5, type="b", lty=2)

legend("topright", c("k=0.1", "k=0.2", "k=0.3", "k=0.5", "k=0.8"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=1.5, lty=2, cex=1.2, bty="n")

mtext("乙二醇 | H = 1mm | Nozzle 24G | Q = 0.0002nl/min | Fv = 20Hz | Duty = 20%", 1, line=1, col="black", cex=1.3, font=2, outer=TRUE)

#dev.off()


#' Triad Table
#'
#' Creates a table that contains triadID - the three nodes that make up the triad, nodeID - the character name of the node,
#' direction of the triad from the node, the valence of the triad from the node's perspective, distance of the triad from the node,
#' and nodeNum - the numeric value of the node
#'
#' @param g An igraph graph
#' @useDynLib pii
#' @export
triad.table <- function(g, triads) {
  if(is.null(V(g)$name)){V(g)$name <- 1:vcount(g)}
  n.dist <- shortest.paths(g, V(g))
  e.valence <- cbind(get.edgelist(g, names = F), E(g)$valence)

  # 3d edge distance matrix of edge, edge, focal.node
  e.dist.l <- edge.distance(g, lookup.mat = T)

  # start the triad table
  # create a copy of the triads for each node, stack it all up
  b <- do.call(rbind, replicate(vcount(g), triads, simplify=F)) %>%
    cbind(rep(1:vcount(g), each = nrow(triads))) %>%
    data.frame %>%
    rename(triadNodeA = X1, triadNodeB = X2, triadNodeC = X3, focalNode = X4)

  # use the two nodes in each edge and the focal node as a lookup index in the e.dist.l table
  b$distEdgeAB <- e.dist.l[as.matrix(b[,c('triadNodeA','triadNodeB', 'focalNode')])]
  b$distEdgeAC <- e.dist.l[as.matrix(b[,c('triadNodeA','triadNodeC', 'focalNode')])]
  b$distEdgeBC <- e.dist.l[as.matrix(b[,c('triadNodeB','triadNodeC', 'focalNode')])]

  b$nodeDistA <- n.dist[as.matrix(b[, c('triadNodeA', 'focalNode')])]
  b$nodeDistB <- n.dist[as.matrix(b[, c('triadNodeB', 'focalNode')])]
  b$nodeDistC <- n.dist[as.matrix(b[, c('triadNodeC', 'focalNode')])]

  # direction, 1 is inward, 0 is outward
  b <- mutate(b, direction = ifelse(distEdgeAB == distEdgeAC & distEdgeAB == distEdgeBC,
                                    ifelse(nodeDistA == nodeDistB & nodeDistA == nodeDistC, 2, 1), 0))
  b$closingNode1 <- NA
  b$closingNode2 <- NA

  #lookup matrix for valence of edges between two lookup nodes
  v.mat <- matrix(NA, ncol = vcount(g), nrow = vcount(g))
  v.mat[get.edgelist(g, names = F)] <- E(g)$valence

  # with outward facing triads, the closing edge is always the furthest away
  farthestEdge <- apply(b[b$direction == 0,c('distEdgeAB', 'distEdgeAC', 'distEdgeBC')], 1, which.max)

  m <- matrix(c(1, 2, 1, 3, 2, 3), byrow = T, ncol = 2)
  m <- m[farthestEdge, ]
  m <- cbind(1:nrow(m), m)

  b1 <- b[b$direction == 0, c('triadNodeA', 'triadNodeB', "triadNodeC")]
  if(nrow(b1) != 0){
    b[b$direction == 0, "closingNode1"] <- b1[m[, c(1, 2)]]
    b[b$direction == 0, "closingNode2"] <- b1[m[, c(1, 3)]]
  }

  # with inward facing triads, the closing edge is the one between the two closest nodes
  b1 <- b[b$direction == 1, c('triadNodeA', 'triadNodeB', "triadNodeC")]
  if(nrow(b1) != 0){
    x <- apply(b[b$direction == 1, c("nodeDistA", "nodeDistB", "nodeDistC")], 1, function(x) { which(x == min(x)) }) %>%
       t %>% as.matrix %>% cbind(1:nrow(.), .)
    b[b$direction == 1, 'closingNode1'] <- b1[x[, c(1, 2)]]
    b[b$direction == 1, 'closingNode2'] <- b1[x[, c(1, 3)]]
  }

  # ambiguous triads are replicated and given the valence of each edge
  b1 <- b[b$direction == 2, ]
  if(nrow(b1) != 0){
    b <- b[b$direction != 2,]

    b1a <- b1
    b1a$closingNode1 <- b1a$triadNodeA
    b1a$closingNode2 <- b1a$triadNodeB

    b1b <- b1
    b1b$closingNode1 <- b1b$triadNodeA
    b1b$closingNode2 <- b1b$triadNodeC

    b1c <- b1
    b1c$closingNode1 <- b1c$triadNodeB
    b1c$closingNode2 <- b1c$triadNodeC

    b <- rbind(b, b1a, b1b, b1c)
  }

  # add valence
  b$closeEdgeValence <- v.mat[b[,c("closingNode1", "closingNode2")] %>% as.matrix]
  b$closeEdgeDist <- e.dist.l[b[,c("closingNode1", "closingNode2", "focalNode")] %>% as.matrix]

  return(b)
}


#' @title jae.hist
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  jae.hist = function(x, s0, s1, bwh, bwd, title, ...) {
    breaks = seq(s0, s1, bwh)
    out = hist(x, breaks=breaks, main=title, ...)
    k = density(x, bw=bwd)
    k$y = k$y * (k$n) * bwh
    lines(k, lwd=2)
    return(out)
  }


# load packages --------------------
install.packages("mice")
install.packages("corrplot")
install.packages("pool")
install.packages("VIM")
library(mice)
library(corrplot)
library(pool)
library(VIM)

# 1. load data ---------------------
train_med <- read.csv("C:/Users/huiyeon/Desktop/Dacon/train_removeNaN_1.csv")  # (16909, 1301)
weather_pre <- read.csv("C:/Users/huiyeon/Desktop/Dacon/weather_knn-All.csv")  # (17088, 7)
#test <- read.csv("C:/Users/huiyeon/Desktop/Dacon/11회 data/test.csv")  # (8760, 201)

# Total NA
train_med_count_na <- apply(train_med,2,function(x)sum(is.na(x)))
train_med_count_na[1:50]

# 2. EDA ---------------------------
# 2-1. train_med
summary(train_med)
describe(train_med)
str(train_med)
head(train_med$Time)

# 2-2. weather_pre
summary(weather_pre)
describe(weather_pre)
str(weather_pre)

# 상관분석
# X, Time만 제외
weather_cor <- cor(weather_pre[, !names(weather_pre) %in% c('X', 'Time')], method='pearson')

# 시각화
corrplot(weather_cor, method='shade', shade.col=NA, tl.col='black', tl.srt=45)

# 3. Merge -------------------------
# X변수 제거
weather_pre <- weather_pre[, !names(weather_pre) %in% c('X')]

# Time to TimeSeries
weather_pre$Time <- as.POSIXlt(weather_pre[,1],format="%Y.%m.%d %H:%M")
train_med$Time <- as.POSIXlt(train_med[,1],format="%Y-%m-%d %H:%M")

# Merge 전에 list로 변환
train_med <- as.list(train_med)
weather_pre <- as.list(weather_pre)

# Merge
data <- merge(train_med, weather_pre, by='Time', all.x=T)
summary(data)
class(data)  # data.frame

# 모두 null값인 컬럼 지우기
null_col <- c('X1', 'X22', 'X24', 'X3', 'X34', 'X4', 'X45', 'X64')
data <- data[, !names(data) %in% null_col]

# After merge, Total count na
Total_count_na <- apply(data,2,function(x)sum(is.na(x)))
Total_count_na[(length(data)-100):length(data)]

# 4. Mice --------------------------
# 100개 변수만 뽑아서 실행해 보기
data_test <- colnames(data)[1:10]
data_test_w <- colnames(data)[(length(data)-4): length(data)]
colname_test <- cbind(data_test, data_test_w)
mice_test <- data[, names(data) %in% colname_test]

# NA pattern 확인
md.pattern(mice_test)

aggr_plot <- aggr(mice_test, col=c('navyblue','red'), numbers=TRUE, sortVars=TRUE, labels=names(mice_test), cex.axis=.7, gap=3, ylab=c("Histogram of missing data","Pattern"))

# Mice
# able : cart
# Unable : norm.boot, lda, pmm, norm, norm.predict, logreg, polyreg, rf, midastouch
# m defalut=5
imp <- mice(mice_test, m=10, method='cart',
            seed=1234)  # dataset을 5개 생성

# m=5 일 때
# X692으로 모형적합
fit_X692 <- with(imp,step(lm(X692~Temp+hum+rain+wind+snow))) # analysis는 lm(), glm(), gam(), nbrm() 등
# fit에는 m개의 분석결과가 들어간다
# stepwise 결과 X692~Temp+Wind+snow
fit_X692 <- with(imp,lm(X692~Temp+wind))
pooled = pool(fit_X692)  # pooled는 m개의 분석결과의 평균
summary(pooled)

imp  # imputaion inf
imp$imp  # 실제 대치값
result_1 <- imp$imp$X692  # m=5일 경우

# m=10 일 때
# X692으로 모형적합
fit_X692 <- with(imp,step(lm(X692~Temp+hum+rain+wind+snow))) # analysis는 lm(), glm(), gam(), nbrm() 등
# fit에는 m개의 분석결과가 들어간다
# stepwise 결과 X692~Temp+Wind+snow
fit_X692 <- with(imp,lm(X692~Temp+wind))
pooled = pool(fit_X692)  # pooled는 m개의 분석결과의 평균
summary(pooled)

imp  # imputaion inf
imp$imp  # 실제 대치값
result_2 <- imp$imp$X692  # m=5일 경우

# m=5일때, 10일 때
data.frame(result_1, result_2)

# X1272으로 모형적합
fit_X1272 <- with(imp,lm(X1272~Temp+hum+wind+snow))
pooled = pool(fit_X1272)
summary(pooled)

# 분석모형 유의성 진단
round(summary(pool(fit_X692)),2)  # 유의하지 않음

###### 결과적으로 원자료 값이 없어서 모형적합도는 확인하지 않기로 결정 #####

# 모든 데이터로 mice 실행하기


library(WGCNA)
multiExpr = vector(mode="list", length=2)
multiExpr[[1]] = list(data=as.data.frame(t(CAU_datExpr[genes,])))
multiExpr[[2]] = list(data=as.data.frame(t(CNS_datExpr[genes,])))
#multiExpr[[3]] = list(data=as.data.frame(t(AA_datExpr[genes,])))

bsize = 5000
nSets = 2
#nSets = 3
powers = c(seq(1,19,by=1),seq(20,30,by=2))
enableWGCNAThreads()
allowWGCNAThreads()

#Pick Soft Threshold
if(TRUE) {
  pdf("./unsigned_softThresh.pdf")
  for(n in 1:2) {
    multiExpr[[n]]$softThresh = pickSoftThreshold(data= multiExpr[[n]]$data, networkType = "unsigned", corFnc="bicor",verbose=5,powerVector=powers,blockSize = bsize)

  sft = multiExpr[[n]]$softThresh
  plot(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2], xlab="Soft Thresh Power", ylab="Scale free R^2",type="n", main=names(multiExpr)[n])
  text(sft$fitIndices[,1], -sign(sft$fitIndices[,3])*sft$fitIndices[,2], labels = powers, cex = 0.7, col="red",  xlab="Soft Thresh Power", ylab="Scale free R^2",main=names(multiExpr)[n])
  abline(h=0.8, col="black")
  plot(sft$fitIndices[,1], sft$fitIndices[,5], xlab = "Soft threshold power", ylab = "Mean connectivity", type = "n")
  text(sft$fitIndices[,1], sft$fitIndices[,5], labels = powers, cex = 0.7, col="black")
  }
  dev.off()
}

softPower=5; cquant=0.5

net = blockwiseConsensusModules(multiExpr, power = 9, maxBlockSize=50000, minModuleSize = 50, deepSplit = 2,pamRespectsDendro = FALSE,networkType="signed",mergeCutHeight = 0.3, numericLabels = TRUE,minKMEtoStay = 0,saveTOMs = TRUE, verbose = 5, pamStage=FALSE ,saveConsensusTOMs = TRUE,consensusTOMFileNames = "Signed_WGCNA_consensusTOM.RData")

consMEs = net$multiMEs;
moduleLabels = net$colors;
moduleColors = labels2colors(moduleLabels)
consTree = net$dendrograms[[1]];
pdf("Unsigned gene dendrogram and module colors.pdf")
plotDendroAndColors(consTree, moduleColors,
                    "Module colors",
                    dendroLabels = FALSE, hang = 0.03,
                    addGuide = TRUE, guideHang = 0.05,
                    main = "Unsigned Consensus gene dendrogram and module colors")
dev.off()

save(net,consMEs, moduleColors, moduleLabels, consTree, file = "Signed_Consensus-NetworkConstruction.RData")

QTL <- read.table("eQTLinAllGenes.txt",header=T,row.names=1)
cauc.specific.egene.col <- labels2colors(QTL$Caucasian.specific.gene)
cns.specific.egene.col <- labels2colors(QTL$Chinese.specific.gene)
share.egene.col <- labels2colors(QTL$Shared)

pdf("Signed module colors for All gene dendrogram.pdf",height=7,width=11)
plotDendroAndColors(consTree, colors = cbind(moduleColors,cauc.signed.moduleColors, cns.signed.moduleColors,cauc.specific.egene.col,cns.specific.egene.col,share.egene.col), groupLabels = c("Consensus modules","Caucasian modules", "Chinese modules","Caucasian.specific.eGenes","Chinese.specific.eGenes","Overlap eGenes"), cex.colorLabels=0.6, cex.dendroLabels=0.2)
dev.off()

nSets = 2
setLabels = c("Caucasian", "Chinese")
consMEsC = multiSetMEs(multiExpr, universalColors = moduleColors);
MET = consensusOrderMEs(consMEsC);
kME = consensusKME(multiExpr, universalColors = moduleColors)
pdf(file = "EigengeneNetworks.pdf", width= 8, height = 10)
par(cex = 0.9)
plotEigengeneNetworks(MET, setLabels, marDendro = c(0,2,2,1), marHeatmap = c(3,3,2,1),
zlimPreservation = c(0.5, 1), xLabelsAngle = 90)
dev.off();


Args<-commandArgs(trailingOnly=T)
file_prefix<-Args[1]
lib_type<-Args[2]
norm_type<-Args[3]

print("read file...")
in_file<-paste(file_prefix, "-coding.", lib_type, ".", norm_type, ".tsv", sep="");
gene_stat_file<-paste(file_prefix, "-stat.", lib_type, ".", norm_type, ".tsv", sep="");
loading_file<-paste(file_prefix, "-loading.", lib_type, ".", norm_type, ".tsv", sep="");
coord_file<-paste(file_prefix, "-coord_tmp.", lib_type, ".", norm_type, ".tsv", sep="");
std_file<-paste(file_prefix, "-std.", lib_type, ".", norm_type, ".tsv", sep="");
z_loading_file<-paste(file_prefix, "-loading.", lib_type, ".", norm_type, ".zscore.tsv", sep="");
z_coord_file<-paste(file_prefix, "-coord_tmp.", lib_type, ".", norm_type, ".zscore.tsv", sep="");
z_std_file<-paste(file_prefix, "-std.", lib_type, ".", norm_type, ".zscore.tsv", sep="");
rds_file<-paste(file_prefix, "-coding.", lib_type, ".", norm_type, ".rds", sep="");
#in_file<-Args[6]
#gene_stat_file<-Args[7]
#loading_file<-Args[8]
#coord_file<-Args[9]
#std_file<-Args[10]
#rds_file<-Args[11]
data <- as.data.frame(data.table::fread(in_file, sep="\t", header = TRUE))
rownames(data) = data$V1
#data<-read.table(in_file, header=T, sep="\t")
print("calculating statistics...")
d<-data[2:nrow(data),2:ncol(data)]
if (!is.na(rds_file)) {
	print("save RDS...")
	saveRDS(d, rds_file)
}
#dim(d)
ncol(data)
if (ncol(data) < 3 ) {
	print("No samples. Exit...")
	quit()
}
#print("to matrix...")
#d<-data[,2:length(data)]
mat<-as.matrix(d) # convert to matrix
mat<-t(mat)
#colnames(mat)<-data[,1]
class(mat)<-"numeric"
#min(mat)
#print("to log2...")
#mat <- log2(mat+1)
neg <- mat[which(mat<0)]
#length(neg)
#summary(neg)
mat <- ifelse(mat < 0, 0, mat)
#print("sd...")
sd_gene <- apply(mat, 2, sd)
mat3000 <- mat[,which(sd_gene > sort(sd_gene, decreasing=T)[3000])]
#mat3000 <- mat
mat <- mat[,which(sd_gene!=0)]
#print("mean...")
mean_gene <- apply(mat, 2, mean)
#print("median...")
median_gene <- apply(mat, 2, median)
sd_gene <- sd_gene[which(sd_gene!=0)]
#scaled_mat <- t((t(mat) - mean_gene)/sd_gene)
#scaled_mat <- mat
gene_stat <- cbind(as.matrix(mean_gene),as.matrix(sd_gene),as.matrix(median_gene))
write.table(gene_stat, file=gene_stat_file, sep='\t', col.names=FALSE, quote=FALSE);
#write.table(scaled_mat, file=gene_stat_file, sep='\t', col.names=FALSE);
print("calculating PCA...")
if (!is.na(loading_file)) {
	res<-prcomp(mat3000)
	s <- min(30, ncol(res$rotation))
	if (s > 3) {
		write.table(res$rotation[,1:s], file=loading_file, sep='\t', col.names=FALSE, quote = FALSE);
		write.table(res$x[,1:3], file=coord_file, sep='\t', col.names=FALSE, quote = FALSE);
		write.table(res$sdev, file=std_file, sep='\t', col.names=FALSE, quote = FALSE);
	}

	res_z<-prcomp(mat, center=T, scale=T)
	s <- min(30, ncol(res_z$rotation))
	if (s > 3) {
		write.table(res_z$rotation[,1:s], file=z_loading_file, sep='\t', col.names=FALSE, quote = FALSE);
		write.table(res_z$x[,1:3], file=z_coord_file, sep='\t', col.names=FALSE, quote = FALSE);
		write.table(res_z$sdev, file=z_std_file, sep='\t', col.names=FALSE, quote = FALSE);
	}
}
print("done.")


prj_name <- "xgb_18"
candi <- list.files(paste0("../submission/", prj_name, "/"))
print(candi)

scores <- as.numeric(substring(candi, nchar(candi)-9, nchar(candi)-4))

info <- data.frame(filename = candi, score = scores)

num_model <- 10

for(i in 1:num_model){
	target_file <- as.character(info$filename[order(info$score, decreasing = TRUE)[i]])
	print(target_file)
	datai <- read.csv(paste0("../submission/", prj_name, "/", target_file))
	if(i==1){
		data <- datai
	}else{
		data$TARGET <- data$TARGET + datai$TARGET
	}
}

data$TARGET <- data$TARGET / num_model

meanvalid <- mean(sort(info$score, decreasing = TRUE)[1:num_model])
write.table(data, paste0("../submission/", prj_name, "_nummodel", num_model, "_mvalid", sprintf("%.4f", meanvalid), ".csv"), row.names = FALSE, sep=",", quote = FALSE)


#!/usr/bin/env Rscript
#
#  two-way_permanova.r - R slave for two-way permanova analysis with R package vegan
#
#  Version 1.0.0 (July, 15, 2016)
#
#  Copyright (c) 2016-- Lela Andrews
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Recieve input files from bash
args <- commandArgs(TRUE)
map=(args[1])
dmfile=(args[2])
factor1=(args[3])
factor2=(args[4])
dmname=(args[5])
f2temp=(args[6])
outdir=(args[7])
perms0=(args[8])
perms <- as.integer(perms0)

## Load libraries
library(vegan)

## Read in data
mapfile <- read.csv(map, sep="\t", header=TRUE)
dm0 <- read.csv(dmfile, sep="\t", header=TRUE)
dm <- as.dist(dm0)
f1 <- mapfile[,factor1]
f2 <- mapfile[,factor2]
f3 <- paste(f1, f2)

## Run betadisper and print to screen
pd <- betadisper(dm, f3)
pd

## Permutation test of dispersions, printing to screen
permutest(pd, permutations = perms)

## Tukey HSD test and print to screen
writeLines("\n********************************\nTukey's HSD test of dispersions across groups:\n")
pd.HSD <- TukeyHSD(pd)
pd.HSD

## PCoA plots and boxplots of multivariate dispersions, write to pdf file
Permdisp <- pd
pdf(paste0(outdir, "/Permdisp_plots.pdf"), width=12, height=12)
par(mfrow=c(2,2))
plot(Permdisp, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 1 vs 2", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(1,2))
plot(Permdisp, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 1 vs 3", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(1,3))
plot(Permdisp, label.cex=0.5, ellipse=TRUE, hull=FALSE, seg.lty="dashed", cex=0.5, sub=dmname, main="PCoA axes 2 vs 3", cex.main=1.5, cex.sub=1.25, cex.lab=1.1, axes=c(2,3))
boxplot(pd, main="Boxplots of multivariate dispersions", sub="Categories", cex.axis=0.75, cex.main=1.5, cex.sub=1.25, cex.lab=1.25)

## End
q()


# EWAS of left-handedness: adjusted model, NTR adults
# V.Odintsova, J.van Dongen

library(gee)

# Load DNA methylation data
# Load phenotype and covariate data

# Variabels for adjusted model
# familynumber
# sex
# age (age at DNA bloodsampling)
# Neut_Perc (neutrophils percentage)
# Mono_Perc (monocytes percentage)
# Eos_Perc (eosinophils percentage)
# Array_rownum (array rownumber)
# Sample_Plate (sample plate)
# hand01 (left-handedness variable: right-handed = 0, left-handed = 1)
# smoking
# BMI

mydata <- data.frame(familynumber, sex,age,Mono_Perc,Eos_Perc,Neut_Perc,Array_rownum,Sample_Plate,hand01,
    smoking, BMI)

mydata <- mydata[order(mydata$familynumber),]
DNAm <- DNAm[rownames(mydata),]

# GEE model for a continuous outcome (DNA methylation level) correcting for clustering of samples
#------------------------------------------------------------------------------------------------------------------------------------------------------

geemodel <- function (data)
{
gee(CpGi~hand01+sex+age+Mono_Perc+Eos_Perc+Neut_Perc+Array_rownum+Sample_Plate+smoking+BMI, data=data, id=familynumber, family=gaussian, corstr="exchangeable", maxiter=100, na.action=na.omit,silent=TRUE)
}
#------------------------------------------------------------------------------------------------------------------------------------------------------

Nestimates <-nrow(coeff)
Ncpgs      <-ncol(DNAm)
pval       <-matrix(NA,Ncpgs,Nestimates)
estimate   <-matrix(NA,Ncpgs,Nestimates)
RobustSE   <-matrix(NA,Ncpgs,Nestimates)
RobustZ    <-matrix(NA,Ncpgs,Nestimates)
N          <- matrix(NA,Ncpgs,1)
Ncpgs
Nestimates

for (i in 1:Ncpgs)
{
    mydata$CpGi <- DNAm[,i]
N[i,] <- length(which(!is.na(mydata$CpGi)))
coeff <- summary(geemodel(mydata))$coefficients
for (j in 1: Nestimates)
{
estimate[i,j] <- coeff[j,1]
RobustSE[i,j] <- coeff[j,4]
RobustZ[i,j]  <- coeff[j,5]
pval[i,j]     <- 2*pnorm(-abs(coeff[j,5]))
}
}

colnames(estimate)   <- rownames(coeff)
colnames(RobustSE)   <- rownames(coeff)
colnames(RobustZ)    <- rownames(coeff)
colnames(pval)       <- rownames(coeff)
rownames(estimate)   <- colnames(DNAm)
rownames(RobustSE)   <- colnames(DNAm)
rownames(RobustZ)    <- colnames(DNAm)
rownames(pval)       <- colnames(DNAm)
rownames(N)          <- colnames(DNAm)

save(estimate,pval,RobustSE,RobustZ,N, file= "EWASresults.RData")


##  ---- libraries

# libraries need to be in a .R file so packrat can find them

require(sp) # the classes and methods that make up spatial ops in R
require(maptools) # tools for reading and manipulating spatial objects
require(mapdata) # includes good vector maps of world political boundaries.
require(PBSmapping) # for calculating intersection areas
require(rgeos)
library(splancs)
require(gridExtra)
require(ggplot2)
require(reshape2)
require(plyr)
require(rjags)
require(coda)
require(BEST)
require(coin)
require(pander)
require(Momocs)
require(dependencies) # github only


# Day 20: Trench Map

get_day20_input_path <- function() {
    paste(getwd(), "/2021/Day 20/Day20_input.txt", sep = "")
}

part1 <- function(num_enhancements = 2) {
    readings <- readLines(get_day20_input_path())

    padding <- num_enhancements + 1
    trench_len <- nchar(readings[3]) + padding * 2

    enhance <- unlist(strsplit(readings[1], ""))
    trench <- matrix(ncol = trench_len)[-1, ]

    trench <- map_trench(trench, readings, padding)

    # Enhancements loop
    for (i in 1:num_enhancements) {
        new_trench <- matrix(".", nrow = nrow(trench), ncol = ncol(trench))

        trench_ind <- which(trench == "#", arr.ind = TRUE)
        trench_ind <- rbind(trench_ind, which(trench == ".", arr.ind = TRUE))

        # Trench index loop
        for (l in seq_len(nrow(trench_ind))) {
            points_to_calc <- get_adj_points(trench_ind[l, 1], trench_ind[l, 2],
                                        nrow(trench), ncol(trench))
            points_to_calc <- rbind(points_to_calc, trench_ind[l, ])

            # Points around current index loop
            for (p in seq_len(nrow(points_to_calc))) {
                segment <- get_adj_points(points_to_calc[p, 1],
                                        points_to_calc[p, 2],
                                        nrow(trench), ncol(trench))
                segment <- rbind(segment, points_to_calc[p, ])

                # If we have a 9-piece segment, calculate the enhancement index
                if (nrow(segment) == 9) {
                    segment <- segment[order(segment[, 1], segment[, 2]), ]
                    values <- trench[segment]

                    enhance_index <- lights_to_dec(values) + 1
                    point <- matrix(points_to_calc[p, ], ncol = 2)
                    new_trench[point] <- enhance[enhance_index]
                } else {
                    # We don't have a 9-piece segment, so we're near a border
                    # 0 index is "on" and 511 index is "off"
                    # So if we're not near the enhancement image,
                    # We can fill in the partial segment based on loop iteration
                    if (i %% 2 == 0) {
                        new_trench[segment] <- "."
                    } else {
                        new_trench[segment] <- "#"
                    }
                }
            }
        }
        trench <- new_trench
    }

    cat("Lit pixels:", sum(trench == "#"), "\n")
}

part2 <- function() {
    part1(50)
}

map_trench <- function(trench, readings, padding) {
    trench <- pad_rows(trench, padding)

    space <- rep(".", padding)
    for (i in 3:length(readings)) {
        trench <- rbind(trench, c(space,
                                  unlist(strsplit(readings[i], "")),
                                  space))
    }

    trench <- pad_rows(trench, padding)
}

pad_rows <- function(trench, padding) {
    for (i in 1:padding) {
        trench <- rbind(trench, ".")
    }
    trench
}

get_adj_points <- function(row, col, max_row, max_col) {
    adj_points <- matrix(ncol = 2)[-1, ]

    # Up Value
    if (row > 1) {
        adj_points <- rbind(adj_points, c(row - 1, col))
    }

    # Up Left Value
    if (row > 1 && col > 1) {
        adj_points <- rbind(adj_points, c(row - 1, col - 1))
    }

    # Up Right Value
    if (row > 1 && col < max_col) {
        adj_points <- rbind(adj_points, c(row - 1, col + 1))
    }

    # Down Value
    if (row < max_row) {
        adj_points <- rbind(adj_points, c(row + 1, col))
    }

    # Down Left Value
    if (row < max_row && col > 1) {
        adj_points <- rbind(adj_points, c(row + 1, col - 1))
    }

    # Down Right Value
    if (row < max_row && col < max_col) {
        adj_points <- rbind(adj_points, c(row + 1, col + 1))
    }

    # Left Value
    if (col > 1) {
        adj_points <- rbind(adj_points, c(row, col - 1))
    }

    # Right Value
    if (col < max_col) {
        adj_points <- rbind(adj_points, c(row, col + 1))
    }

    adj_points
}

lights_to_dec <- function(values) {
    values <- replace(values, values == ".", "0")
    values <- replace(values, values == "#", "1")
    bin <- paste(values, collapse = "")
    dec <- strtoi(bin, base = 2)
    dec
}

part1()
part2()