\name{make_comb_mat}
\alias{make_comb_mat}
\title{
Make a Combination Matrix for UpSet Plot
}
\description{
Make a Combination Matrix for UpSet Plot
}
\usage{
make_comb_mat(..., mode = c("distinct", "intersect", "union"),
    top_n_sets = Inf, min_set_size = -Inf, remove_empty_comb_set = TRUE,
    remove_complement_set = FALSE, universal_set = NULL,
    complement_size = NULL, value_fun = NULL)
}
\arguments{

  \item{...}{The input sets. If it is represented as a single variable, it should be a matrix/data frame or a list. If it is multiple variables, it should be name-value pairs, see Input section for explanation.}
  \item{mode}{The mode for forming the combination set, see Mode section.}
  \item{top_n_sets}{Number of sets with largest size.}
  \item{min_set_size}{Ths minimal set size that is used for generating the combination matrix.}
  \item{remove_empty_comb_set}{Whether remove empty combination sets?}
  \item{remove_complement_set}{Whether remove the complement set which has no intersection to any of the set.}
  \item{universal_set}{The universal set. If it is set, the size of the complement set of all sets is also calculated. It if is specified, \code{complement_size} is ignored.}
  \item{complement_size}{The size for the complement of all sets. If it is specified, the combination set name will be like "00...".}
  \item{value_fun}{For each combination set, how to calculate the size? If it is a scalar set,  the length of the vector is the size of the set, while if it is a region-based set, (i.e. \code{GRanges} or \code{IRanges} object), the sum of widths of regions in the set is calculated as the size of the set.}

}
\section{Input}{
To represent multiple sets, the variable can be represented as:

1. A list of sets where each set is a vector, e.g.:

  \preformatted{
    list(set1 = c("a", "b", "c"),
         set2 = c("b", "c", "d", "e"),
         ...)  }

2. A binary matrix/data frame where rows are elements and columns are sets, e.g.:

  \preformatted{
      a b c
    h 1 1 1
    t 1 0 1
    j 1 0 0
    u 1 0 1
    w 1 0 0
    ...  }

If the variable is a data frame, the binary columns (only contain 0 and 1) and the logical
columns are only kept.

The set can be genomic regions, then it can only be represented as a list of \code{GRanges} objects.}
\section{Mode}{
E.g. for three sets (A, B, C), the UpSet approach splits the combination of selecting elements
in the set or not in the set and calculates the sizes of the combination sets. For three sets,
all possible combinations are:

  \preformatted{
    A B C
    1 1 1
    1 1 0
    1 0 1
    0 1 1
    1 0 0
    0 1 0
    0 0 1  }

A value of 1 means to select that set and 0 means not to select that set. E.g., "1 1 0"
means to select set A, B while not set C. Note there is no "0 0 0", because the background
size is not of interest here. With the code of selecting and not selecting the sets, next
we need to define how to calculate the size of that combination set. There are three modes:

1. \code{distinct} mode: 1 means in that set and 0 means not in that set, then "1 1 0" means a
set of elements also in set A and B, while not in C (i.e. \code{setdiff(intersect(A, B), C)}). Under
this mode, the seven combination sets are the seven partitions in the Venn diagram and they
are mutually exclusive.

2. \code{intersect} mode: 1 means in that set and 0 is not taken into account, then, "1 1 0" means
a set of elements in set A and B, and they can also in C or not in C (i.e. \code{intersect(A, B)}).
Under this mode, the seven combination sets can overlap.

3. \code{union} mode: 1 means in that set and 0 is not taken into account. When there are multiple
1, the relationship is OR. Then, "1 1 0" means a set of elements in set A or B, and they can also in C or not in C (i.e. \code{union(A, B)}).
Under this mode, the seven combination sets can overlap.}
\value{
A matrix also in a class of \code{comb_mat}.

Following functions can be applied to it: \code{\link{set_name}}, \code{\link{comb_name}}, \code{\link{set_size}}, \code{\link{comb_size}}, \code{\link{comb_degree}},
\code{\link{extract_comb}} and \code{\link{t.comb_mat}}.
}
\examples{
set.seed(123)
lt = list(a = sample(letters, 10),
          b = sample(letters, 15),
          c = sample(letters, 20))
m = make_comb_mat(lt)

mat = list_to_matrix(lt)
mat
m = make_comb_mat(mat)

\dontrun{
library(circlize)
library(GenomicRanges)
lt = lapply(1:4, function(i) generateRandomBed())
lt = lapply(lt, function(df) GRanges(seqnames = df[, 1],
    ranges = IRanges(df[, 2], df[, 3])))
names(lt) = letters[1:4]
m = make_comb_mat(lt)
}
}


freq <- read.csv("0301.frequency.csv",
                 header = T,
                 na.strings = ".")
str(freq)
freq$grade <- factor(freq$grade,
                     levels = c(5:1),
                     labels = c("A","B","C","D","F"))

str(freq$grade)

str(freq)

attach(freq)

# 일변량 범주형 자료 ####

barplot(grade)

# 그래프로(테이블) 된 것만 barplot 으로 그릴 수 있다. table로 정리한 후에 그려야 한다. - 원자료 사용못한다.
# 기본 막대그래프

grade <- table(grade)
barplot(grade)

# 그래프 옵션

barplot(grade, # 원데이터가 아니라 테이블로 만든 데이터
        main = "학점별 분포",
        xlab = "학점",
        ylab = "명",
        ylim = c(0,30),
        col = rainbow(length(grade)),
        legend =rownames(grade)) # 범례, 행네임을 grade에 있는 A - F로 붙여 주어라.

# 수평 막대 그래프

barplot(grade,  # 원데이터가 아니라 테이블로 만든 데이터
       main = "학점별 분포",
       horiz = TRUE, # 가로형태로 만들어라
       xlab = "명",
       ylab = "학점",
       xlim = c(0,30),
       col = "red", # heat.colors 로 해도됨
       legend = rownames(grade))

# 원그래프 ####

pie(grade,
    main = "학점별 분포",
    init.angle = 180, # 처음 각도를 0도에서 시작하라.
    col = rainbow(length(grade))) # grade 테이블의 행의 갯수

legend(0 ,0, # 범례지정함수는 그래프와 별도로 입력할 수 있음 1,1은 위치지정 ()
       rownames(grade),
       cex = 0.5, # 범례 글자 크기
       fill = rainbow(length(grade))) # 색깔입력

# 3D 원그래프 옵션 ####

# install.packages("plotrix")
library(plotrix)

pie3D(grade,
      main = "학점별 분포",
      labels=grade,
      explode=0.1,
      col=heat.colors(5))  # 파이가 쪼개지는 정도
legend(0.8 ,1, # 범례지정함수는 그래프와 별도로 입력할 수 있음 1,1은 위치지정 ()
       rownames(grade),
       cex = 0.8, # 범례 글자 크기
       fill = heat.colors(5)) # 색깔입력

detach(freq)

# 누적 막대그래프와 모자이크 ####

pre <- read.csv("0302.pre.csv",
                header = T,
                na.strings = ".")

str(pre)

pre$treat <- factor(pre$treat,
                    levels = c(1,2),
                    labels = c("비타민","Placebo"))
pre$cold <- factor(pre$cold,
                   levels = c(1,2),
                   labels = c("Cold","noCold"))
str(pre)

attach(pre)

# 누적막대 그래프(barplot), 범주가 2개일 때
# 데이터를 테이블로 정리

pre.t <- table(treat, cold)

pre.t

pre.p <- prop.table(pre.t) # 만들어 놓은 테이블 데이터를 활용한다.

pre.p

barplot(pre.t,
        main = "비타민 섭취에 따른 감기유병률",
        xlab = "집단",
        ylab = "명",
        ylim = c(0,80),
        col = c("darkblue","red"),
        legend = rownames(pre.t))

barplot(pre.t,
        main = "비타민 섭취에 따른 감기유병률",
        xlab = "집단",
        ylab = "명",
        ylim = c(0,40),
        col = c("darkblue","red"),
        legend = rownames(pre.t),
        beside = T) # 범주별로 보여주는 옵션임

# 모자이크 그래프 ####

mosaicplot(pre.t, # 뭔가 구체적인 설명이 필요할 것 같은데... 더 찾아봐야 함. 그래프는 더 보기 좋게 나타남
           shade = T,
           xlab = "treat",
           ylab = "감기유무",
           main = "비타민섭취에 따른 감기유병률")

detach(pre)

# 히스토그램 그리기 ####
 # 범주형 자료가 아니라 연속형 자료일 때 활용하는 그래프(칸과 칸 사이가 붙어있음, 막대그래프는 떨어짐)

wgt <- read.csv("0401.wgt.csv",
                header = T,
                na.strings = ".")
str(wgt)

wgt$sex <- factor(wgt$sex,
                  levels = c(1,2),
                  labels = c("남자","여자"))
str(wgt)

attach(wgt)

hist(weight)
boxplot(weight)
stem(weight)

# 수치형 자료를 범주형으로 구분하여 막대그래프 그리기.
 # 미만 - 이상 으로 구분하여 개수 세고 그림 그리기
 # if 를 쓰는 방법과 cut을 활용하는 방법이 있음. 이 것은 cut이 편함

wgt <- transform(wgt,
                 wgt.cut = cut(weight,
                               breaks=c(0,45,50,55,60,65,70,100),
                               right=FALSE, # right = FALSE : a <= x < b (이상 - 미만) / right = TRUE : a < x <= b 초과 - 이하
                               labels=c("~45미만", "45이상~50미만","50이상~55미만","55이상~60미만",
                                        "60이상~65미만","65이상~70미만","70이상~")))

# 범주형 자료로 변환 (ifelse이용)
wgt<- transform(wgt,
                wgt.if = ifelse(weight < 45, "~ 45미만",
                                ifelse(weight >= 45 & weight < 50, "45이상~50미만",
                                       ifelse(weight >= 50 & weight < 55, "50이상~55미만",
                                              ifelse(weight >= 55 & weight < 60, "55이상~60미만",
                                                     ifelse(weight >= 60 & weight < 65, "60이상~65미만",
                                                            ifelse(weight >= 65 & weight < 70, "65이상~70미만","70이상~"
                                                            )
                                                     )
                                              )
                                       )
                                )
                )
)

# 데이터프레임을 새롭게 수정했을 경우에는 detach한후에 다시 attach해줘야 함
detach(wgt)
attach(wgt)
table(wgt.cut)
barplot(table(wgt.cut))

# 히스토그램 bin 설정
hist(weight,
     main ="학생들의 체중",
     breaks=7, # 구분점을 몇개로 할지 정해라
     col= "blue",
     min(weight),
     max(weight))

detach(wgt)

# 다변량 수치형 자료 ####
 # 그룹간 연속변수 특성 비교 (박스표)

boxplot(weight ~ sex, # 왼쪽에 있는 것이 종속변수(수치형 분석), 뒷쪽이 독립변수(구분해 주는 변수)
        data = wgt,
        main = "성별에 따른 몸무게 분포",
        xlab = "성별",
        ylab = "kg")

# 여러 연속자료의 비교 ####

load("game.RData")
str(game)

detach(wgt)
attach(game)

o1 <- mean(o1)
o2 <- mean(o2)
fb1 <- mean(fb1)
fb2 <- mean(fb2)
fb3 <- mean(fb3)

game.t <- cbind(o1,o2,fb1,fb2,fb3) # 옆으로 저장됨
game.t

barplot(game.t,
        col=c("darkblue"),
        main = "연속변수 평균",
        names.arg = c(colnames(game.t)), # 이거 의미 -어레인. 이름을 넣는데, 컬럼 순서대로 넣으라는 뜻
        ylim = c(0,4))

detach(game)

# 고급 그래프 그리기 ####

library(ggplot2)

ggplot(wgt, aes(x=sex)) +
  geom_bar()

ggplot(wgt, aes(x=sex, y=weight)) + geom_boxplot(col="red") +
  ggtitle("성별 체중 상자도표")

ch05 - 그래프 그리기/그래프 그리기.r

ch05 - 그래프 그리기/그래프 그리기.r

ch05 - 그래프 그리기/그래프 그리기.r


file_path <- "http://www.sthda.com/sthda/RDoc/data/housetasks.txt"
housetasks <- read.delim(file_path, row.names = 1)

library("gplots")
dt <- as.table(as.matrix(housetasks))
balloonplot(t(dt), main = "housetasks", xlab = "", ylab = "",
    label = FALSE, show.margins = FALSE)


 DTGSEN Example Program Results

 Number of selected eigenvalues  =    2

 Selected Generalized Eigenvalues

  1 ( 2.0000E+00, 0.0000E+00)
  2 ( 3.0000E+00, 0.0000E+00)

 Norm estimate of projection onto left  eigenspace for selected cluster
   2.69E+00

 Norm estimate of projection onto right eigenspace for selected cluster
   1.50E+00

 F-norm based upper bound on Difu
   2.52E-01

 F-norm based upper bound on Difl
   2.45E-01


source('Exact_unconditional_test_2x2.R')
source('Exact_cond_midP_unspecific_ordering_rx2.R')

#' Perform statistical test of association.
#'
#' @param groups_per_patient Vector with group number for each group.
#' @param total_per_group
#' @return p-value
#' @examples
stat_test <- function(groups_per_patient, total_per_group) {
    n_total <- total_per_group
    n_tumor <- count_patients_per_group(groups_per_patient)
    t <- c(
        n_tumor$low,
        n_tumor$medium,
        #n_tumor$high,
        n_total$low - n_tumor$low,
        n_total$medium - n_tumor$medium#,
        #n_total$high - n_tumor$high
    )
    # t <- c(
    #     n_tumor$low,
    #     n_tumor$medium,
    #     n_tumor$low + n_tumor$medium,
    #     n_tumor$high,
    #     n_total$low - n_tumor$low,
    #     n_total$medium - n_tumor$medium,
    #     n_total$low - n_tumor$low + n_total$medium - n_tumor$medium,
    #     n_total$high - n_tumor$high
    #  )
    cont_table <- matrix( t, nrow=2, byrow=TRUE )

    ## Long version (~17% slower)
    #rownames <- c('Tumor', 'No tumor')
    #colnames <- c('Low', 'Medium', 'High')
    #cont_table <- matrix( t, nrow=2, byrow=TRUE, dimnames = list(rownames,colnames) )

    test <- 'Pearson' # Fisher or Pearson
    if (test=='Fisher'){
        res <- fisher.test(cont_table)
        p_value <- res$p.value
    } else {
        if (dim(cont_table)[2]==2) {
            res <- Exact_unconditional_test_2x2(cont_table, printresults=FALSE)
            result <- list('p'=res, 'direction'='')
        } else if (dim(cont_table)[2]>=3 & dim(cont_table)[2]<=5) {
            p1 <- n_tumor$low/n_total$low
            p2 <- n_tumor$medium/n_total$medium
            p3 <- n_tumor$high/n_total$high
            if ((p1<=p2 & p1>=p3) | (p1>=p2 & p1>=p3) ){
                direction <- 'decreasing'
            } else {
                direction <- 'increasing'
            }
            res <- Exact_cond_midP_unspecific_ordering_rx2(t(cont_table), direction,'Pearson', FALSE) #test=Pearson, LR, PearsonCumOR or LRCumOR

            if ((n_tumor$low+n_tumor$medium+n_tumor$high)==0){
                print('Voxel with no tumors')
                print(cont_table)
                print(res$P)
            }

            result <- list('p'=res$P, 'direction'=direction)
            #result <- list('p'=res$midP, 'direction'=direction)
        }
    }
}

count_patients_per_group <- function( group_per_patient ) {
    n <- list('low'=0,'medium'=0,'high'=0)
    for (i in 1:length(n)) n[i] <- sum(group_per_patient==i)
    n
}

# rperm creates m unique permutations of 1:size
# Returns a `size` by `m` matrix; each column is a permutation of 1:size.
#
# https://stats.stackexchange.com/questions/24300/how-to-resample-in-r-without-repeating-permutations
#
rperm <- function(m, size=2) { # Obtain m unique permutations of 1:size

    # Function to obtain a new permutation.
    newperm <- function() {
        count <- 0                # Protects against infinite loops
        repeat {
            # Generate a permutation and check against previous ones.
            p <- sample(1:size)
            hash.p <- paste(p, collapse="")
            if (is.null(cache[[hash.p]])) break

            # Prepare to try again.
            count <- count+1
            if (count > 1000) {   # 1000 is arbitrary; adjust to taste
                p <- NA           # NA indicates a new permutation wasn't found
                hash.p <- ""
                break
            }
        }
        cache[[hash.p]] <<- TRUE  # Update the list of permutations found
        p                         # Return this (new) permutation
    }

    # Obtain m unique permutations.
    cache <- list()
    replicate(m, newperm())
}


# Modelo monetario de tipo de cambio con RNAs
# 04 de julio de 2016

rm(list=ls())
graphics.off()

# Leer los datos
library(xlsx)
df = read.xlsx("datosModelo.xlsx", sheetName="datosANN",
	colIndex = c(1:6), rowIndex = c(1:181))

# Dividir la muestra
datafit = df[1:144, ]
dataforecast = df[145:180, ]

# Cargar los pesos sinapticos iniciales
load("pesos/sw_1_9.rda")

# Capa oculta
oculta = c(9)

# Estimar la red neuronal
library(neuralnet)
nn <- neuralnet(
	s ~ y + inf + i + m,
	data = datafit,
	startweights = w0,
	hidden = oculta,
	err.fct = "sse",
	threshold = 0.1,
	rep = 1,
	act.fct = "tanh",
	linear.output=TRUE,
	algorithm = "rprop+",
	lifesign = "minimal"
)

# Computar fuera de la muestra
nnOut = compute(nn, dataforecast[ , 3:6])

# Graficar los resultados dentro y fuera de la muestra
par(mfrow=c(2,1))
plot(datafit$fecha, datafit$s, type="n", xlab="", ylab="s", ylim=c(-2,2.5))
title(main="Dentro de la muestra")
lines(datafit$fecha, datafit$s, type="l", col="blue")
lines(datafit$fecha, nn$net.result[[1]], col="red")

plot(dataforecast$fecha, dataforecast$s, type="n", xlab="", ylab="s", ylim=c(-2,2.5))
title(main="Fuera de la muestra")
lines(dataforecast$fecha, dataforecast$s, type="l", col="blue")
lines(dataforecast$fecha, nnOut$net.result, col="red")

# Guardar los resultados en archivo Excel
inSample = cbind(nn$response, nn$net.result[[1]])
outOfSample = cbind(dataforecast$s, nnOut$net.result)
write.xlsx(inSample, "netResult.xlsx", sheetName = "inSample")
write.xlsx(outOfSample, "netResult.xlsx", sheetName = "outOfSample", append=TRUE)

# Para interpretar el resultado
library(NeuralNetTools)
graf.garson = garson(mod_in = nn, y_lab = "Importancia relativa")


data = read.table("kddcup.data_10_percent",
	sep="," ,
	col.names=c("duration","protocol_type","service","flag","src_bytes","dst_bytes","land",
		"wrong_fragment","urgent","hot","num_failed_logins","logged_in","num_compromised",
		"root_shell","su_attempted","num_root","num_file_creations","num_shells","num_access_files",
		"num_outbound_cmds","is_host_login","is_guest_login","count","srv_count","serror_rate",
		"srv_serror_rate","rerror_rate","srv_rerror_rate","same_srv_rate","diff_srv_rate",
		"srv_diff_host_rate","dst_host_count","dst_host_srv_count","dst_host_same_srv_rate",
		"dst_host_diff_srv_rate","dst_host_same_src_port_rate","dst_host_srv_diff_host_rate",
		"dst_host_serror_rate","dst_host_srv_serror_rate","dst_host_rerror_rate","dst_host_srv_rerror_rate","label"),
	colClasses=c(label="character",protocol_type="factor", service="factor"))

data[1,'label'] == "normal.";
label_distribution = table(data$label);
as.data.frame(label_distribution)

library(rpart)

fit <- rpart(label ~ duration+protocol_type+service+flag+src_bytes+dst_bytes+land+wrong_fragment+urgent+hot+num_failed_logins+logged_in+num_compromised+root_shell+su_attempted+num_root+num_file_creations+num_shells+num_access_files+num_outbound_cmds+is_host_login+is_guest_login+count+srv_count+serror_rate+srv_serror_rate+rerror_rate+srv_rerror_rate+same_srv_rate+diff_srv_rate+srv_diff_host_rate+dst_host_count+dst_host_srv_count+dst_host_same_srv_rate+dst_host_diff_srv_rate+dst_host_same_src_port_rate+dst_host_srv_diff_host_rate+dst_host_serror_rate+dst_host_srv_serror_rate+dst_host_rerror_rate+dst_host_srv_rerror_rate,method="class", data=data)


definePlotBoundary<-function(gg,lim=NULL){
	if(is.null(lim))
		lim<-c(min(g$data$lon),max(g$data$lon),min(g$data$lat),max(g$data$lat))

	gg<-gg+ scale_x_continuous(limits = c(lim[1],lim[2]), expand = c(0, 0))
	gg<-gg+ scale_y_continuous(limits = c(lim[3],lim[4]), expand = c(0, 0))
	return(gg)
}

addGraticules<-function(gg,x=10,y=10,proj,plot.line=TRUE,plot.text=TRUE,color="grey", size=0.25,...){
	lines_proj<-graticules(x,y,proj=proj)
	lines<-lines2dataframe(lines_proj)
	if(plot.line==TRUE){
		gg<-gg+geom_path(data=lines,aes(lon,as.numeric(lat),group=group),colour=color,
			size=size,...)
	}
	lim<-c(min(gg$data$lon),max(gg$data$lon),min(gg$data$lat),max(gg$data$lat))
	p<-gratText(lines_proj,lim)
	if(plot.text==TRUE){
		gg<-gg+theme(axis.text.x = element_text(),
					axis.text.y = element_text(),
					axis.ticks = element_line())
		gg<-gg+scale_x_continuous(limits = c(lim[1],lim[2]), expand = c(0, 0),
			    breaks=as.vector(p$x[,1]),labels=p$x$txt)
		gg<-gg+scale_y_continuous(limits = c(lim[3],lim[4]), expand = c(0, 0),
			    breaks=as.vector(p$y[,1]), labels=p$y[,2])
	}else	gg<-definePlotBoundary(gg)

	return(gg)
}


require(Hmisc)

epicurve <- function(slct,tmvec){
  tm <- (0:max(tmvec))
  tmsel <- tmvec[slct]
  epic <- array(NA,dim=c(length(tm),2))
  for(k.tm in 1:length(tm)){
    sel <- which(tmsel==tm[k.tm])
    epic[k.tm,] <- c(tm[k.tm],length(sel))
  }
  return(epic)
}

reprnum <- function(pmat){
  csum <- rep(NA,dim(pmat)[2])
  for(k.col in 1:dim(pmat)[2]) csum[k.col] <- sum(pmat[,k.col])
  return(csum)
}

rbytime <- function(slct,pmat,tmvec){
  rbycol <- reprnum(pmat)[slct]
  tmsel <- tmvec[slct];
  tm <- unique(tmvec)
  rbyt <- array(NA,dim=c(length(tm),5))
  for(k.tm in 1:length(tm)){
    sel <- which(tmsel==tm[k.tm])
    rbyt[k.tm,1] <- tm[k.tm]
    rbyt[k.tm,2:4] <- quantile(rbycol[sel],c(0.025,0.5,0.975))
    rbyt[k.tm,5] <- mean(rbycol[sel],na.rm = T)
  }
  return(rbyt)
}

# r.est <- rbytime(rep(TRUE,length(timedata)),pmpmat,timedata)
#this is the code you can truncate 5 recent days of Rt;
#r.est[(length(r.est[,1])-4):length(r.est[,1]),2:4] <- NA

# pdf(paste("./",ver,"/output/","Rgraph_",k.county,".pdf",sep=""))
# par(mfrow=c(2,1),mar=c(2,4,6,0))
# epic <- epicurve(rep(TRUE,length(timedata)),timedata)
# barplot(epic[,2],names.arg=epic[,1],xaxt="n",ylab="nr cases",main=paste0(k.county))
# par(mar=c(8,4,0,0))
# errbar(r.est[,1],r.est[,3],r.est[,4],r.est[,2],
#        xlab="",ylab="Reff",xaxt = "n",ylim=c(0,10))
# axis(1, at=0:(length(seq(min(timedata),max(timedata),by=1))-1),
#      labels=as.Date(min(time):max(time),origin="1970-01-01"),las=2)
# abline(h=1,lty=2)
# mtext(side=1, text="date", line=6)
# dev.off()

out.res <- matrix(NA, nrow = 0, ncol = 6)
for(k in unique(unitdata)){
  r.est <- rbytime(unitdata==k,pmpmat,timedata)
  out.res <- rbind(out.res, cbind(r.est[,1]+min(time),r.est[,2:5],rep(counties[k],length(r.est[,1]))))
  pdf(paste("./output/","Rgraph_",counties[k],".pdf",sep=""))
  par(mfrow=c(2,1),mar=c(2,4,6,0))
  epic <- epicurve(unitdata==k,timedata)
  barplot(epic[,2],names.arg=epic[,1],xaxt="n",ylab="nr cases",main=paste0(counties[k],", n=",sum(unitdata==k)))
  par(mar=c(8,4,0,0))
  errbar(r.est[,1],r.est[,3],r.est[,4],r.est[,2],
         xlab="",ylab="Reff",xaxt = "n",ylim=c(0,10))
  axis(1, at=0:(length(seq(min(timedata),max(timedata),by=1))-1),
       labels=as.Date(min(time):max(time),origin="1970-01-01"),las=2)
  abline(h=1,lty=2)
  mtext(side=1, text="date", line=6)
  dev.off()
}
out.res <- data.frame(out.res)
names(out.res) <- c("date onset","q2.5","median","q97.5","mean","county")
out.res$`date onset` <- as.numeric(as.character(out.res$`date onset`))
out.res$q2.5 <- as.numeric(as.character(out.res$q2.5))
out.res$q97.5 <- as.numeric(as.character(out.res$q97.5))
out.res$median <- as.numeric(as.character(out.res$median))
out.res$mean <- as.numeric(as.character(out.res$mean))

save(out.res,file = paste("./output/res",ind.county,".rda",sep=""))


library(contextual)
horizon <- 500
simulations <- 1000
ProbClick <- c(0.1, 0.3, 0.7)

bandit <- BasicBernoulliBandit$new(weights = ProbClick)

policy <- EpsilonGreedyPolicy$new(epsilon = 0.1)

agent <- Agent$new(policy,bandit)

simulator <- Simulator$new(agent, horizon, simulations, do_parallel = FALSE)

history <- simulator$run()

plot(history, type = "average", regret = TRUE, lwd = 2, legend_position = "topright")

plot(history, type = "cumulative", regret = TRUE, rate = TRUE, lwd = 2,legend_position = "topright")

plot(history, type = "arms", legend_position = "topright")


#' @name bc
#' @aliases jaccard
#' @title Compute dissimilarity indices
#' @param comm Community matrix giving sites (rows) by species (columns); values are abundances. Column and row labels are highly recommended
#' @return Site by site dissimilarity matrix
#' @rdname bc
#' @export
bc <- function(comm)
{
	# get min abundance of shared species
	# pretty slow right now because it uses nested applies
	# a fast way to do this would be great
	shared_abundance <- apply(comm, 1, function(site1) {
		apply(comm, 1, function(site2) {
			mask <- site1 <= site2
			sum((site1 * mask) + ((!mask) * site2))
		})
	})

	# total abundance at each site for each pairwise combo
	site1 <- matrix(rowSums(comm), nrow=nrow(comm), ncol=nrow(comm))
	site2 <- t(site1)

	1.0 - ((2.0 * shared_abundance)/(site1 + site2))
}

#' @rdname bc
#' @export
jaccard <- function(comm)
{
	# get the intersection of all sites - number of sp in common
	site_similarity <- comm %*% t(comm)
	richness <- rowSums(comm)
	# make richness matrices for comparisons
	ra <- matrix(richness, nrow=length(richness), ncol=length(richness))
	1 - (site_similarity / (ra + t(ra) - site_similarity))
}

#' Compute a dataframe of environmental dissimilarity values
#'
#' @param x A data frame of environmental covariates.
#' @param sites Either a vector of site names or a column index (or column name) giving the location of the site names
#'              in x. If 0, row names will be used; if rownames are missing rows will be numbered
#' @param sitenames Boolean; should site names be returned with the data frame?
#' @return A data frame including both sites' names, environmental dissimilarity between the two sites, and midpoints
#'         between the two sites for each variable
#' @export
env_dissim <- function(x, sites = 0, sitenames = TRUE) {
	if(length(sites) == nrow(x)) {
		rownames(x) <- sites
	} else if(sites != 0) {
		rownames(x) <- x[,sites]
		x <- x[,-sites]
	}
	if(all(is.null(rownames(x))))
		rownames(x) <- 1:nrow(x)

	if(is.null(colnames(x)))
		colnames(x) <- paste0("var", seq_len(ncol(x)))

	midpoints <- apply(x, 2, function(v) {
		mat <- sapply(v, function(x) (x+v)/2)
		mat[lower.tri(mat)]
	})
	distance <- as.vector(dist(x))
	covars <- as.data.frame(cbind(distance, midpoints))
	colnames(covars) <- c('distance', colnames(x))
	if(sitenames)
	{
		nms <- t(do.call(cbind, sapply(1:(nrow(x) - 1), function(i) {
			sapply((i+1):nrow(x), function(j) {
				c(rownames(x)[i], rownames(x)[j])
			})
		})))
		covars$site1 <- nms[,1]
		covars$site2 <- nms[,2]
	}
	covars
}


#Calculate delta(SNP Index)

#' @title Calculate delta(SNP index)
#' @description This function is used to calculate the ∆(SNP-index) by subtracting the SNP-index value of the wild-type bulk from the SNP-index value of the mutant bulk.
#'
#' \deqn{mean_M_SNPindex - mean_WT_SNPindex.WT}
#'
#' @param SNPindex.windows data frame obtained after running the slidingWindow()function
#'
#' @return Data frame containing start, mid and stop positions of each window in the chromosome, as well as the corresponding mean SNP-index value for each bulk and ∆(SNP-index)value.
#'
#' @details For each row in the data frame returned by slidingWindow(), corresponding to a different window, ∆(SNP-index) is calculated by subtracting the SNP-index value of the reference bulk to the SNP-index value of the mutant bulk.
#' The values of ∆(SNP-index)ineach window are added to the data frame as a new column.
#'
#' @importFrom dplyr %>%
#' @export calc_deltaSNPindex
#' @examples
#' deltaSNPindex_windows <- calc_deltaSNPindex(SNPindex.windows=SNPindex_windows)

calc_deltaSNPindex <- function(SNPindex.windows) {

  #Calculate delta SNP-index and add it as new column
  deltaSNPindex.windows <- SNPindex.windows %>% dplyr::mutate("delta_SNPindex" = (mean_SNPindex.M - mean_SNPindex.WT))
  return(deltaSNPindex.windows)
}


#########################################################################
# Data-generating mechanism

# First-stage regression coefficients
.alpha0_j <- function(pz, a, s.j) {
  S.j <- sample(1:pz, size = s.j, replace = FALSE)
  alpha0.j <- numeric(pz) %>%
  { .[S.j] <- a; . }
  alpha0.j
}

# ... - arguments to alpha0_j:
#   pz, a, sj.min, sj.max
.Alpha0 <- function(px, pz, a, s.j) {
  Alpha0 <- map(1:px, ~ { .alpha0_j(pz, a, s.j) }) %>%
    reduce(cbind) %>%
    { dimnames(.) <- NULL; . }
  Alpha0
}

# Second-stage regression coefficients
.beta0 <- function(px, b, s_beta) {
  S_beta <- sample(1:px, size = s_beta, replace = FALSE)
  beta0 <- numeric(px) %>%
    { .[S_beta] <- b; .}
  beta0
}

# types: (1) "TZ" (Toeplitz), (2) "CS" (circulant-symmetic),
# (3) "ID" (identity), (4) "RN" (scaled Gram of m draws from multivariate-p Normal)
.Sigma_z <- function(pz, type, rho0 = .7, K = 5, m = 2*pz){
  if ( type == "TZ" ) {
    # TZ
    Sigma_z <- rho0^abs(outer(1:(pz), 1:(pz), "-"))
  } else if ( type == "CS" ) {
    # CS
    Sigma_z <- array(dim = c(pz, pz))
    for (j in 1:pz){
      for (k in j:pz){
        if (k == j){
          Sigma_z[j, k] <- 1
        }
        else if (( k %in% (j+1):(j+K)) || (k %in% (j+pz-K):(j+pz-1)) ){
          Sigma_z[j, k] <- .1
        }
        else {
          Sigma_z[j, k] <- 0
        }
      }
    }
    for (k in 1:pz){
      for (j in k:pz){
        Sigma_z[j, k] <- Sigma_z[k, j]
      }
    }
  } else if ( type == "EC" ) {
    # ...
  }
  Sigma_z
}

Sigma.uv. <- function(px, sigma0_v, sigma0_u) {
  r <- 5
  b <- sigma0_u*sigma0_v
  v <- c(.5*b, rep(.25*b, r-1), rep(.25*b, r), rep(.05*b, px-2*r)) %>%
    sample
  V <- diag(sigma0_v, px)
  Sigma_uv <- rbind(c(sigma0_u, v),
        cbind(v, V))
  dimnames(Sigma_uv) <- NULL
  Sigma_uv
}

# ... = sigma0_v, sigma0_u, cor_hv, corstr
.uV <- function(n, Sigma.uv) {
  # Sigma_hv <- .Sigma_hv(px, ...)
  uV <- rmvnorm(n, rep(0, ncol(Sigma.uv)), Sigma.uv)
  list(u = uV[,1], V = uV[,2:ncol(uV)])
}

.Sigma_z.Z <- function(n, pz, type, ...) {
  Sigma_z <- .Sigma_z(pz = pz, type = type, ...)
  Z <- rmvnorm(n, rep(0, pz), Sigma_z)
  list(Sigma_z = Sigma_z, Z = Z)
}

.D <- function(Z, Alpha0) { Z %*% Alpha0 }

# ... = sigma0_v, sigma0_u, cor_hv, corstr
.X.y <- function(D, beta0, Sigma.uv) {
  n <- nrow(D); px <- ncol(D)
  uV <- .uV(n, Sigma.uv)
  u <- uV$u; V <- uV$V;
  X <- D + V
  y <- X %*% beta0 + u
  list(X = X, y = y, V = V, u = u)
}

#########################################################################
# Generate observations

.obs <- function(config_id.) {
  configs <- read.csv("configs/configs.csv")
  config <- configs %>%
    filter(config_id == config_id.)

  Alpha0 <- read.table(paste("configs", config_id., "Alpha0", sep = "/")) %>%
    as.matrix %>%
    { dimnames(.) <- NULL; . }
  beta0 <- read.table(paste("configs", config_id., "beta0", sep = "/")) %>%
    as.matrix %>%
    { dimnames(.) <- NULL; . }
  Sigma.uv <- read.table(paste("configs", config_id., "Sigma.uv", sep = "/")) %>%
    as.matrix %>%
    { dimnames(.) <- NULL; . }

  Sigma_z.Z <- .Sigma_z.Z(n = config$n, pz = config$pz, type = config$type)
  Sigma_z <- Sigma_z.Z$Sigma_z; Z <- Sigma_z.Z$Z
  D <- .D(Z, Alpha0)

  X.y <- .X.y(D, beta0, Sigma.uv = Sigma.uv)
  X <- X.y$X; y <- X.y$y

  obs <- list(y = y, X = X, Z = Z, D = D, u = X.y$u,
              sigma0_u = config$sigma0_u, sigma0_v = config$sigma0_v,
              beta0 = beta0, Sigma_z=Sigma_z, Alpha0=Alpha0)
  obs
}


#
# Example R program
#

# example from https://cran.r-project.org/web/packages/randomForest/randomForest.pdf

library(randomForest)

## Classification:
##data(iris)
set.seed(71)
iris.rf <- randomForest(Species ~ ., data=iris, importance=TRUE, proximity=TRUE)
print(iris.rf)

## Look at variable importance:
round(importance(iris.rf), 2)
## Do MDS on 1 - proximity:
iris.mds <- cmdscale(1 - iris.rf$proximity, eig=TRUE)
op <- par(pty="s")
pairs(cbind(iris[,1:4], iris.mds$points), cex=0.6, gap=0,
      col=c("red", "green", "blue")[as.numeric(iris$Species)],
      main="Iris Data: Predictors and MDS of Proximity Based on RandomForest")
par(op)
print(iris.mds$GOF)

## The `unsupervised' case:
set.seed(17)
iris.urf <- randomForest(iris[, -5])
MDSplot(iris.urf, iris$Species)

## stratified sampling: draw 20, 30, and 20 of the species to grow each tree.
(iris.rf2 <- randomForest(iris[1:4], iris$Species,
                          sampsize=c(20, 30, 20)))
## Regression:
## data(airquality)
set.seed(131)
ozone.rf <- randomForest(Ozone ~ ., data=airquality, mtry=3,
                         importance=TRUE, na.action=na.omit)
print(ozone.rf)

## Show "importance" of variables: higher value mean more important:
round(importance(ozone.rf), 2)

## "x" can be a matrix instead of a data frame:
set.seed(17)
x <- matrix(runif(5e2), 100)
y <- gl(2, 50)
(myrf <- randomForest(x, y))
(predict(myrf, x))

## "complicated" formula:
(swiss.rf <- randomForest(sqrt(Fertility) ~ . - Catholic + I(Catholic < 50),
                          data=swiss))
(predict(swiss.rf, swiss))

## Test use of 32-level factor as a predictor:
set.seed(1)
x <- data.frame(x1=gl(53, 10), x2=runif(530), y=rnorm(530))
(rf1 <- randomForest(x[-3], x[[3]], ntree=10))

## Grow no more than 4 nodes per tree:
(treesize(randomForest(Species ~ ., data=iris, maxnodes=4, ntree=30)))

## test proximity in regression
iris.rrf <- randomForest(iris[-1], iris[[1]], ntree=101, proximity=TRUE, oob.prox=FALSE)
str(iris.rrf$proximity)


library(cluster)
suppressPackageStartupMessages(library(factoextra))
suppressPackageStartupMessages(library(dendextend))
suppressPackageStartupMessages(library(ape))

# Abrimos el archivo csv que generamos del alineamiento
InputData  <- read.table("/Users/carlosmichelmourradiaz/Documents/alignment_scores2.csv", header = TRUE, sep = ",", quote="")

# Generamos un dataframe unicamente con los datos que nos interesan
datos <- data.frame(Sequence_1 = InputData$Sequence_1, Sequence_2 = InputData$Sequence_2, Dissimilarity = InputData$Dissimilarity)

# Funcion que genera la matriz de scores
Generate_Matrix <- function(datos,rows,cols,value2){
  num_rows <- length(rows)
  num_cols <- length(cols)
  total <- num_cols*num_rows
  mat <- matrix(1:total,nrow = num_rows, ncol = num_cols)
  rownames(mat) <- rows
  colnames(mat) <- cols

  # Recorrer los valores y rellenar la matriz
  for (row in rows){
    for (col in cols){
      index <- datos$Sequence_1 == row & datos$Sequence_2 == col
      if (length(datos$Dissimilarity[index]) > 0){
        mat[row,col] <- datos$Dissimilarity[index]
      }
      # Si no se encontro el alineamiento rellenar con un 0
      else{
        mat[row,col] <- value2
      }
    }

  }
  return(mat)
}

# Obtenemos los genes para las filas y columnas de la matriz
row_genes <- unique(datos$Sequence_1)
col_genes <- unique(datos$Sequence_2)

# Generamos la matriz
valores <- Generate_Matrix(datos,row_genes,col_genes,NA)

# hClust
ccom <- hclust(dist(valores), method = "complete")
csin <- hclust(dist(valores), method = "single")
cave <- hclust(dist(valores), method = "average")
cward <- hclust(dist(valores), method = "ward.D2")

# sacar los coeficientes de aglomeración de cada modelo de clustering
coeffcom <- coef(ccom)
coeffsin <- coef(csin)
coeffave <- coef(cave)
coeffward <- coef(cward)

# obtenemos los coeficientes de aglomeración
print("Complete")
coeffcom
print("Single")
coeffsin
print("Average")
coeffave
print("Ward")
coeffward

# Dendograma con complete
plot (ccom, hang = -1, main = "hclust Dendogram Complete")
cls3 <- cutree(ccom, k=3)

# plot de dendograma con single
plot (csin, hang = -1, main = "hclust Dendogram Single")
cls4 <- cutree(cave, k=3)

# plot de dendograma con average
plot (cave, hang = -1, main = "hclust Dendogram Average")
cls5 <- cutree(cave, k=3)

# Plot de dendograma con ward
plot (cward, hang = -1, main = "hclust Dendogram Ward")
cls6 <- cutree(cward, k=3)

# Guardar los dendogramas en formato tree
my_treecom <- as.phylo(ccom)
write.tree(phy=my_treecom, file="/Users/carlosmichelmourradiaz/Documents/complete_tree.tree")

my_treesin <- as.phylo(csin)
write.tree(phy=my_treesin, file="/Users/carlosmichelmourradiaz/Documents/single_tree.tree")

my_treecave <- as.phylo(cave)
write.tree(phy=my_treecave, file="/Users/carlosmichelmourradiaz/Documents/average_tree.tree")

my_treeward <- as.phylo(cward)
write.tree(phy=my_treeward, file="/Users/carlosmichelmourradiaz/Documents/ward_tree.tree")

# Agnes

# Generamos la matriz
valores2 <- Generate_Matrix(datos,row_genes,col_genes,0)

# Generamos los modelos de clustering con los diferentes metodos
aClustcom <- agnes(valores2, method = "complete")
aClustsin <- agnes(valores2, method = "single")
aClustave <- agnes(valores2, method = "average")
aClustward <- agnes(valores2, method = "ward")

# Observamos el dendograma generado con Agnes para el metodo complete
pltree(aClustcom, cex = 0.6, hang = -1, main = "agnes Dendrogram Complete")
aCoeffcom <- aClustcom$ac
rect.hclust(as.hclust(aClustcom), k = 6, border=2:4)
aCls3 <- cutree(as.hclust(aClustcom), k = 6)
fviz_cluster(list(data = valores2, cluster = aCls3))

# Observamos el dendograma generado con Agnes para el metodo single
pltree(aClustsin, cex = 0.6, hang = -1, main = "agnes Dendrogram Single")
aCoeffsin <- aClustsin$ac
rect.hclust(as.hclust(aClustsin), k=6, border=2:4)
aCls4 <- cutree(as.hclust(aClustsin), k = 6)
fviz_cluster(list(data = valores2, cluster = aCls4))

# Observamos el dendograma generado con Agnes para el metodo ward
pltree(aClustward, cex = 0.6, hang = -1, main = "agnes Dendrogram Ward")
aCoeffward <- aClustward$ac
rect.hclust(as.hclust(aClustward), k=6, border=2:4)
aCls6 <- cutree(as.hclust(aClustward), k = 6)
fviz_cluster(list(data = valores2, cluster = aCls6))

# Observamos los coeficientes de aglomeración
print("Complete")
aCoeffcom
print("Single")
aCoeffsin
print("Average")
aCoeffave
print("Ward")
aCoeffward


# INDIVIDUAL SITES
# - PCA and clustering for individual sites

# LIBRARIES ====================================================================
library(Momocs)

# DATA =========================================================================
# - load data, after elliptical Fourier transform
load("./Archive/Adzes/Dt.efProf")
load("./Archive/Adzes/Dt.efSide")
load("./Archive/Adzes/Dt.efTop")

# filter (need to unload tidyverse!)
VedProf <- filter(efProf, Lok == "Ved")
KraProf <- filter(efProf, Lok == "Kra")
KleProf <- filter(efProf, Lok == "Kle")
NitProf <- filter(efProf, Lok == "Nit")

VedSide <- filter(efSide, Lok == "Ved")
KraSide <- filter(efSide, Lok == "Kra")
KleSide <- filter(efSide, Lok == "Kle")
NitSide <- filter(efSide, Lok == "Nit")

VedTop <- filter(efTop, Lok == "Ved")
KraTop <- filter(efTop, Lok == "Kra")
KleTop <- filter(efTop, Lok == "Kle")
NitTop <- filter(efTop, Lok == "Nit")

# PCA
pcaLok <- function(pcaSlot, Type, LokName) {
  plot(PCA(pcaSlot), pos.shp = "xy", size.shp = 0.5,
       density = T, chull = F, chull.filled = F,
       title = sprintf("PCA %s: %s", Type, LokName), unit = T)
  }

pcaLok(VedProf, "prof", "Ved")
pcaLok(KraProf, "prof", "Kra")
pcaLok(KleProf, "prof", "Kle")
pcaLok(NitProf, "prof", "Nit")

pcaLok(VedSide, "side", "Ved")
pcaLok(KraSide, "side", "Kra")
pcaLok(KleSide, "side", "Kle")
pcaLok(NitSide, "side", "Nit")

pcaLok(VedTop, "top", "Ved")
pcaLok(KraTop, "top", "Kra")
pcaLok(KleTop, "top", "Kle")
pcaLok(NitTop, "top", "Nit")

# Clustering
clustLok <- function(Slot) {
  CLUST(PCA(Slot), type = "phylogram",
        dist_method = "maximum", hclust_method = "ward.D2")
}

pdf(file = "./Adzes/TreeVedProf.wardD2.pdf")
CLUST(PCA(VedProf), type = "phylogram", dist_method = "maximum", hclust_method = "ward.D2")
  rect(xleft = 4.5, ybottom = 17.6, xright = 5.8, ytop = 21.5, border = "red")
  rect(xleft = 4.5, ybottom = 12.6, xright = 5.8, ytop = 17.4, border = "green")
  rect(xleft = 4.5, ybottom = 8.6, xright = 5.8, ytop = 12.4, border = "blue")
  rect(xleft = 4.5, ybottom = 1.6, xright = 5.8, ytop = 3.5, border = "purple")
  text(x = 1, y = 20, labels = "Vedrovice (prof, Ward D2)")
dev.off()

pdf(file = "./Adzes/clustLokProf.pdf")
  layout(matrix(c(1,2,3,4), 2, 2, byrow = TRUE))
  clustLok(VedProf)
  clustLok(KraProf)
  clustLok(KleProf)
  clustLok(NitProf)
  title(sub = "Momocs::clust (Ward D2) Prof")
dev.off()

pdf(file = "./Adzes/clustLokSide.pdf")
  layout(matrix(c(1, 2, 3, 4), 2, 2, byrow = TRUE))
  clustLok(VedSide)
  clustLok(KraSide)
  clustLok(KleSide)
  clustLok(NitSide)
  title(sub = "Momocs::clust (Ward D2) Side")
dev.off()

pdf(file = "./Adzes/clustLokTop.pdf")
  layout(matrix(c(1, 2, 3, 4), 2, 2, byrow = TRUE))
  clustLok(VedTop)
  clustLok(KraTop)
  clustLok(KleTop)
  clustLok(NitTop)
  title(sub = "Momocs::clust (Ward D2) Top")
dev.off()

pdf(file = "./Adzes/clustLokVed.pdf", width = 12, height = 5)
layout(matrix(c(1,2,3), 1, 3, byrow = TRUE))
  clustLok(VedProf)
    title(sub = "Prof")
  clustLok(VedSide)
    title(sub = "Side")
  clustLok(VedTop)
    title(sub = "Top")
dev.off()

pdf(file = "./Adzes/clustLokKra.pdf", width = 12, height = 5)
layout(matrix(c(1,2,3), 1, 3, byrow = TRUE))
clustLok(KraProf)
title(sub = "Prof")
clustLok(KraSide)
title(sub = "Side")
clustLok(KraTop)
title(sub = "Top")
dev.off()

pdf(file = "./Adzes/clustLokKle.pdf", width = 12, height = 5)
layout(matrix(c(1,2,3), 1, 3, byrow = TRUE))
clustLok(KleProf)
title(sub = "Prof")
clustLok(KleSide)
title(sub = "Side")
clustLok(KleTop)
title(sub = "Top")
dev.off()

pdf(file = "./Adzes/clustLokNit.pdf", width = 12, height = 5)
layout(matrix(c(1,2,3), 1, 3, byrow = TRUE))
clustLok(NitProf)
title(sub = "Prof")
clustLok(NitSide)
title(sub = "Side")
clustLok(NitTop)
title(sub = "Top")
dev.off()

# the end
graphics.off()
rm(list = ls())
gc()
q("no")


library(randomForest)

set.seed(1433)

churn <- get(load("churn.RData"))
colnames(churn)

ind <- sapply(churn, is.numeric)
churn[ind] <- lapply(churn[ind], scale)

test_churn <- churn[4001:5000,]
churn <- churn[1:4000,]

drops <- c("state")
churn <- churn[,!(names(churn) %in% drops)]
test_churn <- test_churn[,!(names(test_churn) %in% drops)]

##################################################
# Forest 300 tree

(model.rf1 <- randomForest (churned ~ ., data=churn, ntree=300, proximity=FALSE))
plot(model.rf1)
pred.rf1 <- predict (model.rf1, test_churn, type="class")

# test error
(ct <- table(Truth=test_churn$churned, Pred=pred.rf1))

prop.table(ct, 1)
sum(diag(ct))/sum(ct)
round(100*(1-sum(diag(ct))/sum(ct)),2)

##################################################
# Forest 50 tree

(model.rf1 <- randomForest (churned ~ ., data=churn, ntree=50, proximity=FALSE))
plot(model.rf1)
pred.rf1 <- predict (model.rf1, test_churn, type="class")

# test error
(ct <- table(Truth=test_churn$churned, Pred=pred.rf1))

prop.table(ct, 1)
sum(diag(ct))/sum(ct)
round(100*(1-sum(diag(ct))/sum(ct)),2)


# Simon attempt to add DEM data to DairyBase file using raster
# Note: raster package can work with data on disk (doesn't need to be in memory)

rm(list=ls()) # remove all variables

library(tidyverse)
library(cowplot) # applies to all plots
library(sf)
library(raster) # see http://neondataskills.org/R/Raster-Data-In-R/
library(elevatr) # access DEM data

# functions
ensnakeify <- function(x) {
  x %>%
    iconv(to="ASCII//TRANSLIT") %>% # remove accents
    str_replace_na() %>% # convert NA to string
    str_to_lower() %>% # convert to lower case
    str_replace_all(pattern="[^[:alnum:]]", replacement=" ") %>% # convert non-alphanumeric to space
    str_trim() %>% # trim leading and trailing spaces
    str_replace_all(pattern="\\s+", replacement="_") # convert remaining spaces to underscore
}

# define coordinate systems
nztm2000string <- "+proj=tmerc +lat_0=0 +lon_0=173 +k=0.9996 +x_0=1600000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
wgs84string <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"

#### read dairybase data ####
file_name <- "DairyBaseForPowerBIsoils.csv"
farms <- read_csv(file_name, na=c("","NaN","NA"), col_types=cols(Concatbest="c")) # force "Concatbest" to chr
names(farms) <- ensnakeify(names(farms))
farms <- st_as_sf(farms, coords=c("long", "lat"), remove=FALSE, crs=wgs84string) # create sf dataframe
ggplot() +
  labs(title="Farms") +
  coord_sf() + # ensures consistent projection
  geom_sf(data=farms, mapping=aes(color=as.factor(district_council)), size=0.1) # size < 1 doesn't work

# choose some farms and then get the relevant DEM data from Amazon
# https://cran.r-project.org/web/packages/elevatr/vignettes/introduction_to_elevatr.html
sub_farms <- farms %>%
  filter(district_council==20)
  # filter((long>175) & (long<176) & (lat< -37) & (lat>-38))
sub_farms_sp <- as(sub_farms$geometry, "Spatial")
sub_dem <- get_elev_raster(sub_farms_sp, z=10, src="aws") # about 100 m resolution
plot(sub_dem)
points(sub_farms_sp)

# raster package for handling grided data
# aster_dem <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_dem.tif" # Hamilton-Hauraki Area, 25Mb (WGS84 longlat)
# DEM <- raster(aster_dem)
# projection(DEM) # it's in wgs84 (longlat)
# plot(DEM, main="Hamilton-Hauraki DEM")

slope <- terrain(sub_dem, opt="slope", unit="degrees") # can handle long-lat-metres
plot(slope, main="Hamilton-Hauraki Slope")
points(sub_farms_sp)

aspect <- terrain(sub_dem, opt="aspect", unit="degrees") # can handle long-lat-metres
plot(aspect, main="Hamilton-Hauraki Aspect")
points(sub_farms_sp)

# extract data
sub_farms$slope  <- raster::extract(slope, sub_farms_sp)
sub_farms$aspect <- raster::extract(aspect, sub_farms_sp)


# load data
depdata = read.csv("C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\dependencies\\dependencydone_copadded.csv")

depdata$positive = as.numeric(depdata$positive)
depdata$negative = as.numeric(depdata$negative)
depdata$functional = as.numeric(depdata$functional)
depdata$structural = as.numeric(depdata$structural)
depdata$descriptive = as.numeric(depdata$descriptive)
depdata$instruction = as.numeric(depdata$instruction)
depdata$interCLT = as.numeric(depdata$interCLT)
depdata$other = as.numeric(depdata$other)

library(sqldf)
relstat = sqldf("select relation, sum(positive) as npositive, count(*)  as nobs from depdata group by relation")

# Compute population statistic
prc.positive.total <- sum(relstat$npositive) / sum(relstat$nobs)

expected.positive <- relstat$nobs * prc.positive.total

delta.positive <- relstat$npositive - expected.positive

# The standard deviation of a binomial variable
std.deviation <- sqrt(relstat$nobs * prc.positive.total * (1 - prc.positive.total))

relstat$z.score <- delta.positive / std.deviation

relstat$prc.positive = relstat$npositive/relstat$nobs

relstat$prc.negative = (relstat$nobs-relstat$npositive)/relstat$nobs

write.table(relstat, "C:\\Users\\gaya\\prog\\workspace\\TutorialRecommender\\tutorials\\dependencies\\Probs\\relstat.csv", sep=",")


# Get OSAVI and LSWI indices from the composited raster
# Then merge everything (and NDVI) into one file
# Also extract the water mask out of the QC
# Can't merge radiometry and indices due to different data type
library(raster); source("utils/set-temp-path.r")
source("utils/GetProbaVQCMask.r")

Dir = "../../userdata/indices-no-na/"
#SemiCleanDir = "../../userdata/semicleaned/"
Radiometry = brick(paste0(Dir, "composite.tif"))
OSAVI = overlay(Radiometry, fun=function(RED, NIR, BLUE, SWIR){return(1.16 * ((NIR-RED)/(NIR+RED+0.16)))},
    datatype="FLT4S", filename=paste0(Dir, "OSAVI.tif"), overwrite=TRUE, progress="text",
    options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))
LSWI = overlay(Radiometry, fun=function(RED, NIR, BLUE, SWIR){return((NIR-SWIR)/(NIR+SWIR))},
    datatype="FLT4S", filename=paste0(Dir, "LSWI.tif"), overwrite=TRUE, progress="text",
    options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"))

# Do not add NDVI because it's colinear with OSAVI

# This should be the same as max(NDVIs), but just to make sure follow the same procedure
#NDVIs = stack(list.files(paste0(SemiCleanDir, "ndvi/"), pattern=glob2rx("*NDVI*.tif"), full.names = TRUE))
#SummerNDVIs = subset(NDVIs,
#    which(names(NDVIs) == "PROBAV_S5_TOC_X20Y01_20160601_100M_V001_NDVI_sm"):
#        which(names(NDVIs) == "PROBAV_S5_TOC_X20Y01_20160826_100M_V001_NDVI_sm"))
#MaxNDVI = raster(paste0(Dir, "maxndvi.tif"))
#NDVI = stackSelect(SummerNDVIs, MaxNDVI, datatype="FLT4S", filename=paste0(Dir, "ndvi_composite.tif"),
#    overwrite=TRUE, progress="text")
#Everything = stack(OSAVI, LSWI)
#Everything = writeRaster(Everything, datatype="FLT4S", filename=paste0(Dir, "indices.tif"), overwrite=TRUE,
#    progress="text")
#plotRGB(Everything)

QCExample = raster("/data/MTDA/TIFFDERIVED/PROBAV_L3_S5_TOC_100M/2015/20150616/PROBAV_S5_TOC_20150616_100M_V101/PROBAV_S5_TOC_X20Y01_20150616_100M_V101_SM.tif")
WaterQC = GetProbaVQCMask(land = FALSE)
SelectWater = function(x)
{
    return(x %in% WaterQC)
}
WaterMask = calc(QCExample, fun=SelectWater)
WaterMask = writeRaster(WaterMask, datatype = "INT1U", filename = paste0(Dir, "watermask.tif"),
    options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4", "NBITS=1"))


#############################################
# MCMC Algorithm Shell
#############################################

# Define a single iteration of the MH within Gibbs sampler
blocked.mcmc.update <- function(U.data, cur){
        cur <- sample.th(U.data, cur)
        cur <- sample.a(U.data, cur)
        cur <- sample.b(U.data, cur)
        cur <- sample.s2(U.data, cur)
        return(cur)
}

# MCMC Chain Update
run.chain.2pl <- function(M.burnin, M.keep, M.thin, U.data, hyperpars,
                          th.init, a.init, b.init, s2.init,
                          MH.th, MH.a, MH.b, verbose = FALSE){
        # Define and initialize the list of things to keep track of in the current state of the chain
        cur <- list(th = th.init, a = a.init, b= b.init, s2 = s2.init,
                    hyperpars = hyperpars,
                    MH = list(th = MH.th, a = MH.a, b = MH.b),
                    ACC = list(th = 0, th.n = 0, a = 0, a.n = 0, b = 0, b.n = 0))

        # Define matrix to store MCMC results ...
        chain.keep <- matrix(NA, ncol = M.keep,
                             nrow = length(th.init) + length(a.init)
                             + length(b.init) + length(s2.init))
        rownames(chain.keep) <- c(paste('theta.abl', 1:length(th.init)),
                                  paste('a.disc', 1:length(a.init)),
                                  paste('b.diff', 1:length(b.init)),
                                  'sigma.theta')

        # Burnin phase : do not keep these results
        if(M.burnin > 0){
                for (ii in 1:M.burnin) {
                        cur <- blocked.mcmc.update(U.data, cur)
                }
        }

        # Converged phase: Keep these results after thinning
        for (m in 1:M.keep) {
                # Skip the thinned pieces of the chain
                if (M.thin > 1) {
                        for (ii in 1:(M.thin-1)) {
                                cur <- blocked.mcmc.update(U.data, cur)
                        }
                }
                # Generate a kept update and save its results
                cur <- blocked.mcmc.update(U.data, cur)
                chain.keep[,m] <- c(cur$th, cur$a, cur$b, cur$s2)

                if(m %% 100 == 0){
                        print(m)
                        # Adaptive tuning would go here
                }
        }

        if (verbose) {
                cat(paste("Average acceptance rates:",
                          "\n theta.abl:", round(cur$ACC$th / cur$ACC$th.n, 3),
                          "\n a.disc:   ", round(cur$ACC$a  / cur$ACC$a.n, 3),
                          "\n b.diff:   ", round(cur$ACC$b  / cur$ACC$b.n, 3),
                          "\n"))
        }
        return(chain.keep)
}


library("xml2")
library("dplyr")
library("stringr")
library("rlist")
library("xts")
library("quantmod")
library("PortfolioAnalytics")
library("DEoptim")
library("ROI")
require("ROI.plugin.glpk")
require("ROI.plugin.quadprog")

weights<-function(ins) {
    ### Read data from last milestone
    #setwd("C:/Users/EDZ/Desktop/理享�?/Portfolio_Proj") #can be specified
    data = read.csv("complete.csv",header = TRUE, sep=",", na.strings = "")
    seven_data = data[,52:53]
    #data = final_fund_all

    #Number of funds in the final portforlio, can be specified
    portfolio_num = 5
    fund_num = portfolio_num*10

    fund_num_tmp = floor(fund_num/10)
    fund_num_upper = fund_num_tmp * ins
    if(ins == 10)
    {
        fund_num_upper = fund_num
    }
    selected <- data[,(fund_num_tmp*(ins-1)+1+1):(fund_num_upper+1)] #first plus one�? begin with 6-10; second plus one: first column of data is date
    selected <- cbind(data[,1],selected)
    print(selected)
    data <- selected

    data_print_out <- data
    data_print_out <- cbind(data_print_out,seven_data)
    #print(rownames(data))
    #date_tmp = as.Date(rownames(data),format="%Y-%m-%d")
    #data = cbind(date_tmp,data)

    ### Construct the system by Markowitz model
    #Initialization
    rows = nrow(data)
    returns_tmp = c()
    return_tmp = data.frame()

    for (j in 1:portfolio_num){
        data_tmp <- data.frame(data[,1],data[,j+1])
        data_tmp <- xts(data_tmp[,2],as.Date(data_tmp[,1]))
        return_tmp <- periodReturn(data_tmp,period="daily",type="log")
        returns_tmp <- cbind(returns_tmp,return_tmp)
    }

    returns <- returns_tmp[,1:5]
    rownames(returns) <- data[,1]
    colnames(returns) <- c("fd1", "fd2", "fd3", "fd4","fd5")
    funds <- colnames(returns)
    init <- portfolio.spec(assets = funds)
    init <- add.constraint(portfolio=init, type="leverage",min_sum=1.00, max_sum=1.00)
    init <- add.constraint(portfolio=init, type="box", min=0.10, max=0.40)
    #print.default(init)

    #6.3 Minimize variance with ROI
    minvar <- add.objective(portfolio=init, type="risk", name="var")
    opt_minvar <- optimize.portfolio(R=returns, portfolio=minvar, optimize_method="ROI", trace=TRUE)
    #print(opt_minvar)
    #plot(opt_minvar, risk.col="StdDev", return.col="mean", main="Minimum Variance Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

    w = extractWeights(opt_minvar)
    data_print_out_final = rbind(data_print_out,w)
    return_data = data_print_out_final[,-1]
    write.csv(return_data,"weight.csv",na="")
    return_data = rbind(colnames(return_data),return_data)
    return (return_data)
}


normalize = function(x){
    normX = (x - mean(x)) / sqrt(var(x))
    }

#### Get/Parse Arguments ####
Args = commandArgs()
inputFC = sub(".shp", "", Args[5], ignore.case = TRUE)
outputFC = sub(".shp", "", Args[6], ignore.case = TRUE)
numClusters = as.integer(Args[7])
clusterMethod = Args[8]
fields = Args[9]
useLocation = as.integer(Args[10])
scriptDir = Args[11]
useFields = FALSE

#### Create Field Names is Applicable ####
if (fields != "NA"){
    varNames = strsplit(fields, ";")
    varNames = c(unlist(varNames))
    useFields = TRUE
    }

#### Import the Cluster Library ####
print("Loading Libraries....")
# include the core clust function from clustTools
clust.include <- paste(sep="/", scriptDir, "clust.R")
source(clust.include)

#### Using Maptools For Shapefiles ####
library(maptools)

print("Begin Calculations....")
shp = readShapePoints(inputFC)
centroids = coordinates(shp)

#### Create Boolean For Using Location ####
#### Set to True: if useLocation requested or no fields provided ####
noFields = (useFields == FALSE)
addLocation = (useLocation | noFields)

#### Add Locations ####
if (addLocation){
    XCOO = normalize(centroids[,1])
    YCOO = normalize(centroids[,2])
    allVars = cbind(XCOO, YCOO)
    } else {
    allVars = NULL
    }

#### Add Fields ####
if (useFields){
    for (i in 1:length(varNames)){
        allVars = cbind(allVars, normalize(shp[[varNames[i]]]))
        }
    }

#### Create Data Frame for Analysis ####
new = data.frame(allVars)

#### Run Algorithm ####
newCL = clust(new, k = numClusters, method = clusterMethod)

#### Write Output to New FC ####
shp$CLUSTER = newCL$cluster
writeSpatialShape(shp, outputFC)

#### Print Output Summary ####
print(newCL)
delim = paste(rep('-', 55), collapse = "")
print(delim)
print(names(newCL))
print(delim)
print(delim)
print("Centers")
print(newCL$centers)
print(delim)
print(delim)
print(newCL$valMeasures)
print(delim)

print("Calculations Complete...")


drawGeneCovarHeatMap	<- function( seuratObj , heatMapHeight, heatMapWidth){

# This snippet makes a heatmap of gene covariation matrix.
# written by Vsevolod J. Makeev 2017 - 2021
# inspired by GitHub code of hrbrmstr in hrbrmstr/viridis_chords.R

require( ComplexHeatmap)
require( circlize)
require( viridis)
require( proxy)

heatMapGenes	<- rownames( seuratObj@data)
covar <- cor(t(seuratObj@data))

nCol		<- 1024

colPanelFun	 = colorRamp2( quantile( covar, seq(0, 1, by = 1/(nCol - 1))), viridis( nCol))

hMap		<- Heatmap( 	covar,
			name 	= "gene covariance",
			width 	= unit( heatMapWidth,  "inches"),
			height 	= unit( heatMapHeight, "inches"),
			heatmap_legend_param = list(
				title = "gene covar",
				legend_height = unit( 2, "inches"),
				grid_width = unit( 0.5, "inches"),
				title_gp = gpar( fontsize = 16, fontface = "bold")
						),
			col	=  colPanelFun,
			cluster_columns = TRUE,
			cluster_rows = TRUE,
			show_column_names = TRUE,
			row_names_gp = gpar(fontsize = 16),
			column_names_gp = gpar(fontsize = 16),
			clustering_distance_rows = function(x) dist( x, method = "cosine", pairwise = TRUE),
			clustering_distance_columns = function(x) dist( x, method = "cosine", pairwise = TRUE),
			use_raster = TRUE, raster_device = "png"
			)

return( hMap)

}


sq=function(no,vect,mat)
{
  sqr=no*no
  if(dim(mat)[2]!=length(vect))
  {
    stop("Can't multiply")
  }
  vari=vect*mat
  res=vari*sqr
  ret=list(sqr,vari,res)
  return(ret)
}
main=function()
{
  vect=c(1:3)
  mat=matrix(c(1:9),3,3,byrow = TRUE)
  var=5
  total=sq(var,vect,mat)
  print(total)
}

debug(main)
main()


#### Calculate Topographic Relief Alteration
#### Christopoulos Konstantinos
### Load Required Packages
 ## Ipak Function by Steven Worthington
  # https://gist.github.com/stevenworthington
ipak <- function(pkg){
    new.pkg <- pkg[!(pkg %in% installed.packages()[, "Package"])]
    if (length(new.pkg))
        install.packages(new.pkg, dependencies = TRUE)
    sapply(pkg, require, character.only = TRUE)
}

ipak(c("raster","SDMTools","maptools","scatterplot3d"))

#########################################################
#########################################################
### DATA
 ## CHANGE THESE:
  # FROM HERE
setwd("C:/") # Path with files here
Initial_State <- raster("state_0") # Initial Raster
Final_State <- raster("state_1") # Final Raster
Boundaries <-  readShapePoly("boundary.shp") # Boundary Raster
  # TO HERE
#########################################################
#########################################################

### Collect required spatial data
state_0 <- Initial_State
state_1 <- Final_State
slope_state_0 <- terrain(state_0, opt='slope', unit='degrees', neighbors=8)
slope_state_1 <- terrain(state_1, opt='slope', unit='degrees', neighbors=8)
aspect_state_0 <- terrain(state_0, opt='aspect', unit='degrees', neighbors=8)
aspect_state_1 <- terrain(state_1, opt='aspect', unit='degrees', neighbors=8)

elevation_points_0 <- rasterToPoints(state_0)
elevation_points_1 <- rasterToPoints(state_1)
slope_points_0 <- rasterToPoints(slope_state_0)
slope_points_1 <- rasterToPoints(slope_state_1)
aspect_points_0 <- rasterToPoints(aspect_state_0)
aspect_points_1 <- rasterToPoints(aspect_state_1)

data_elev <- as.data.frame(cbind(elevation_points_0, elevation_points_1[,3]))
colnames(data_elev) <-c("x","y","state_0","state_1")
data_slope <- as.data.frame(cbind(slope_points_0, slope_points_1[,3]))
colnames(data_slope) <-c("x","y","state_0","state_1")
data_aspect <- as.data.frame(cbind(aspect_points_0, aspect_points_1[,3]))
colnames(data_aspect) <-c("x","y","state_0","state_1")

### Plots
 ## Raster Elevation
  # Fig.1
par(mfrow = c(1,2))
plot(state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)
contour(state_0, add = T)

plot(state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)
contour(state_1, add = T)

 ## Raster Slope
  # Fig.2
par(mfrow = c(1,2))
plot(slope_state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)

plot(slope_state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)

 ## Raster Aspect
  # Fig.3
par(mfrow = c(1,2))
plot(aspect_state_0,
     main = "Initial State",
     xlab = "", ylab = "")
lines(Boundaries, col = "red", lwd = 2)

plot(aspect_state_1,
     main = "Final State")
lines(Boundaries, col = "red", lwd = 2)

 ## Elevation Comparison
  # Fig.4
par(mfrow = c(1,2))
scatterplot3d(
  data_elev$x, data_elev$y, data_elev$state_0,
  color = "darkgreen", pch = ".",
  col.axis = "blue", col.grid = "lightblue",
  xlab = "X", ylab = "Y", zlab = "Z",
  main = "Initial State"
)
scatterplot3d(
  data_elev$x, data_elev$y, data_elev$state_1,
  color = "red", pch = ".",
  col.axis = "blue", col.grid = "lightblue",
  xlab = "X", ylab = "Y", zlab = "Z",
  main = "Final State"
)

  # Fig.5
par(mfrow = c(1,1))
plot(
  data_elev$state_0,data_elev$state_1,
  pch = 0, cex = 0.2, col = "red2",
  main = "Elevation Comparison #2",
  xlab = "Initial State Elevation (m)",
  ylab = "Final State Elevation (m)",
  xlim = c(60,180),ylim = c(60,180)
)
abline(0, 1, lwd = 1, col = "blue")

  # Fig.6
plot(
  data_elev$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Elevation Comparison #3",
  xlab = "Index",
  ylab = "Elevation (m)",
  ylim = c(50,185)
)
points(data_elev$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_elev$state_0 ~ poly(seq(1,nrow(data_elev)), 3, raw = TRUE))
mdl_2 = lm(data_elev$state_1 ~ poly(seq(1,nrow(data_elev)), 3, raw = TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

  # Fig.7
plot(
  data_elev$state_1 - data_elev$state_0,
  pch = "x", cex = 0.8, col = "gray25",
  main = "Elevation Comparison #4",
  xlab = "Index",
  ylab = "Δ Elevation = Final - Initial (m)"
)

   # Volume Difference
volume <-
  sum((data_elev$state_1 - data_elev$state_0) * (xres(state_0) * yres(state_0)))
add_text <- sprintf("The Volume Difference is: %s", volume, "m^3")
mtext(paste(
  "The Volume Difference is: ",round(volume, digits = 0), "cubic meters"
),
col = "red")

 ## Slope Comparison
  # Fig.8
plot(
  data_slope$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Slope Comparison",
  xlab = "Index",
  ylab = "Slope (Deg)",
  ylim = c(0,50)
)
points(data_slope$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_slope$state_0 ~ poly(seq(1,nrow(data_slope)), 3, raw = TRUE))
mdl_2 = lm(data_slope$state_1 ~ poly(seq(1,nrow(data_slope)), 3, raw = TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

 ## Aspect Comparison
  # Fig.9
plot(
  data_aspect$state_0,
  pch = ".", cex = 1.2, col = "darkgreen",
  main = "Aspect Comparison",
  xlab = "Index",
  ylab = "Aspect (Deg)",
  ylim = c(0,360)
)
points(data_aspect$state_1, pch = ".", cex = 1.2, col = "red2")
mdl_1 = lm(data_aspect$state_0 ~ poly(seq(1,nrow(data_aspect)), 3, raw =
                                        TRUE))
mdl_2 = lm(data_aspect$state_1 ~ poly(seq(1,nrow(data_aspect)), 3, raw =
                                        TRUE))
lines(predict(mdl_1), lwd = 2, col = "darkgreen")
lines(predict(mdl_2), lwd = 2, col = "red2")

### Remove unwanted variables from memory
rm(list=ls()[! ls() %in% c("data_elev", "data_slope", "data_aspect")])

### Calculate Indexes for DoTRA
 ## Landform Index (LI)
var_elev_0 <- var(data_elev$state_0)
var_elev_1 <- var(data_elev$state_1)
cov_elev <- cov(data_elev$state_0,data_elev$state_1)

LI <- (var_elev_0 + var_elev_1 - 2 * cov_elev) /
      (var_elev_0 + var_elev_1)

LI <- round(LI, digits=2)

 ## Altitude Index (AI)
Δ_mean_elev <- mean(data_elev$state_0) - mean(data_elev$state_1)

Δ_elev_0_mean_elev_2 <- (data_elev$state_0 -
						 mean(data_elev$state_0))**2
Δ_elev_1_mean_elev_2 <- (data_elev$state_0 -
						 Δ_mean_elev -
						 mean(data_elev$state_0))**2

AI <- (sqrt(sum(Δ_elev_1_mean_elev_2)) /
       sqrt(sum(Δ_elev_0_mean_elev_2)) - 1) * 100

AI <- round(AI, digits=0)

 ## Slope Index (SI)
Δ_slope <- data_slope$state_0 - data_slope$state_1
Δ_slope_abs_90 <- abs(Δ_slope)/90

SI <- mean(Δ_slope_abs_90)

SI <- round(SI, digits=2)

 ## Aspect Index (AsI)
reduct360to180 <- function(x) {
    ifelse(x < 180, x, x-360)
}

reduct360to180_aspect_0 <- reduct360to180(data_aspect$state_0)
reduct360to180_aspect_1 <- reduct360to180(data_aspect$state_1)

Δ_red360to180_aspect <- abs(reduct360to180_aspect_0 - reduct360to180_aspect_1)

reduct360to180_2 <- function(x) {
    ifelse(x < 180, x, 360-x)
}

red360to180_Δ_red360to180_aspect <- reduct360to180_2(Δ_red360to180_aspect)

AsI <- mean(red360to180_Δ_red360to180_aspect/180)

AsI <- round(AsI, digits=2)

 ## Category of Landform Index (LI_c)
if (0<=LI & LI<=0.15){
    LI_c <- "Class 1"
	} else if (0.16<=LI & LI<=0.25){
	LI_c <- "Class 2"
	} else if (0.26<=LI & LI<=0.35){
	LI_c <- "Class 3"
	} else if (0.36<=LI & LI<=0.45){
	LI_c <- "Class 4"
	} else if (0.46<=LI & LI<=0.55){
	LI_c <- "Class 5"
	} else if (0.56<=LI & LI<=0.65){
	LI_c <- "Class 6"
	} else if (0.66<=LI & LI<=0.75){
	LI_c <- "Class 7"
	} else if (0.76<=LI & LI<=0.85){
	LI_c <- "Class 8"
	} else if (0.86<=LI & LI<=0.95){
	LI_c <- "Class 9"
	} else {
	LI_c <- "Class 10"
}

 ## Category of Altitude Index (AI_c)
if (0<=AI & AI<=10){
    AI_c <- "Class 1"
	} else if (11<=AI & AI<=20){
	AI_c <- "Class 2"
	} else if (21<=AI & AI<=30){
	AI_c <- "Class 3"
	} else if (31<=AI & AI<=40){
	AI_c <- "Class 4"
	} else if (41<=AI & AI<=50){
	AI_c <- "Class 5"
	} else if (51<=AI & AI<=60){
	AI_c <- "Class 6"
	} else if (61<=AI & AI<=70){
	AI_c <- "Class 7"
	} else if (71<=AI & AI<=80){
	AI_c <- "Class 8"
	} else if (81<=AI & AI<=90){
	AI_c <- "Class 9"
	} else {
	AI_c <- "Class 10"
}

 ## Adjusted Landform Index(ALI)
ALI <- as.numeric(gsub("[^0-9]", "", LI_c, ""))/10 * 0.8 +
	   as.numeric(gsub("[^0-9]", "", AI_c, ""))/10 * 0.2

 ## Category of Adjusted Landform Index (ALI_c)
ALI_c <- paste("Class",round(ALI * 10, digits=0))

 ## Category of Slope Index (SI_c)
if (0<=SI & SI<=0.05){
    SI_c <- "Class A"
	} else if (0.06<=SI & SI<=0.15){
	SI_c <- "Class B"
	} else if (0.16<=SI & SI<=0.30){
	SI_c <- "Class C"
	} else if (0.31<=SI & SI<=0.60){
	SI_c <- "Class D"
	} else {
	SI_c <- "Class E"
}

 ## Category of Aspect Index (AsI_c)
if (0<=AsI & AsI<=0.25){
    AsI_c <- "Class A"
	} else if (0.26<=AsI & AsI<=0.50){
	AsI_c <- "Class B"
	} else if (0.51<=AsI & AsI<=0.75){
	AsI_c <- "Class C"
	} else {
	AsI_c <- "Class D"
}

### Calculate Degree of Topographic Relief Alteration (DoTRA)
 ## DoTRA
Parameters <- c(
"Class A#Class A#Class 1","Class A#Class A#Class 2","Class A#Class A#Class 3",
"Class A#Class A#Class 4","Class A#Class A#Class 5","Class A#Class A#Class 6",
"Class A#Class A#Class 7","Class A#Class A#Class 8","Class A#Class A#Class 9",
"Class A#Class A#Class 10","Class A#Class B#Class 1","Class A#Class B#Class 2",
"Class A#Class B#Class 3","Class A#Class B#Class 4","Class A#Class B#Class 5",
"Class A#Class B#Class 6","Class A#Class B#Class 7","Class A#Class B#Class 8",
"Class A#Class B#Class 9","Class A#Class B#Class 10","Class A#Class C#Class 1",
"Class A#Class C#Class 2","Class A#Class C#Class 3","Class A#Class C#Class 4",
"Class A#Class C#Class 5","Class A#Class C#Class 6","Class A#Class C#Class 7",
"Class A#Class C#Class 8","Class A#Class C#Class 9","Class A#Class C#Class 10",
"Class A#Class D#Class 1","Class A#Class D#Class 2","Class A#Class D#Class 3",
"Class A#Class D#Class 4","Class A#Class D#Class 5","Class A#Class D#Class 6",
"Class A#Class D#Class 7","Class A#Class D#Class 8","Class A#Class D#Class 9",
"Class A#Class D#Class 10","Class B#Class A#Class 1","Class B#Class A#Class 2",
"Class B#Class A#Class 3","Class B#Class A#Class 4","Class B#Class A#Class 5",
"Class B#Class A#Class 6","Class B#Class A#Class 7","Class B#Class A#Class 8",
"Class B#Class A#Class 9","Class B#Class A#Class 10","Class B#Class B#Class 1",
"Class B#Class B#Class 2","Class B#Class B#Class 3","Class B#Class B#Class 4",
"Class B#Class B#Class 5","Class B#Class B#Class 6","Class B#Class B#Class 7",
"Class B#Class B#Class 8","Class B#Class B#Class 9","Class B#Class B#Class 10",
"Class B#Class C#Class 1","Class B#Class C#Class 2","Class B#Class C#Class 3",
"Class B#Class C#Class 4","Class B#Class C#Class 5","Class B#Class C#Class 6",
"Class B#Class C#Class 7","Class B#Class C#Class 8","Class B#Class C#Class 9",
"Class B#Class C#Class 10","Class B#Class D#Class 1","Class B#Class D#Class 2",
"Class B#Class D#Class 3","Class B#Class D#Class 4","Class B#Class D#Class 5",
"Class B#Class D#Class 6","Class B#Class D#Class 7","Class B#Class D#Class 8",
"Class B#Class D#Class 9","Class B#Class D#Class 10","Class C#Class A#Class 1",
"Class C#Class A#Class 2","Class C#Class A#Class 3","Class C#Class A#Class 4",
"Class C#Class A#Class 5","Class C#Class A#Class 6","Class C#Class A#Class 7",
"Class C#Class A#Class 8","Class C#Class A#Class 9","Class C#Class A#Class 10",
"Class C#Class B#Class 1","Class C#Class B#Class 2","Class C#Class B#Class 3",
"Class C#Class B#Class 4","Class C#Class B#Class 5","Class C#Class B#Class 6",
"Class C#Class B#Class 7","Class C#Class B#Class 8","Class C#Class B#Class 9",
"Class C#Class B#Class 10","Class C#Class C#Class 1","Class C#Class C#Class 2",
"Class C#Class C#Class 3","Class C#Class C#Class 4","Class C#Class C#Class 5",
"Class C#Class C#Class 6","Class C#Class C#Class 7","Class C#Class C#Class 8",
"Class C#Class C#Class 9","Class C#Class C#Class 10","Class C#Class D#Class 1",
"Class C#Class D#Class 2","Class C#Class D#Class 3","Class C#Class D#Class 4",
"Class C#Class D#Class 5","Class C#Class D#Class 6","Class C#Class D#Class 7",
"Class C#Class D#Class 8","Class C#Class D#Class 9","Class C#Class D#Class 10",
"Class D#Class A#Class 1","Class D#Class A#Class 2","Class D#Class A#Class 3",
"Class D#Class A#Class 4","Class D#Class A#Class 5","Class D#Class A#Class 6",
"Class D#Class A#Class 7","Class D#Class A#Class 8","Class D#Class A#Class 9",
"Class D#Class A#Class 10","Class D#Class B#Class 1","Class D#Class B#Class 2",
"Class D#Class B#Class 3","Class D#Class B#Class 4","Class D#Class B#Class 5",
"Class D#Class B#Class 6","Class D#Class B#Class 7","Class D#Class B#Class 8",
"Class D#Class B#Class 9","Class D#Class B#Class 10","Class D#Class C#Class 1",
"Class D#Class C#Class 2","Class D#Class C#Class 3","Class D#Class C#Class 4",
"Class D#Class C#Class 5","Class D#Class C#Class 6","Class D#Class C#Class 7",
"Class D#Class C#Class 8","Class D#Class C#Class 9","Class D#Class C#Class 10",
"Class D#Class D#Class 1","Class D#Class D#Class 2","Class D#Class D#Class 3",
"Class D#Class D#Class 4","Class D#Class D#Class 5","Class D#Class D#Class 6",
"Class D#Class D#Class 7","Class D#Class D#Class 8","Class D#Class D#Class 9",
"Class D#Class D#Class 10","Class E#Class A#Class 1","Class E#Class A#Class 2",
"Class E#Class A#Class 3","Class E#Class A#Class 4","Class E#Class A#Class 5",
"Class E#Class A#Class 6","Class E#Class A#Class 7","Class E#Class A#Class 8",
"Class E#Class A#Class 9","Class E#Class A#Class 10","Class E#Class B#Class 1",
"Class E#Class B#Class 2","Class E#Class B#Class 3","Class E#Class B#Class 4",
"Class E#Class B#Class 5","Class E#Class B#Class 6","Class E#Class B#Class 7",
"Class E#Class B#Class 8","Class E#Class B#Class 9","Class E#Class B#Class 10",
"Class E#Class C#Class 1","Class E#Class C#Class 2","Class E#Class C#Class 3",
"Class E#Class C#Class 4","Class E#Class C#Class 5","Class E#Class C#Class 6",
"Class E#Class C#Class 7","Class E#Class C#Class 8","Class E#Class C#Class 9",
"Class E#Class C#Class 10","Class E#Class D#Class 1","Class E#Class D#Class 2",
"Class E#Class D#Class 3","Class E#Class D#Class 4","Class E#Class D#Class 5",
"Class E#Class D#Class 6","Class E#Class D#Class 7","Class E#Class D#Class 8",
"Class E#Class D#Class 9","Class E#Class D#Class 10")

Parameters_Values <- c(
  0.08,0.12,0.15,0.18,0.22,0.25,0.28,0.32,0.35,0.38,0.17,0.20,0.23,0.27,0.30,
  0.33,0.37,0.40,0.43,0.47,0.25,0.28,0.32,0.35,0.38,0.42,0.45,0.48,0.52,0.55,
  0.33,0.37,0.40,0.43,0.47,0.50,0.53,0.57,0.60,0.63,0.11,0.14,0.18,0.21,0.24,
  0.28,0.31,0.34,0.38,0.41,0.19,0.23,0.26,0.29,0.33,0.36,0.39,0.43,0.46,0.49,
  0.28,0.31,0.34,0.38,0.41,0.44,0.48,0.51,0.54,0.58,0.36,0.39,0.43,0.46,0.49,
  0.53,0.56,0.59,0.63,0.66,0.15,0.18,0.22,0.25,0.28,0.32,0.35,0.38,0.42,0.45,
  0.23,0.27,0.30,0.33,0.37,0.40,0.43,0.47,0.50,0.53,0.32,0.35,0.38,0.42,0.45,
  0.48,0.52,0.55,0.58,0.62,0.40,0.43,0.47,0.50,0.53,0.57,0.60,0.63,0.67,0.70,
  0.23,0.26,0.29,0.33,0.36,0.39,0.43,0.46,0.49,0.53,0.31,0.34,0.38,0.41,0.44,
  0.48,0.51,0.54,0.58,0.61,0.39,0.43,0.46,0.49,0.53,0.56,0.59,0.63,0.66,0.69,
  0.48,0.51,0.54,0.58,0.61,0.64,0.68,0.71,0.74,0.78,0.34,0.38,0.41,0.44,0.48,
  0.51,0.54,0.58,0.61,0.64,0.43,0.46,0.49,0.53,0.56,0.59,0.63,0.66,0.69,0.73,
  0.51,0.54,0.58,0.61,0.64,0.68,0.71,0.74,0.78,0.81,0.59,0.63,0.66,0.69,0.73,
  0.76,0.79,0.83,0.86,0.89
)

DoTRA_table <- cbind(Parameters,Parameters_Values)
DoTRA_key <- paste (SI_c,AsI_c,ALI_c, sep = "#")
DoTRA <- as.numeric(DoTRA_table[grep(DoTRA_key, DoTRA_table),2])

 ## Category of DoTRA (DoTRA_c)
if (0<=DoTRA & DoTRA<=0.15){
    DoTRA_c <- "Very Low"
	} else if (0.17<=DoTRA & DoTRA<=0.25){
	DoTRA_c <- "Low"
	} else if (0.26<=DoTRA & DoTRA<=0.40){
	DoTRA_c <- "Intermediate"
	} else if (0.41<=DoTRA & DoTRA<=0.58){
	DoTRA_c <- "High"
	} else {
	DoTRA_c <- "Very High"
}

### Remove unwanted variables from memory
rm(list=ls()[! ls() %in% c("LI","AI","SI","AsI","LI_c","AI_c","ALI",
                           "ALI_c","SI_c","AsI_c","DoTRA","DoTRA_c")])

### Print DoTRA and it's indexes
msg_00 <- sprintf("LI:  %s %s",LI, LI_c)
msg_01 <- sprintf("\nAI:    %s %s",AI, AI_c)
msg_02 <- sprintf("\nSI:  %s %s",SI, SI_c)
msg_03 <- sprintf("\nAsI: %s %s",AsI, AsI_c)
msg_04 <- sprintf("\nALI: %s %s\n",ALI, ALI_c)

msg_1 <- sprintf(" The Degree of Topographic Relief Alteration is: %s", DoTRA)
msg_2 <- sprintf("\n  It is characterized as: %s\n", DoTRA_c)
cat(msg_00,msg_01,msg_02,msg_03,msg_04,msg_1,msg_2)


makepd4 <- function(target,x,sumstat,tol,gwt,rejmethod=T,transf="none",bb=c(0,0))
{
# target is the set of target summary stats
# x is the parameter vector (long vector of numbers from the simulations) and is the dependent variable for the regression
# sumstat is an array of simulated summary stats (i.e. independent variables).
# NBB this function originally used lm() and assumed 4 summary stats, and I edited by hand for other numbers.
# NBB I've now modified it using lsfit() (following Shola Ajayi) so that it will take an arbitrary number of summary stats.
# tol is the required proportion of points nearest the target values
# gwt is a vector with T/F weights, weighting out any 'bad' values (determined by the simulation program - i.e. nan's etc)
# if rejmethod=T it doesn't bother with the regression, and just does rejection.

# If rejmethod=F it returns a list with the following components:-

# $x regression adjusted values
# $vals - unadjusted values in rejection region (i.e. normal rejection)
# $wt - the regression weight (i.e. the Epanechnikov weight)
# $ss - the sumstats corresponding to these points
# $predmean - estimate of the posterior mean
# $fv - the fitted value from the regression

if(sum(transf == c("none","log","logit")) == 0){
	stop("transf must be none, log, or logit")

}
if(transf=="logit"){
	if(bb[1] >= bb[2]){
		stop("bounds wrong for logit")

	}
}

if(missing(gwt))gwt <- rep(T,length(sumstat[,1]))

nss <- length(sumstat[1,])

# scale everything

    scaled.sumstat <- sumstat

    for(j in 1:nss){

    	scaled.sumstat[,j] <- normalise(sumstat[,j],sumstat[,j][gwt])
    }
    target.s <- target

    for(j in 1:nss){

    	target.s[j] <- normalise(target[j],sumstat[,j][gwt])
    }

# calc euclidean distance

    sum1 <- 0
    for(j in 1:nss){
    	sum1 <- sum1 + (scaled.sumstat[,j]-target.s[j])^2
   }
   dst <- sqrt(sum1)
# includes the effect of gwt in the tolerance
    dst[!gwt] <- floor(max(dst[gwt])+10)

# wt1 defines the region we're interested in
    abstol <- quantile(dst,tol)
    wt1 <- dst < abstol

    if(transf == "log"){
    	if(min(x) <= 0){
    		print("log transform: val out of bounds - correcting")
    		x.tmp <- ifelse(x <= 0,max(x),x)
    		x.tmp.min <- min(x.tmp)
    		x <- ifelse(x <= 0, x.tmp.min,x)
    	}
    	x <- log(x)
    }
    else if(transf == "logit"){
    	if(min(x) <= bb[1]){
    		x.tmp <- ifelse(x <= bb[1],max(x),x)
    		x.tmp.min <- min(x.tmp)
    		x <- ifelse(x <= bb[1], x.tmp.min,x)

    	}
    	if(max(x) >= bb[2]){
    		x.tmp <- ifelse(x >= bb[2],min(x),x)
    		x.tmp.max <- max(x.tmp)
    		x <- ifelse(x >= bb[2], x.tmp.max,x)

    	}
    	x <- (x-bb[1])/(bb[2]-bb[1])
    	x <- log(x/(1-x))
    }

    if(rejmethod){
        l1 <- list(x=x[wt1],wt=0)
    }
    else{
        regwt <- 1-dst[wt1]^2/abstol^2

        fit1 <- lsfit(scaled.sumstat[wt1,],x[wt1],wt=regwt)

        predmean <- fit1$coeff %*% c(1,target.s)

        l1 <- list(x=fit1$residuals+predmean,vals=x[wt1],wt=regwt,ss=sumstat[wt1,],predmean=predmean,fv = x[wt1]-fit1$residuals,transf=transf)

    }
    if(transf == "log"){
    	l1$x <- exp(l1$x)
    	l1$vals <- exp(l1$vals)
    }
    else if(transf == "logit"){
    	l1$x <- exp(l1$x)/(1+exp(l1$x))
    	l1$x <- l1$x*(bb[2]-bb[1])+bb[1]
    	l1$vals <- exp(l1$vals)/(1+exp(l1$vals))
    	l1$vals <- l1$vals*(bb[2]-bb[1])+bb[1]
    }

    l1
}

normalise <- function(x,y){

if(var(y) == 0)return (x - mean(y))
(x-(mean(y)))/sqrt(var(y))
}


#'@title Determine whether or not a time series is stationary in the mean
#'
#'@description Uses the Augmented Dickey-Fuller test to determine when the time series has a unit root.
#'
#'@usage  tsData.isStationary <- isStationary(tsData)
#'
#'@details
#' A time series must have a minimum of three complete years of data.
#' For details on the implementation of the Augmented Dickey-Fuller test,
#' see the tseries package on cran.
#'
#'@param tsData  A time series object.
#'
#'@return A boolean indicating whether or not the given time series is stationary.
#'
#'@export

isStationary <- function(tsData)
{
	tsObj     <- tsData
	minMonths <- 36

	tsObj <- Castor::tsCompleteYears(tsObj)

	if (length(tsObj) < minMonths)
		stop("ERROR: Time series must have a minimum of three complete years of data")

	ADF_IS_STATIONARY <- suppressWarnings(tseries::adf.test(tsObj, alternative="stationary")$p.value <= .05)

	return (ADF_IS_STATIONARY)
}


library(npowerPrioR)
source("../Gaussian/data_Gaussian.r")

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = 1
)

###
get_l_a0_gaussian <- function(y0, n0, alpha0, beta0, m0, k0, a_0){
  nstar <- a_0 * n0
  ybar <- mean(y0)
  s <- mean( (y0-ybar)^2 )
  kappa_n <- k0 + nstar
  alpha_n <- alpha0 + nstar/2
  beta_n <- beta0 + .5 * (nstar * s +  (k0 * nstar * (ybar - m0)^2 )/kappa_n )
  ans <- lgamma(alpha_n)-lgamma(alpha0)
  ans <- ans + alpha0 * log(beta0) - alpha_n * log(beta_n)
  ans <- ans + .5 *( log(k0) - log(kappa_n) )-nstar/2 * log(2*pi)
  return(ans)
}
############
l_a0 <- function(x) {
  get_l_a0_gaussian(
    y0 = gs.data$y0,
    n0 = gs.data$N0,
    alpha0 = gs.data$alpha0,
    beta0 = gs.data$beta0,
    m0 = gs.data$mu0,
    k0 = gs.data$kappa0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
########

maxA <- 1
prior <- stan_model("../Gaussian/stan/simple_Gaussian_prior.stan")

# direct method
J <- 20
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10,
                                       stan.list = gs.data, pars = c("mu", "sigma"))
)

# VR2018
Delta.a <- 0.01
a0s.vr2018 <- seq(0, maxA, by = Delta.a)

vr2018.time <- system.time(
  vr2018.estimates <-  create_lc_df_derivOnly(a0_grid = a0s.vr2018,
                              compiled.model.prior = prior,
                              stan.list = gs.data, pars = c("mu", "sigma") )
)

write.csv(vr2018.estimates$result,
          file = "Gaussian_VR2018.csv", row.names = FALSE)
adaptive.time
vr2018.time
###
## Now the approximations
adapt.gam <-  mgcv::gam(lc_a0 ~ s(a0, k = J), data = adaptive.ca0.estimates$result)
vr2018.estimates$result$la0_est <- cumsum(vr2018.estimates$result$deriv_lc) * Delta.a

## Finally, comparisons

K <- 20000
pred.a0s <- seq(0, maxA, length.out = K)

true.la0s <- l_a0(pred.a0s)

adaptive.preds <- predict(adapt.gam, newdata = data.frame(a0 = pred.a0s))

vr2018.preds <- approx(x = vr2018.estimates$result$a0,
                          y =  vr2018.estimates$result$la0_est,
                          xout =  pred.a0s)

plot(vr2018.preds, type = "l", lwd = 5,
     col = 3,
     xlab = expression(a[0]), ylab = "Log-normalising constant")
lines(pred.a0s, adaptive.preds, col = 2, lwd = 5)
lines(pred.a0s, true.la0s, lwd = 5, lty = 2, add = TRUE)
legend(x = "topleft", legend =  c("GAM", "VR2018", "True"),
       col = c(2, 3, 1), lwd  = 2, lty = c(1, 1, 2), bty = 'n')

preds.list <- list(
  adaptive = adaptive.preds,
  VR2018 = vr2018.preds$y
)

ntrue.la0s <- true.la0s

lapply(preds.list, function(pred) sqrt(mean( ( pred- ntrue.la0s)^2 )) )
lapply(preds.list, function(pred) mean( abs( pred- ntrue.la0s) ))


## useful plots

plotsfh <- function(sfh, ages, ptype="instsfr", quants=c(0.025,.975), log="", ylim=NULL) {
    require(ggplot2)

    nt <- ncol(sfh)
    ns <- nrow(sfh)
    ages.years <- 10^ages
    yvals <- matrix(0, ns, nt)
    switch(ptype,
        avgsfr = {
            yvals <- t(apply(sfh, 1, cumsum)/ages.years)
        },
        instsfr = {
            dt <- diff(c(0,ages.years))
            yvals <- t(t(sfh)/dt)
        },
        cumfrac = {
            tm <- rowSums(sfh)
            yvals <- t(apply(sfh, 1, cumsum))/tm
        },
        cumfrac0 = {
            tm <- rowSums(sfh)
            yvals <- 1-t(apply(sfh, 1, cumsum))/tm
        }
    )
    ages.gyr <- ages.years*10^(-9)
    y <- colMeans(yvals)
    ylims <- apply(yvals, 2, quantile, probs=quants)
    df <- data.frame(ages.gyr=ages.gyr, y=y, ymin=ylims[1,], ymax=ylims[2,])
    g1 <- ggplot(df, aes(x=ages.gyr, y=y)) + geom_line() +
            geom_ribbon(aes(ymin=ymin, ymax=ymax), color="gray70", alpha=0.5) +
            xlab("T (Gyr)") + ylab(ptype)
    if (!is.null(ylim)) {
        g1 <- g1 + ylim(ylim)
    }
    if (log=="x" || log=="xy") {
        g1 <- g1 + scale_x_log10()
    }
    if (log=="y" || log=="xy") {
        g1 <- g1 + scale_y_log10()
    }
    g1
}

plotmgh <- function(mgh, ages, quants=c(.025, .975), log="", ylim=c(0,1)) {
    require(ggplot2)
    ages.gyr <- 10^(ages-9)
    mgh.mean <- colMeans(mgh)
    if (length(mgh.mean) > length(ages.gyr)) {
      ages.gyr <- c(1.e-9, ages.gyr)
    }
    lims <- apply(mgh, 2, quantile, probs=quants)
    df <- data.frame(T=ages.gyr, mgh=mgh.mean, ymin=lims[1,], ymax=lims[2,])
    g1 <- ggplot(df, aes(x=T, y=mgh)) + geom_line() + xlab("T (Gyr)") +
            ylab("Cumulative mass fraction")
    g1 <- g1 + geom_ribbon(aes(ymin=ymin, ymax=ymax), color="gray70", alpha=0.5) +
            ylim(ylim)
    if (log=="x" || log=="xy") {
        g1 <- g1 + scale_x_log10()
    }
    if (log=="y" || log=="xy") {
        g1 <- g1 + scale_y_log10()
    }
    g1
}

addnnmgh <- function(ggraph, nnfits, which.spax, z, ages, mstar, cumfrac=TRUE, color="red", linetype=2) {
  ns <- length(mstar)
  nt <- length(ages)
  nz <- ns/nt
  rmass <- matrix(nnfits$nnfits[which.spax, 1:ns]*mstar, nt, nz)
  rmass <- rowSums(rmass) * cosmo::lum.sol(1, z)
  mgh <- c(sum(rmass), sum(rmass)-cumsum(rmass))
  if (cumfrac) {
    mgh <- mgh/sum(rmass)
  }
  df <- data.frame(t = c(0, 10^(ages-9)), mgh=mgh)
  ggraph + geom_line(aes(x=t, y=mgh), data=df, color=color, linetype=linetype)
}

multimgh <- function(..., ages, ids=NULL, quants=c(0.025,0.975),
                     palette="Set1", alpha=0.5, legend=NULL) {
  require(ggplot2)
  ages <- 10^(ages-9)
  mghs <- list(...)
  if (dim(mghs[[1]])[2] > length(ages)) {
    ages <- c(1.e-9, ages)
  }
  N <- length(list(...))
  nt <- length(ages)
  x <- numeric(0)
  y <- numeric(0)
  ymin <- numeric(0)
  ymax <- numeric(0)
  if (is.null(ids)) {
    ids <- as.factor(1:N)
  }
  id <- rep(ids, each=nt)
  levels(id) <- ids
  for (i in 1:N) {
    x <- c(x,ages)
    y <- c(y, colMeans(mghs[[i]]))
    ylims <- apply(mghs[[i]], 2, quantile, probs=quants)
    ymin <- c(ymin, ylims[1,])
    ymax <- c(ymax, ylims[2,])
  }
  df <- data.frame(id=id, x=x, y=y, ymin=ymin, ymax=ymax)
  g1 <- ggplot(df) + geom_line(aes(x=x, y=y, color=id)) +
    geom_ribbon(aes(x=x, ymin=ymin, ymax=ymax, fill=id),
                alpha=alpha, show.legend=FALSE)
  g1 <- g1 + scale_color_brewer(type="qual", palette=palette, breaks=ids)
  g1 <- g1 + scale_fill_brewer(type="qual",palette=palette, breaks=ids)
  g1 <- g1 + xlab("Lookback time (Gyr)") + ylab("Cumulative mass fraction")
  if (!is.null(legend)) {
    g1 <- g1 + labs(color=legend)
  }
  plot(g1)
  list(df=df, graph=g1)
}

multimgh2 <- function(mghs, ages, ids=NULL, quants=c(0.025,0.975),
                     palette="Set1", alpha=0.5, legend=NULL) {
  require(ggplot2)
  ages <- 10^(ages-9)
  if (dim(mghs)[2] > length(ages)) {
    ages <- c(1.e-9, ages)
  }
  ok2plot <- which(!is.na(mghs[1,1,]))
  nt <- length(ages)
  x <- numeric(0)
  y <- numeric(0)
  ymin <- numeric(0)
  ymax <- numeric(0)
  if (is.null(ids)) {
    ids <- as.factor(ok2plot)
  }
  id <- rep(ids, each=nt)
  levels(id) <- ids
  for (i in ok2plot) {
    x <- c(x,ages)
    y <- c(y, colMeans(mghs[,,i]))
    ylims <- apply(mghs[,,i], 2, quantile, probs=quants)
    ymin <- c(ymin, ylims[1,])
    ymax <- c(ymax, ylims[2,])
  }
  df <- data.frame(id=id, x=x, y=y, ymin=ymin, ymax=ymax)
  g1 <- ggplot(df) + geom_line(aes(x=x, y=y, color=id)) +
    geom_ribbon(aes(x=x, ymin=ymin, ymax=ymax, fill=id),
                alpha=alpha, show.legend=FALSE)
  if (length(ok2plot) <= 9) {
    g1 <- g1 + scale_color_brewer(type="qual", palette=palette, breaks=ids)
    g1 <- g1 + scale_fill_brewer(type="qual",palette=palette, breaks=ids)
  } else {
    g1 <- g1 + scale_color_manual(values=viridis::viridis(length(ok2plot)))
    g1 <- g1 + scale_fill_manual(values=viridis::viridis(length(ok2plot)))
  }
  g1 <- g1 + xlab("Lookback time (Gyr)") + ylab("Cumulative mass fraction")
  if (!is.null(legend)) {
    g1 <- g1 + labs(color=legend)
  }
  plot(g1)
  list(df=df, graph=g1)
}

## mghs and ages in lists of same length

multimgh3 <- function(mgh_list, ages_list, ids=NULL, quants=c(0.025,0.975),
                     palette="Set1", alpha=0.5, legend=NULL) {
  require(ggplot2)
  N <- length(mgh_list)
  x <- numeric(0)
  y <- numeric(0)
  ymin <- numeric(0)
  ymax <- numeric(0)
  if (is.null(ids)) {
    ids <- as.factor(1:N)
  }
  id <- factor(levels=ids)
  for (i in 1:N) {
    nt <- length(ages_list[[i]])
    x <- c(x, 1.e-9, 10^(ages_list[[i]]-9))
    y <- c(y, colMeans(mgh_list[[i]]))
    ylims <- apply(mgh_list[[i]], 2, quantile, probs=quants)
    ymin <- c(ymin, ylims[1,])
    ymax <- c(ymax, ylims[2,])
    id <- c(id, rep(ids[i], nt+1))
  }
  id <- as.factor(id)
  df <- data.frame(id=id, x=x, y=y, ymin=ymin, ymax=ymax)
  g1 <- ggplot(df) + geom_line(aes(x=x, y=y, color=id)) +
    geom_ribbon(aes(x=x, ymin=ymin, ymax=ymax, fill=id),
                alpha=alpha, show.legend=FALSE)
  g1 <- g1 + scale_color_brewer(type="qual", palette=palette, breaks=ids)
  g1 <- g1 + scale_fill_brewer(type="qual",palette=palette, breaks=ids)
  g1 <- g1 + xlab("Lookback time (Gyr)") + ylab("Cumulative mass fraction")
  if (!is.null(legend)) {
    g1 <- g1 + labs(color=legend)
  }
  plot(g1)
  list(df=df, graph=g1)
}

plotpp <- function(sfit, title=NULL,
                   quants=c(.025,.975), gcolor="grey70", fcolor="turquoise2") {
    require(ggplot2)
    lambda <- sfit$spm_data$lambda
    gflux <- sfit$spm_data$gflux
    g_std <- sfit$spm_data$g_std
    pp <- rstan::extract(sfit$stanfit)$gflux_rep
    if (exists("norm_g", sfit)) {
      gflux <- gflux * sfit$norm_g
      g_std <- g_std * sfit$norm_g
    }
    ylims <- apply(pp, 2, quantile, probs=quants)
    df <- data.frame(lambda=lambda, gflux=gflux, fitted=colMeans(pp),
                     ymin=ylims[1,], ymax=ylims[2,],
                     residual = (gflux-colMeans(pp))/g_std,
                     rmin=(gflux-ylims[1,])/g_std, rmax=(gflux-ylims[2,])/g_std)
    g1 <- ggplot(df, aes(x=lambda, y=gflux)) + geom_line(color=gcolor)
    g1 <- g1 + xlab(expression(lambda)) + ylab("flux")
    g1 <- g1 + geom_ribbon(aes(ymin=ymin, ymax=ymax), fill=fcolor, alpha=0.33)
    g1 <- g1 + geom_line(aes(y=fitted), color=fcolor)
    if (!is.null(title)) {
      g1 <- g1 + ggtitle(title)
    }
    g2 <- ggplot(df, aes(x=lambda, y=residual)) + geom_line(color=gcolor)
    g2 <- g2 + xlab(expression(lambda)) + ylab("residual")
    g2 <- g2 + geom_ribbon(aes(ymin=rmin, ymax=rmax), fill=fcolor, alpha=0.33)
    g2 <- g2 + geom_line(aes(y=residual), color=fcolor)
    g3 <- gridExtra::grid.arrange(g1, g2, nrow=2)
    plot(g3)
    list(df=df, g1=g1, g2=g2)
}

plotfitted <- function(sfit, quants=c(.025,.975), gcolor="grey70", fcolor="turquoise2") {
    require(ggplot2)
    require(gridExtra)
    lambda <- sfit$spm_data$lambda
    gflux <- sfit$spm_data$gflux
    g_std <- sfit$spm_data$g_std
    if (exists("norm_g", sfit)) {
      gflux <- gflux * sfit$norm_g
      g_std <- g_std * sfit$norm_g
    }
    fitted <- rstan::extract(sfit$stanfit)$mu_g
    res <- t((gflux-t(fitted))/g_std)
    ylims <- apply(fitted, 2, quantile, probs=quants)
    rlims <- apply(res, 2, quantile, probs=quants)
    df <- data.frame(lambda=lambda, gflux=gflux, fitted=colMeans(fitted),
                     ymin=ylims[1,], ymax=ylims[2,],
                     rmean=colMeans(res),rmin=rlims[1,],rmax=rlims[2,]
                    )
    g1 <- ggplot(df, aes(x=lambda, y=gflux)) + geom_line(color=gcolor)
    g1 <- g1 + xlab(expression(lambda)) + ylab("flux")
    g1 <- g1 + geom_ribbon(aes(ymin=ymin, ymax=ymax), fill=fcolor)
    g1 <- g1 + geom_line(aes(y=fitted), color=fcolor)
    g2 <- ggplot(df, aes(x=lambda, y=rmean)) + geom_line(color=gcolor)
    g2 <- g2 + xlab(expression(lambda)) + ylab("sd")
    g2 <- g2 + geom_line(aes(y=rmean), color=fcolor)
    g2 <- g2 + geom_ribbon(aes(ymin=rmin, ymax=rmax), fill=fcolor)
    plot(grid.arrange(g1, g2, nrow=2, heights=c(3,1)))
    list(g1=g1, g2=g2)
}


library(lme4)

# Fit a model with one fixed (`x`) and one random (`group`) effect (intercept only)
# Note the specific syntax (`(1|<your_var>)`) for random effect
outLmer <- lmer(response ~ x + (1|group), data = multIntDemo)

# Look at model outputs
summary(outLmer)
# tidy(outLmer)

# Random-effect slopes:
outLmer2 <- lmer(response ~ (x|group), multIntDemo)

summary(outLmer2)
#tidy(outLmer2)


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);

  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b8;
real b9;
real b10;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u+b8*((1-exp(-n/b10))/(n/b10))+b9*((1-exp(-n/b10))/(n/b10)-exp(-n/b10))+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.028,0.01);
b8 ~ normal(0.05,0.01);
b9 ~ normal(0.05,0.01);
b10 ~ normal(0.05,0.01);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

setwd("./covid19modelrisk/output/model_with_E")

###########
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_GM.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_IT.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_JP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_SP.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_UK.csv")
  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_US.csv")
##  E=read.csv("volumeWeight_entropy_sentiment_IQRSummary_AU.csv")

################
  E=E[,4]
##  E=E[,5]

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.028,b8=0.05,b9=0.05,b10=0.05,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)


##CTE534_PCA=group
##Imagen=raster
##UltimaBanda=number 9
##Muestra=number 500
##PCA=output raster
##showplots
library(raster)

sr <- sampleRandom(Imagen[[1:UltimaBanda]], Muestra)#Paquete de sampleRandom
pca <- prcomp(sr, scale =TRUE)
screeplot(pca)

PCA <- predict(Imagen[[1:UltimaBanda]], pca, index = 1:UltimaBanda)
par(mfrow=c(2,2))
plot(PCA[[1]])
plot(PCA[[2]])
plot(PCA[[3]])
#plot(PCA[[4]])


#------------------------------------------------------------------------------
#Copyright (c) 2017 Tijana Vujcic

source("DBDA2E-utilities.R")

  require(rstan)
  #-----------------------------------------------------------------------------
  # THE DATA.

  dataFrame = data.frame( # from Snee (1974)
	Freq = c(68,119,26,7,20,84,17,94,15,54,14,10,5,29,14,16) ,
    Eye  = c("Brown","Brown","Brown","Brown","Blue","Blue","Blue","Blue","Hazel","Hazel","Hazel","Hazel","Green","Green","Green","Green"),
    Hair = c("Black","Brunette","Red","Blond","Black","Brunette","Red","Blond","Black","Brunette","Red","Blond","Black","Brunette","Red","Blond") )
	y = as.numeric(dataFrame$Freq)
	x1 = as.numeric(dataFrame$Eye)
	x1names = levels(dataFrame$Eye)
	x2 = as.numeric(dataFrame$Hair)
	x2names = levels(dataFrame$Hair)

  dataList = list(
    X = x1 ,
    Y = y ,
    N = length(y)
  )

  #-----------------------------------------------------------------------------
  # THE MODEL.
  modelString = "
	data {
		int<lower=1> N; // sample size
		int Y[N];
		real X[N];
	}
	parameters {
		real<lower=0> a;
		real<lower=0> b;
	}
	transformed parameters {

	}
	model {
		a ~ gamma(1,1);
		b~ gamma(1,1);
		for(i in 1:N)
		Y[i] ~ poisson(a + b*X[i]);
	}

  " # close quote for modelString
  # Write out modelString to a text file
 resStan <- stan(model_code = modelString, data = dataList,
                chains = 3, iter = 20000/3, warmup = 1000, thin = 1)


suppressPackageStartupMessages(library(float))

same = function(test, truth) stopifnot(all.equal(dbl(test), truth, tol=1e-6, check.attributes=FALSE))

m = 10
n = 3

x = matrix(stats::rnorm(m*n), m, n)
s = fl(x)

test = scale(s, TRUE, TRUE)
truth = scale(x, TRUE, TRUE)
same(test, truth)

test = scale(s, TRUE, FALSE)
truth = scale(x, TRUE, FALSE)
same(test, truth)

test = scale(s, FALSE, TRUE)
truth = scale(x, FALSE, TRUE)
same(test, truth)

test = scale(s, FALSE, FALSE)
truth = scale(x, FALSE, FALSE)
same(test, truth)