library(nloptr)
library(rlist)
source("bootstrapping.r")

get_expected_I = function(beta, N0, lambda) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  N0 : numeric
    Initial number of cases.
  lambda : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected_I : numeric vector
    Daily expected number of new cases.
  "
  moments = length(beta)
  expected_I = rep(0, moments)
  expected_N = rep(0, moments)
  N_previous = N0
  for(t in 1:moments){
    expected_N[t] = N_previous * (beta[t] + pexp(1, rate=lambda, lower.tail=FALSE))
    expected_I[t] = N_previous * beta[t]
    N_previous = expected_N[t]
  }
  return(expected_I)
}

optimize_lambda = function(observed_I, beta, N0, lambda0, lambda_min, lambda_max) {
  "
  Find lambda that optimizes the quartic error of estimation of E[I(t)].

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  N0 : numeric
    Initial number of cases.
  lambda0 : numeric
    Initial value for lambda.

  Returns
  -------
  lambda : numeric
    Optimal value for lambda.
  "
  # define objective function: mean quartic error of estimation  of new cases
  mean_quartic_error = function(lambda) {
    expected_I = get_expected_I(beta, N0, lambda)
    return(mean((observed_I - expected_I) ^ 4))
  }
  # optimize
  local_opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                      "xtol_rel" = 1.0e-7 )
  opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                "xtol_rel" = 1.0e-7,
                "maxeval" = 100000,
                "local_opts" = local_opts )
  result <- nloptr(x0=lambda0, eval_f=mean_quartic_error, eval_grad_f=NULL,
                   lb=lambda_min, ub=lambda_max, opts=opts)
  return(result$solution)
}

fit = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N0_min, N0_max, alpha, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # set optimization parameters
  moments = length(observed_I)
  beta_min =rep(beta_min, times=moments)
  beta_max =rep(beta_max, times=moments)
  local_opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                      "xtol_rel" = 1.0e-7 )
  opts <- list( "algorithm" = "NLOPT_LN_BOBYQA",
                "xtol_rel" = 1.0e-7,
                "maxeval" = 100000,
                "local_opts" = local_opts )
  # optimize over several N0
  best = list()
  best$loss = Inf
  for (N0 in N0_min:N0_max) {
    loss = function(beta) {
      lambda = optimize_lambda(observed_I, beta, N0, lambda0, lambda_min,
                               lambda_max)
      expected_I = get_expected_I(beta, N0, lambda)
      beta_diff = diff(beta)
      beta_diff = beta_diff[!1:length(beta_diff) %in% ignore_beta_diff]
      loss = mean((expected_I - observed_I) ^ 4) + alpha * mean(beta_diff ^ 2)
      return(loss)
    }
    result <- nloptr(x0=beta0, eval_f=loss, eval_grad_f=NULL, lb=beta_min,
                     ub=beta_max, opts=opts)
    if(result$objective < best$loss) {
      best$loss = result$objective
      best$N0 = N0
      best$beta = result$solution
    }
  }
  best$lambda = optimize_lambda(observed_I, best$beta, best$N0, lambda0,
                                lambda_min, lambda_max)
  return(best)
}

fit2 = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N00, N0_min, N0_max, alpha, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, lambda0, N00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), lambda_min, N0_min)
  ub = c(rep(beta_max, steps), lambda_max, N0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7,
              "maxeval" = 10000000)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    lambda = x[steps + 1]
    N0 = x[steps + 2]
    # calculate loss
    expected_I = get_expected_I(beta, N0, lambda)
    beta_diff = diff(beta)
    beta_diff = beta_diff[!1:length(beta_diff) %in% ignore_beta_diff]
    loss = mean((expected_I - observed_I) ^ 4) + alpha * mean(beta_diff ^ 2)
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$lambda = result$solution[steps + 1]
  model$N0 = result$solution[steps + 2]
  model$loss = result$objective
  return(model)
}

fit3 = function(observed_I, beta0, beta_min, beta_max, lambda0, lambda_min,
               lambda_max, N00, N0_min, N0_max, regularization, regularization_weights, ignore_beta_diff, window_size=10) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, lambda0, N00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), lambda_min, N0_min)
  ub = c(rep(beta_max, steps), lambda_max, N0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7,
              "maxeval" = 100000)
  observed_variances = compute_variances(observed_I, window_size)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    lambda = x[steps + 1]
    N0 = x[steps + 2]
    # calculate loss
    expected_I = get_expected_I(beta, N0, lambda)
    beta_diff = diff(beta)
    alpha = regularization_weights*(observed_variances)
    #6.4e8
    loss = mean((expected_I - observed_I) ^ 4) +(regularization)* mean(alpha[1:(length(alpha) - 1)] * (beta_diff ^ 2))
    return(loss)
  }
  result = nloptr(x0=x0, eval_f=loss, eval_grad_f=NULL, lb=lb, ub=ub, opts=opts)
  model = list()
  model$beta = result$solution[1:steps]
  model$lambda = result$solution[steps + 1]
  model$N0 = result$solution[steps + 2]
  model$loss = result$objective
  return(model)
}


data(USArrests)

# 분산(Variance) 확인
apply(USArrests, 2, var)

# PCA 차원 축소
pca <- prcomp(USArrests, scale = TRUE)
pca
names(pca)

pca$rotation <- -pca$rotation
pca$x <- -pca$x
biplot(pca, scale = 0)


#importa pacote
library('readr')

# Lê/coleta dados no arquivo

dados_cliente <- read.csv("./clientes.csv",sep=";")

head(dados_cliente)

# Descrever a estrutura dos dados

str(dados_cliente)

tail(dados_cliente)

# Definimos que a variável Grau.Instrução deve ser tratada como ordinal

levels(dados_cliente$Grau.Instrução)

# Frequência absoluta

fa <- table(dados_cliente$Estado.civil)
fa

# Frequência relativa

fr1 <- fa/length(dados_cliente$Estado.civil)
fr1

# Frequência relativa

fr2 <- prop.table(fa)
fr2

# Frequência percentual

fpct <- prop.table(fa)*100
fpct

round(fpct,digit=2)

# Moda
names(fa)[which.max(fa)]

barplot(fa,main = "Frequência absoluta",xlab = "Estado Civil",ylab = "Quantidade")

pie(main = "Frequência relativa percentual",fpct,labels=as.character(round(fpct,digits = 2)))

# Frequência absoluta

fa <- table(dados_cliente$Grau.Instrução)
fa
# Frequência relativa

fr <- prop.table(fa)
fr

# Frequência percentual

fpct <- prop.table(fa)*100
fpct

# Moda
names(fa)[which.max(fa)]

barplot(sort(fr),main = "Frequência relativa",xlab = "Valor",ylab = "Grau de Instrução",col = "darkred",horiz = TRUE)

barplot(sort(fa),main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

barplot(fa,main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

levels(dados_cliente$Grau.Instrução)

dados_cliente$Grau.Instrução <- factor(dados_cliente$Grau.Instrução,levels = c('Fundamental','Médio','Superior','Mestrado','Doutorado'))

fa <- table(dados_cliente$Grau.Instrução)

barplot(fa,main = "Frequência absoluta",ylab = "Qtde",xlab = "Grau de Instrução")

head(dados_cliente,2)

# Frequência absoluta

fa <- table(dados_cliente$Qtde.Filhos)
print('Frequência absoluta:')
fa

# Frequência relativa

fr <- prop.table(fa)
print('Frequência relativa:')
round(fr,digit=0)

# Frequência percentual

fpct <- prop.table(fa)*100
print('Frequência relativa percentual:')
round(fpct,digit=0)

# na.rm=TRUE --> Pq alguns valores são NA
# Moda
print("Moda")
names(fa)[which.max(fa)]

# Mediana
print("Mediana")
median(dados_cliente$Qtde.Filhos,na.rm=TRUE)

#Média
print("Media")
mean(dados_cliente$Qtde.Filhos,na.rm=TRUE)

#Quartis
print("quartis")
quantile(dados_cliente$Qtde.Filhos,na.rm=TRUE)
#min
print("min")
min(dados_cliente$Qtde.Filhos,na.rm=TRUE)
#max
print("max")
max(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Amplitude (max-min)
print("Amplitude")
diff(range(dados_cliente$Qtde.Filhos,na.rm=TRUE))

# Variancia
print("Variancia")
var(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Desvio-padrão
print("Desvio-padrão")
sd(dados_cliente$Qtde.Filhos,na.rm=TRUE)

# Coeficiênte de variação
print("Coeficiênte de variação")
sd(dados_cliente$Qtde.Filhos,na.rm=TRUE)/mean(dados_cliente$Qtde.Filhos,na.rm=TRUE)

quartis <- quantile(dados_cliente$Qtde.Filhos,na.rm=TRUE)
# Amplitude interquartilica
print("Amplitude interquartilica")
quartis[4]-quartis[2]

#Resumo
summary(dados_cliente$Qtde.Filhos)

# Frequência absoluta acumulada

faa <- cumsum(fa)
faa

fa

plot(fa,main = "Frequência absoluta",ylab = "Frequência",xlab = "Qtde. de Filhos")

plot(faa,main = "Frequência absoluta acumulada",ylab = "Frequência",xlab = "Qtde. de Filhos",type="S")

head(dados_cliente,2)

summary(dados_cliente$Salário)

# Min e Max
range(dados_cliente$Salário)

#min
min <- min(dados_cliente$Salário,na.rm=TRUE)
#max
max <- max(dados_cliente$Salário,na.rm=TRUE)

#Qtde de classes
nclass.Sturges(dados_cliente$Salário)

# Agrupar
print(cut(dados_cliente$Salário,breaks=seq(min,max,length.out=8)))

# Agrupar
grupos <- cut(dados_cliente$Salário,breaks=seq(min,max,length.out=8))

print(grupos)

# Frequência absoluta

fa <- table(grupos)
print('Frequência absoluta:')
fa

# Frequência relativa

fr <- prop.table(fa)
print('Frequência relativa:')
round(fr,digit=0)

hist(dados_cliente$Salário,main=" Histograma - Salário",ylab = "Frequência",xlab = "Valor salário")

hist(dados_cliente$Salário,main=" Histograma - Salário",ylab = "Densidade",xlab = "Valor salário",freq=FALSE,labels=TRUE)

boxplot(dados_cliente$Salário,main=" Boxplot - Salário",ylab = "Valor salário")

BootCamp Engenheiro de Dados/Modulo 1 - Materiais/Material_complementar_videoaulas/Analise_univariada.r


#load library
library(MethComp)

#import data
df<-read.csv("gatti.csv", header = TRUE, sep = ";", dec= ",", stringsAsFactors = FALSE)
#
# #ignore columns
# df<-df[,1:22]
#
# head(df)
# str(df)
# #delete record number 99
# df<-df[-c(393:396),]
#
# df_Meth<-Meth(df, 2,1,3,7)
#
# plot(df_Meth)

#convert data to Meth object type and save pdf with meth plot

pdf()

for(i in c(4:22)){

df_Meth<-Meth(df, 2,1,3,i)

plot(df_Meth)
title(main=list(colnames(df[i]), col="red"), line=3, adj=0.45)
print(i)
}
dev.off()

#Bland-Altman plot

BA.plot(df_Meth, repl.conn=FALSE, meth.names = TRUE)

#passing  bablok regression

reg<-PBreg(df_Meth)
print(reg)

plot(reg,subtype= 1, xlim = c(0,50), ylim= c(0,50))

#concordance correlation coefficient agreement=(misure del target, misure del test)


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

# Brad Ballard
# CS498 Applied Machine Learning at UIUC

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

# Works cited
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/pimanbholdout.R
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/klarcaret.R
# Resource used: http://luthuli.cs.uiuc.edu/~daf/courses/AML-18/RCodeClassification/svmholdout.R
# Worked with Jacob Rettig (classmate) on this assignment

# Import packages
options(warn=-1)
library(caret)
library(klaR)

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

# Part A: Naive Bayes without package

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

#load data
setwd('/Users/bradjballard/')
data_in<-read.csv('pima.csv', header=FALSE)
x_vector <- data_in[-c(9)]
y_labels <- data_in[,9]

#train naive bayes model
trscore<-array(dim=10)
tescore<-array(dim=10)

for (wi in 1:10){
  #create training and testing sets
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector[-datasplit,]
  testy <- y_labels[-datasplit]

  #splitting positive and negative examples
  trposflag<-trainy>0
  positive_examples <- trainx[trposflag, ]
  negative_examples <- trainx[!trposflag,]

  #calculate means and sds
  ptrmean<-sapply(positive_examples, mean, na.rm=TRUE)
  ntrmean<-sapply(negative_examples, mean, na.rm=TRUE)
  ptrsd<-sapply(positive_examples, sd, na.rm=TRUE)
  ntrsd<-sapply(negative_examples, sd, na.rm=TRUE)

  #calculate offsets and scales
  ptroffsets<-t(t(trainx)-ptrmean)
  ptrscales<-t(t(ptroffsets)/ptrsd)

  pteoffsets<-t(t(testx)-ptrmean)
  ptescales<-t(t(pteoffsets)/ptrsd)
  ptelogs<--(1/2)*rowSums(apply(ptescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ptrsd))
  nteoffsets<-t(t(testx)-ntrmean)
  ntescales<-t(t(nteoffsets)/ntrsd)
  ntelogs<--(1/2)*rowSums(apply(ntescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ntrsd))
  lvwte<-ptelogs>ntelogs
  gotright<-lvwte==testy
  tescore[wi]<-sum(gotright)/(sum(gotright)+sum(!gotright))
}
accuracy <- sum(tescore) / length(tescore)

#accuracy after cross validating 10 times
accuracy

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

# Part B: NB with missing data removed

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

#replace '0' in columns with NA
x_vector_copy <- x_vector
for (i in c(3, 4, 6, 8)){
  non_values <- x_vector[, i]==0
  x_vector_copy[non_values, i]=NA
}

#train naive bayes model
trscore<-array(dim=10)
tescore<-array(dim=10)

for (wi in 1:10){
  #create training and testing sets
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector_copy[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector_copy[-datasplit,]
  testy <- y_labels[-datasplit]

  #splitting positive and negative examples
  trposflag<-trainy>0
  positive_examples <- trainx[trposflag, ]
  negative_examples <- trainx[!trposflag,]

  #calculate means and sds
  ptrmean<-sapply(positive_examples, mean, na.rm=TRUE)
  ntrmean<-sapply(negative_examples, mean, na.rm=TRUE)
  ptrsd<-sapply(positive_examples, sd, na.rm=TRUE)
  ntrsd<-sapply(negative_examples, sd, na.rm=TRUE)

  #calculate offsets and scales
  ptroffsets<-t(t(trainx)-ptrmean)
  ptrscales<-t(t(ptroffsets)/ptrsd)

  pteoffsets<-t(t(testx)-ptrmean)
  ptescales<-t(t(pteoffsets)/ptrsd)
  ptelogs<--(1/2)*rowSums(apply(ptescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ptrsd))
  nteoffsets<-t(t(testx)-ntrmean)
  ntescales<-t(t(nteoffsets)/ntrsd)
  ntelogs<--(1/2)*rowSums(apply(ntescales,c(1, 2), function(x)x^2), na.rm=TRUE)-sum(log(ntrsd))
  lvwte<-ptelogs>ntelogs
  gotright<-lvwte==testy
  tescore[wi]<-sum(gotright)/(sum(gotright)+sum(!gotright))
}
accuracy <- sum(tescore) / length(tescore)

#accuracy after cross validating 10 times
accuracy

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

## Part C: NB with package

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

#create training and testing sets
test_accuracies <- array(dim=10)

for (wi in 1:10){
  datasplit <- createDataPartition(y=y_labels, p=.8, list=FALSE)
  trainx <- x_vector[datasplit,]
  trainy <- y_labels[datasplit]
  testx <- x_vector[-datasplit,]
  testy <- y_labels[-datasplit]

  #train naive bayes model using klaR package
  tr <- trainControl(method='cv' , number=10)
  model <- train (trainx , factor(trainy) , 'nb' , trControl=tr)

  #prediction
  predictions <- predict(model, newdata=testx)
  correct <- length(testy[testy == predictions])
  wrong <- length(testy[testy != predictions])
  accuracy <- correct / (correct + wrong)
  test_accuracies[wi] <- accuracy
}
cross_validation_accuracy <- sum(test_accuracies)/length(test_accuracies)

#accuracy after cross validating 10 times
cross_validation_accuracy

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

## Part D: Using SVMLight

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

#create data sets for training and testing
datasplit<-createDataPartition(y=y_labels, p=.8, list=FALSE)
trainx <- x_vector[datasplit,]
trainy <- y_labels[datasplit]
testx <- x_vector[-datasplit,]
testy <- y_labels[-datasplit]

#train svm
svm <- svmlight(trainx, factor(trainy), pathsvm="/Users/bradjballard/svm_light_osx.8.4_i7/")
labels <- predict(svm, testx)
answers <- labels$class

#accuracy
correct <- sum(answers == testy)
wrong <- sum(answers != testy)
accuracy <- correct / (correct + wrong)
accuracy


model_netradiation <- function (minTair = 0.7,
         maxTair = 7.2,
         albedoCoefficient = 0.23,
         stefanBoltzman = 4.903e-09,
         elevation = 0.0,
         solarRadiation = 3.0,
         vaporPressure = 6.1,
         extraSolarRadiation = 11.7){
    #'- Name: NetRadiation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: NetRadiation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * Abstract: It is calculated at the surface of the canopy and is givenby the difference between incoming and outgoing radiation of both short
    #'                     and long wavelength radiation
    #'- inputs:
    #'            * name: minTair
    #'                          ** description : minimum air temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 0.7
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: maxTair
    #'                          ** description : maximum air Temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 7.2
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: albedoCoefficient
    #'                          ** description : albedo Coefficient
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.23
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: stefanBoltzman
    #'                          ** description : stefan Boltzman constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.903E-09
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: elevation
    #'                          ** description : elevation
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0
    #'                          ** min : -500
    #'                          ** max : 10000
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: solarRadiation
    #'                          ** description : solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 3
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: vaporPressure
    #'                          ** description : vapor Pressure
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 6.1
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: extraSolarRadiation
    #'                          ** description : extra Solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 11.7
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: netRadiation
    #'                          ** description :  net radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: netOutGoingLongWaveRadiation
    #'                          ** description : net OutGoing Long Wave Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    Nsr <- (1.0 - albedoCoefficient) * solarRadiation
    clearSkySolarRadiation <- (0.75 + (2 * 10.0 ^ (-5) * elevation)) * extraSolarRadiation
    averageT <- ((maxTair + 273.16) ^ 4 + (minTair + 273.16) ^ 4) / 2.0
    surfaceEmissivity <- 0.34 - (0.14 * sqrt(vaporPressure / 10.0))
    cloudCoverFactor <- 1.35 * (solarRadiation / clearSkySolarRadiation) - 0.35
    Nolr <- stefanBoltzman * averageT * surfaceEmissivity * cloudCoverFactor
    netRadiation <- Nsr - Nolr
    netOutGoingLongWaveRadiation <- Nolr
    return (list ("netRadiation" = netRadiation,"netOutGoingLongWaveRadiation" = netOutGoingLongWaveRadiation))
}


=begin
  # sample-factorize04.rb

  require "algebra"

  A = AlgebraicExtensionField(Rational, "a") {|a| a**2 - 2}
  B = AlgebraicExtensionField(A, "b"){|b| b**2 + 1}
  P = Polynomial(B, "x")
  x = P.var
  f = x**4 + 1
  p f.factorize
  #=> (x - 1/2ab - 1/2a)(x + 1/2ab - 1/2a)(x + 1/2ab + 1/2a)(x - 1/2ab + 1/2a)
((<_|CONTENTS>))
=end


source("svdopt.r")
predict_svd = predict

hybrid_meta <- function(ratings, features, k = 2) {
	cat("Training SVD Model...", "\n")
	svd = svdopt(ratings, k = 2)

	colnames(ratings) = c("userId", "itemId", "ratings")
	library(reshape2)
	ratings = dcast(ratings, userId~itemId, value.var = "ratings", na.rm=FALSE)
	ratings[is.na(ratings)==T] = 0
	ratings = ratings[,-1]

	library(proxy)
	sim = as.matrix(simil(svd$Q))
	sim[is.na(sim)==T] = 0

	model = list()
	model$sim = sim
	model$k = k
	model$ratings = ratings

	return(model)
}

predict <- function(model, user, item) {
	similar.items = order(-model$sim[item, ])
	rated.items = which(model$ratings[user, ] > 0)
	most.similar.rated = intersect(similar.items, rated.items)[1:model$k]

	sum = 0
	sumWeight = 0
	for(j in most.similar.rated) {
		sum = sum + model$sim[item, j]
		sumWeight = sumWeight + model$sim[item, j] * model$ratings[user, j]
	}

	return(sumWeight / sum)
}


library(h2o)
h2o.init()

ausPath = system.file("extdata", "australia.csv", package="h2o")
australia.hex = h2o.uploadFile(path = ausPath)
summary(australia.hex)

pca_model=h2o.prcomp(training_frame = australia.hex,
                     k = 8,
                     transform = "STANDARDIZE")

summary(pca_model)
barplot(as.numeric(pca_model@model$importance[2,]),
        main="Pca model",
        xlab="Pca component",
        ylab="Proportion of Variance")


############################################################
# kmer_model.r
#
# Read in a file full of kmer coverages, and optimize
# a probabilistic model in which kmer coverage is simulated
# as follows:
#
# 1. Choose error or no as binomial(p.e)
# 2. Choose copy number as zeta(p)
# 3a. If error, choose coverage as my discrete pareto(p)
# 3b. If not, choose coverage as normal(copy*u.v, var.v)
#
# Finally, output the ratio of being an error kmer vs being
# a non-error kmer for varying levels of low coverage.
############################################################
library(VGAM)

# get ratio from input
if(length(commandArgs(trailingOnly=TRUE)) > 0) {
  ratio.goal = as.integer(commandArgs(trailingOnly=TRUE)[1])
} else {
  ratio.goal = 1000
}

outf = "cutoff.txt"
max.copy = 30

############################################################
# est.cov
#
# Estimate the coverage mean by finding the max past the
# first valley.
############################################################
est.cov = function(d) {
  hc = d[,2]

  # find first valley (or right before it)
  valley = hc[1]
  i = 2
  while(hc[i] < valley) {
    valley = hc[i]
    i = i + 1
  }

  # return max over the rest
  max.hist = hc[i]
  max.cov = i
  while(i <= length(hc)) {
    if(hc[i] > max.hist) {
      max.hist = hc[i]
      max.cov = i
    }
    i = i + 1
  }
  return( max.cov )
}

############################################################
# load data
############################################################
cov = read.table('kmers.hist')[,1:2]
cov.est = est.cov(cov)

# filter extremes from kmers
cov = cov[cov[,1] < 1.25*max.copy*cov.est,]
max.cov = max(cov[,1])

############################################################
# model
############################################################
model = function(params) {
  print(params)

  zp.copy = params[1]
  p.e = params[2]
  shape.e = params[3]
  u.v = params[4]
  var.v = params[5]

  if(zp.copy <= 0 | shape.e <= 0 | var.v <= 0)
    return(list(like=-Inf))

  dcopy = dzeta(1:max.copy, zp.copy)

  kmers.probs = matrix(0, dim(cov)[1], ncol=(max.copy+1))

  # error
  pp = ppareto(1:(max.cov+1), 1, shape.e)
  derr = pp[2:(max.cov+1)] - pp[1:max.cov]
  kmers.probs[,1] = p.e * derr[cov[,1]]

  # no error
  for(copy in 1:max.copy) {
    kmers.probs[,1+copy] = dcopy[copy] * (1-p.e) * dnorm(cov[,1], mean=(copy*u.v), sd=sqrt(copy*var.v))
  }

  logprobs = log(apply(kmers.probs, 1, sum))
  print(sum(logprobs*cov[,2]))
  return(list(like=-sum(logprobs*cov[,2]), probs=kmers.probs))
}

############################################################
# display.params
############################################################
display.params = function(x, print) {
  if(print) {
    cat("zp.copy: ",x[1],"\n", file=outf, append=T)
    cat("p.e: ",x[2],"\n", file=outf, append=T)
    cat("shape.e: ",x[3],"\n", file=outf, append=T)
    cat("u.v: ",x[4],"\n", file=outf, append=T)
    cat("var.v: ",x[5],"\n", file=outf, append=T)
  }
  return(list(zp.copy=x[1], p.e=x[2], shape.e=x[3], u.v=x[4], var.v=x[5]))
}

############################################################
# cutoffs
############################################################
cutoffs = function(p) {
  dcopy = dzeta(1:max.copy, p$zp.copy)
  pp = ppareto(1:(max.cov+1), 1, p$shape.e)
  derr = pp[2:(max.cov+1)] - pp[1:max.cov]

  ratios = rep(0,40)
  for(cov in 1:40) {
    error = p$p.e * derr[cov]

    no.error.list = rep(0,max.copy)
    for(copy in 1:max.copy) {
      no.error.list[copy] = dcopy[copy] * (1-p$p.e) * dnorm(cov, mean=(copy*p$u.v), sd=sqrt(copy*p$var.v))
    }

    ratios[cov] = error / sum(no.error.list)
  }
  return(ratios)
}

############################################################
# action
############################################################
init = c(3, .9, 3, cov.est, 5*cov.est)
#ol = c(.001, .001, 0.001, 0, 10)
#ou = c(20, .999, 20, 1000, Inf)
#opt = optim(init, function(x) model(x)$like, lower=ol, upper=ou, method="L-BFGS-B", control=list(trace=1, maxit=1000))
opt = optim(init, function(x) model(x)$like, method="BFGS", control=list(trace=1, maxit=5000))
cat('value:',opt$value,"\n")
p=display.params(opt$par, F)

cut = min((1:40)[cutoffs(p) < ratio.goal])
cat(cut,"\n", file=outf)

display.params(opt$par, T)
write(cutoffs(p), file=outf, append=T)

max.x = 250
dcopy = dzeta(1:max.copy, p$zp.copy)
pp = ppareto(1:(max.cov+1), 1, p$shape.e)
derr = pp[2:(max.cov+1)] - pp[1:max.cov]

kmers.probs = matrix(0, max.x, ncol=(1+max.copy))
# error
kmers.probs[,1] = p$p.e * derr[1:max.x]
# no error
for(copy in 1:max.copy) {
  kmers.probs[,1+copy] = dcopy[copy] * (1-p$p.e) * dnorm(1:max.x, mean=(copy*p$u.v), sd=sqrt(copy*p$var.v))
}

all.dist = apply(kmers.probs, 1, sum)
err.dist = kmers.probs[,1]/p$p.e
norm.dist = apply(kmers.probs[,2:(1+max.copy)], 1, sum)/(1-p$p.e)

ratios = err.dist*p$p.e / norm.dist/(1-p$p.e)


#' Compute the "resolution" of a numeric vector
#'
#' The resolution is the smallest non-zero distance between adjacent
#' values.  If there is only one unique value, then the resolution is defined
#' to be one. If x is an integer vector, then it is assumed to represent a
#' discrete variable, and the resolution is 1.
#'
#' @param x numeric vector
#' @param zero should a zero value be automatically included in the
#'   computation of resolution
#' @export
#' @examples
#' resolution(1:10)
#' resolution((1:10) - 0.5)
#' resolution((1:10) - 0.5, FALSE)
#'
#' # Note the difference between numeric and integer vectors
#' resolution(c(2, 10, 20, 50))
#' resolution(c(2L, 10L, 20L, 50L))
resolution <- function(x, zero = TRUE) {
  if (is.integer(x) || zero_range(range(x, na.rm = TRUE)))
    return(1)

  x <- unique(as.numeric(x))
  if (zero) {
    x <- unique(c(0, x))
  }

  min(diff(sort(x)))
}


#' @title
#' Multivatiate functional regression via nested reduced-rank regularization
#'
#' @description
#' This function takes functional observations as input and fits a nested
#' reduced-rank regression with a user-specified rank selection method.
#' The B-spline basis is used to conduct basis expansion.
#'
#' @usage
#' NRRR.func(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
#'           tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[1],
#'           nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
#'           lambda = 0, maxiter = 300, conv = 1e-4,
#'           dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
#'           yrankfix = NULL, lang = c('R', 'Rcpp')[1])
#'
#' @param Y a data frame of the functional responses with d columns
#'          for the values of the response components, a column indicating subject ID named as 'ID'
#'          and a column of observation times named as 'TIME'.
#' @param X a data frame of the functional predictors with p columns
#'          for the values of the predictor components, a column indicating subject ID named as 'ID'
#'          and a column of observation times named as 'TIME'. Order of Subject ID should be the SAME as that of Y.
#' @param jx number of basis functions to expand the predictor trajectory.
#' @param jy number of basis functions to expand the response trajectory.
#' @param S.interval range of observation times of X, e.g., \code{S.interval = c(0, 1)}. Default is NULL.
#' @param T.interval range of observation times of Y, e.g., \code{T.interval = c(0, 1)}. Default is NULL.
#' @param degree degree of piecewise polynomial. Default is 3. See \code{\link{bs}}.
#' @param tuning methods to select ranks. If \code{tuning = 'CV'}, then cross validation
#'               is used to select ranks. Otherwise, the selected information criterion
#'               is used to select ranks.
#' @param nfold the number of folds used in cross validation. Default is 10.
#' @param norder a vector of length n that assigns samples to multiple folds for cross validation.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'}.
#'               Default is 0.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 300.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
#' @param dimred a vector of logical values to decide whether to use the specified tuning method
#'               do rank selection on certain dimensions. TRUE means the rank is selected
#'               by the specified tuning method.
#'               If \code{dimred[1] = FALSE}, r is provided by \code{rankfix}
#'               or \eqn{min(jy*d, rank(X))};
#'               If \code{dimred[2] = FALSE}, rx equals to \code{xrankfix} or p;
#'               If \code{dimred[3] = FALSE},
#'               ry equals to \code{yrankfix} or d.
#'               Default is \code{c(TRUE, TRUE, TRUE)}.
#' @param rankfix a user-provided value of r when \code{dimred[1] = FALSE}. Default is NULL
#'                which leads to \eqn{r = min(jy*d, rank(X))}.
#' @param xrankfix a user-provided value of rx when \code{dimred[2] = FALSE}. Default is NULL
#'                 which leads to \code{rx = p}.
#' @param yrankfix a user-provided value of ry when \code{dimred[3] = FALSE}. Default is NULL
#'                 which leads to \code{ry = d}.
#' @param lang 'R' (default): the R version function is used; 'Rcpp': the Rcpp
#'             version function is used.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{the estimated degrees of freedom of the selected model.}
#'   \item{sse}{the sum of squared errors of the selected model.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV of the selected model.}
#'   \item{rx_path}{a matrix displays the path of selecting rx with cross validation. Only available when 'CV' is selected.}
#'   \item{ry_path}{a matrix displays the path of selecting ry with cross validation. Only available when 'CV' is selected.}
#'   \item{r_path}{a matrix displays the path of selecting r with cross validation. Only available when 'CV' is selected.}
#   \item{iter}{the number of iterations needed to converge in the selected model.}
#'   \item{rank}{the estimated r.}
#'   \item{rx}{the estimated rx.}
#'   \item{ry}{the estimated ry.}
#'   \item{sseq}{sequence of the time points of observing the predictor trajectory.}
#'   \item{phi}{the basis functions to expand the predictor trajectory.}
#'   \item{tseq}{sequence of the time points of observing the response trajectory.}
#'   \item{psi}{the basis functions to expand the response trajectory.}
#'
#' @details
#' This function applies a basis expansion and truncation method to transform
#' the functional problem into a classical finite-dimensional regression problem,
#' and then fits a nested reduced-rank regression.
#' The functional observations are commonly collected in a discrete mannar, and before using this
#' function, the functional response observations and functional predictor observations
#' should be saved as a data frame. Data standardization procedures, e.g., centering or
#' scaling, should be conducted before using this function. B-spline basis is
#' used to conduct basis expansion. If the functional data are already processed into an integrated form,
#' functions like \code{\link{NRRR.est}}, \code{\link{NRRR.ic}} or \code{\link{NRRR.cv}} can
#' be used to fit a NRRR model.
#'
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#'
#' @examples
#' n <- 100
#' ns <- 80
#' nt <- 80
#' p <- 10
#' d <- 10
#' jx <- 8
#' jy <- 8
#' library(NRRR)
#' set.seed(3)
#' # generate functional data
#' simDat <- NRRR.sim(n = 100, ns = 80, nt = 80, r = 3, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 10, d = 10, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' # dimension: c(n, d, nt)
#' dim(simDat$Y)
#' # dimension: c(n, p, ns)
#' dim(simDat$X)
#' # process the functional data into a data frame with columns:
#' # predictor/response components, subject ID, and observation time
#'
#' Y <- t(simDat$Y[1,,])
#' for (i in 2:n){
#'   Y <- rbind(Y, t(simDat$Y[i,,]))
#' }
#' Y <- data.frame(Y)
#' Y$TIME <- rep(simDat$tseq, n)
#' Y$ID <- rep(1:n, each = nt) # Y: nt*n rows, d+2 columns
#' head(Y)
#'
#' X <- t(simDat$X[1,,])
#' for (i in 2:n){
#'   X <- rbind(X, t(simDat$X[i,,]))
#' }
#' X <- data.frame(X)
#' X$TIME <- rep(simDat$sseq, n)
#' X$ID <- rep(1:n, each = ns) # X: ns*n rows, p+2 columns
#' head(X)
#'
#' fit_func <- NRRR.func(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
#'                       tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[2],
#'                       nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
#'                       lambda = 0, maxiter = 300, conv = 1e-4,
#'                       dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
#'                       yrankfix = NULL, lang = c('R', 'Rcpp')[1])
#' @export
NRRR.func <- function(Y, X, jx, jy, degree = 3, S.interval = NULL, T.interval = NULL,
                      tuning = c('CV', 'BIC', 'BICP', 'AIC', 'GCV')[1],
                      nfold = 10, norder = NULL, method = c('RRR', 'RRS')[1],
                      lambda = 0, maxiter = 300, conv = 1e-4,
                      dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
                      yrankfix = NULL, lang = c('R', 'Rcpp')[1]){

  # X and Y are data.frames or matrices
  X <- as.data.frame(X)
  Y <- as.data.frame(Y)

  if(is.null(S.interval)) {
    S.interval <- range(X[, "TIME"])
  } else {
    filter_id <- X[, "TIME"] >= S.interval[1]
    filter_id <- X[filter_id, "TIME"] <= S.interval[2]
    X <- X[filter_id, ]
  }
  if(nrow(X) == 0) stop("S.interval is out of range of observed data points in X.")

  if(is.null(T.interval)) {
    T.interval <- range(Y[, "TIME"])
  } else {
    filter_id <- Y[, "TIME"] >= T.interval[1]
    filter_id <- Y[filter_id, "TIME"] <= T.interval[2]
    Y <- Y[filter_id, ]
  }
  if(nrow(Y) == 0) stop("T.interval is out of range of observed data points in Y.")

  nx <- length(unique(X[,"ID"]))
  p <- ncol(X) - 2
  ny <- length(unique(Y[,"ID"]))
  d <- ncol(Y) - 2
  if (nx != ny) stop("The same number of observations in predictor and response is required")
  n <- nx

  X.list <- split(X[, which(!colnames(X)%in%c("ID"))], X[, "ID"])
  Xint <- array(dim = c(n, p, jx), NA)
  for (i in 1:n){
    x <- X.list[[i]]
    sseq <- sort(unique(x[, "TIME"]))
    ns <- length(sseq)
    if (ns != dim(x)[1]) stop("repeated observations in X")
    x <- x[order(x[, "TIME"]), ]  # ns-by-p
    x <- as.matrix(x[, -which(colnames(x) == "TIME")])
    phi <- splines::bs(x = c(0, sseq), df = jx, degree = degree)[-1,]
    sdiff <- (sseq - c(0, sseq[-ns]))
    for (l in 1:p){
      for (j in 1:jx){
        Xint[i, l, j] <- sum(phi[, j] * x[ , l] * sdiff)
      }
    }
  }

  # compute Jpsi and Jpsi^{-1/2}
  tseq <- sort(unique(Y[, "TIME"]))
  nt <- length(tseq)
  psi <- splines::bs(x = c(0, tseq), df = jy, degree = degree)[-1,]
  Jpsi <- matrix(nrow = jy, ncol = jy, 0)
  tdiff <- (tseq - c(0, tseq[-nt]))
  for (t in 1:nt) Jpsi <- Jpsi + psi[t, ] %*% t(psi[t, ]) * tdiff[t]
  eJpsi <- eigen(Jpsi)
  Jpsihalf <- eJpsi$vectors %*% diag(sqrt(eJpsi$values)) %*% t(eJpsi$vectors)
  Jpsihalfinv <- eJpsi$vectors %*% diag(1 / sqrt(eJpsi$values)) %*% t(eJpsi$vectors)

  Y.list <- split(Y[, which(!colnames(Y)%in%c("ID"))], Y[, "ID"])
  Yint <- array(dim = c(n, d, jy), NA)
  for (i in 1:n){
    y <- Y.list[[i]]
    tseq <- sort(unique(y[, "TIME"]))
    nt <- length(tseq)
    if (nt != dim(y)[1]) stop("repeated observations in Y")
    y <- y[order(y[, "TIME"]), ]  # nt-by-d
    y <- as.matrix(y[, -which(colnames(y) == "TIME")])
    psi <- splines::bs(x = c(0, tseq), df = jy, degree = degree)[-1,]
    psistar <- psi %*% Jpsihalfinv
    tdiff <- (tseq - c(0,tseq[-nt]))
    for (l in 1:d){
      for (j in 1:jy){
        Yint[i, l, j] <- sum(psistar[, j] * y[ , l] * tdiff)
      }
    }
  }

  # obtain matrices Y and X in matrix approximation form
  Yest <- Yint[, , 1]
  for (j in 2:jy) Yest <- cbind(Yest, Yint[, , j])

  Xest <- Xint[, , 1]
  for (j in 2:jx) Xest <- cbind(Xest, Xint[, , j])

  if (tuning == 'CV') {
    fit.nrrr <- NRRR.cv(Yest, Xest, nfold, norder, Ag0 = NULL, Bg0 = NULL,
                        jx, jy, p, d, n, maxiter, conv, method, lambda,
                        dimred, rankfix, xrankfix, yrankfix, lang)
  } else {
    fit.nrrr <- NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
                        jx, jy, p, d, n, maxiter, conv,
                        method, lambda, ic = tuning,
                        dimred, rankfix, lang)
  }
  fit.nrrr$sseq <- sseq
  fit.nrrr$phi <- phi
  fit.nrrr$tseq <- tseq
  fit.nrrr$psi <- psi
  return(fit.nrrr)
}


chart.Correlation2<-function (R, histogram = TRUE, method = c("pearson", "kendall",
    "spearman"), ...)
{
# note this is PerformanceAnalytics::chart.Correlation with improved font
	# PerformanceAnalytics: Econometric Tools for Performance and Risk Analysis (Brian G Peterson and Peter Carl)
	# https://cran.r-project.org/web/packages/PerformanceAnalytics/PerformanceAnalytics.pdf

    x = checkData(R, method = "matrix")
    if (missing(method))
        method = method[1]
    cormeth <- method
    panel.cor <- function(x, y, digits = 2, prefix = "", use = "pairwise.complete.obs",
        method = cormeth, cex.cor, ...) {
        usr <- par("usr")
        on.exit(par(usr))
        par(usr = c(0, 1, 0, 1))
        r <- cor(x, y, use = use, method = method)
        txt <- format(c(r, 0.123456789), digits = digits)[1]
        txt <- paste(prefix, txt, sep = "")
        if (missing(cex.cor))
            cex <- 0.8/strwidth(txt)
        test <- cor.test(as.numeric(x), as.numeric(y), method = method)
        Signif <- symnum(test$p.value, corr = FALSE, na = FALSE,
            cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***",
                "**", "*", ".", " "))
        text(0.5, 0.5, txt, cex = cex * (abs(r) + 0.3)/1.3)
        text(0.8, 0.8, Signif, cex = cex, col = 2)
    }
    f <- function(t) {
        dnorm(t, mean = mean(x), sd = sd.xts(x))
    }
    dotargs <- list(...)
    dotargs$method <- NULL
    rm(method)
    hist.panel = function(x, ... = NULL) {
        par(new = TRUE)
        hist(x, col = "light gray", probability = TRUE, axes = FALSE,
            main = "", breaks = "FD")
        lines(density(x, na.rm = TRUE), col = "red", lwd = 1)
        rug(x)
    }
    if (histogram)
        pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor,
            diag.panel = hist.panel)
    else pairs(x, gap = 0, lower.panel = panel.smooth, upper.panel = panel.cor, cex.labels=1.1, font.labels=2)
}


spiral_matrix <- function(n) {
    spiralv <- function(v) {
        n <- sqrt(length(v))
        if (n != floor(n))
            stop("length of v should be a square of an integer")
        if (n == 0)
            stop("v should be of positive length")
        if (n == 1)
            m <- matrix(v, 1, 1)
        else
            m <- rbind(v[1:n], cbind(spiralv(v[(2 * n):(n^2)])[(n - 1):1, (n - 1):1], v[(n + 1):(2 * n - 1)]))
        m
    }
    spiralv(1:(n^2))
}


# Enter your code here. Read input from STDIN. Print output to STDOUT
val <- pnorm(9800, 205 * 49, sqrt( 49 * (15 ^ 2) ))
write(round(val, 4), stdout())


# 4. faza: Napredna analiza podatkov
library(ranger)
library(randomForest)

set.seed(123)

#KORELACIJA MED BDP PER CAPITA IN ŠTEVILOM VELEMOJSTROV
velemojstri_drzave <- velemojstri_drzave[complete.cases(velemojstri_drzave),]
bdp_gm <- ggplot(velemojstri_drzave, aes(x=`BDP_per_capita`, y=`Stevilo_velemojstrov`)) + geom_point()

linearna1 <- lm(data = velemojstri_drzave, velemojstri_drzave$BDP_per_capita ~ velemojstri_drzave$Stevilo_velemojstrov)

premica1 <- bdp_gm + geom_smooth(method = "lm", formula = y ~ x) +
  labs(y = "Velemojstri") +
  labs(x = "BDP per capita") +
  ggtitle("Korelacija med BDP per capita in velemojstri")

#KORELACIJA MED BDP PER CAPITA IN ŠTEVILOM VELEMOJSTROV PER CAPITA
bdp_gm_pc <- ggplot(velemojstri_drzave, aes(x=`BDP_per_capita`, y=`Velemojstri_per_capita`)) + geom_point()

linearna2 <- lm(data = velemojstri_drzave, velemojstri_drzave$BDP_per_capita ~ velemojstri_drzave$Velemojstri_per_capita)

premica2 <- bdp_gm_pc + geom_smooth(method = "lm", formula = y ~ x) +
  labs(y = "Velemojstri per capita") +
  labs(x = "BDP per capita") +
  ggtitle("Korelacija med BDP per capita in velemojstri per capita")

#REGRESIJA, NAPOVEDOVANJE

# Datume dam v numericno obliko kot stevilo dnevov od 1/1/1970
igre_magnus_otb_ratingi$Date.numeric = as.numeric(igre_magnus_otb_ratingi$Date)
#igre_magnus_otb_ratingi$ID <- seq.int(nrow(igre_magnus_otb_ratingi))

#4. stopnja, ker se najbolj prilega ratingu 1.2.2022
# prileganje <- lm(Rating_Magnusa ~ poly(Date.numeric,4), data=igre_magnus_otb_ratingi)
#napovedni_datumi <- data.frame(Date.numeric = as.numeric(as.Date(c("2022-02-01","2022-08-01","2023-02-01", "2023-08-01"))))
#
# prediction <- mutate(napovedni_datumi, Rating_Magnusa = predict(prileganje, napovedni_datumi,interval = "prediction"))
# prediction["Date"] <- as.Date(as.numeric(prediction$Date.numeric), origin = "1970-01-01")
# prediction <- prediction[,c(2,3,1)]
#
# graf_napovedi <- ggplot(igre_magnus_otb_ratingi, aes(x=Date, y=Rating_Magnusa)) + geom_point()
# graf_napovedi
#
# igre_magnus_otb_ratingi <- rbind(igre_magnus_otb_ratingi, prediction)
#
# regresija <- igre_magnus_otb_ratingi %>%ggplot(aes(x=Date,y=Rating_Magnusa))+
#   geom_smooth(method='lm', fullrange=TRUE, color='red', formula=y ~ poly(x,4,raw=TRUE)) +
#   geom_point()
#
#
# graf_napoved <- ggplot() +
#   geom_point(aes(x = Date,y = Rating_Magnusa),data=head(igre_magnus_otb_ratingi,-4),colour = '#3399ff', size=1) +
#   geom_point(aes(x = Date,y = Rating_Magnusa),data=tail(igre_magnus_otb_ratingi,4),colour = '#ff00ff', size=2) +
#   geom_smooth(data=head(igre_magnus_otb_ratingi,-3), aes(x = Date, y= Rating_Magnusa),method='lm', fullrange=TRUE, color='red', formula=y ~ poly(x,4,raw=TRUE)) +
#   xlab(label = 'Leto') +
#   ylab(label = 'Rating')

#regresija

#Primerjal napake različnih modelov, na koncu se odločil za naključne gozdove

# formule <- c(Rating_Magnusa ~ poly(Date.numeric,1),
#              Rating_Magnusa ~ poly(Date.numeric,2),
#              Rating_Magnusa ~ poly(Date.numeric,3),
#              Rating_Magnusa ~ poly(Date.numeric,4),
#              Rating_Magnusa ~ poly(Date.numeric,5),
#              Rating_Magnusa ~ poly(Date.numeric,6),
#              Rating_Magnusa ~ poly(Date.numeric,7),
#              Rating_Magnusa ~ poly(Date.numeric,8),
#              Rating_Magnusa ~ poly(Date.numeric,9),
#              Rating_Magnusa ~ poly(Date.numeric,10))

# napake <- rep(0, 15)
# for (i in 1:15){
#   formula <- Rating_Magnusa ~ poly(Date.numeric,i)
#   model <- igre_magnus_otb_ratingi %>% ucenje(formula, "lin.reg")
#   napaka <- napaka_regresije(igre_magnus_otb_ratingi, model, "lin.reg")
#   napake[i] <- napaka
# }
# which.min(napake)
# napake

#lin.model <- igre_magnus_otb_ratingi %>% ucenje(Rating_Magnusa ~ poly(Date.numeric,8), "lin.reg")
#lin.model
#print(igre_magnus_otb_ratingi %>% napaka_regresije(lin.model, "lin.reg"))
#pp.ratingi <- pp.razbitje(10, stratifikacija = igre_magnus_otb_ratingi)
#pp.ratingi <- razbitje(igre_magnus_otb_ratingi,10)

#print(precno.preverjanje(igre_magnus_otb_ratingi, pp.ratingi,Rating_Magnusa ~ poly(Date.numeric,11),"lin.reg", F))
#precno.preverjanje(igre_magnus_otb_ratingi, pp.ratingi,Rating_Magnusa ~ poly(Date.numeric,11),"lin.reg", F)

#ng.model <- igre_magnus_otb_ratingi %>% ucenje(Rating_Magnusa ~ Date.numeric, "ng")
#napaka.ng <- igre_magnus_otb_ratingi %>% napaka_regresije(ng.model, "ng")
#napaka.ng
#p1 = predict(ng.model, data = igre_magnus_otb_ratingi)
#head(p1)

#prediction <- mutate(napovedni_datumi, Rating_Magnusa = predict(ng.model, data=igre_magnus_otb_ratingi))

#
# pp <- pp.razbitje(igre_magnus_otb_ratingi)
# razbitje1 <- razbitje(igre_magnus_otb_ratingi[-2], 3)
# pp
# razbitje1
#print(precno.preverjanje(igre_magnus_otb_ratingi[-2], razbitje1,Rating_Magnusa ~ Date.numeric , "ng", FALSE))

ratingi <- igre_magnus_otb_ratingi[,1]
ratingi

Lag <- function(x, n) {c(rep(NA, n), x)[1:length(x)]
}

naredi.df <- function(x){
  data.frame(ratingi = x, ratingi1 = Lag(x,1), ratingi2 = Lag(x,2))
}
df.ng <- naredi.df(c(ratingi))
df.ng
model1 <- ranger(formula = ratingi ~ ., data = df.ng %>% drop_na())

n <- nrow(df.ng)
for(i in 1:12) {
  df.ng <- naredi.df(c(df.ng$ratingi, NA))
  napoved <- predict(model1, data = df.ng[n+i,])$predictions
  df.ng[n+i,1] <- napoved
}

napovedi <- df.ng[(n+1):(n+12),1] %>% round()

napovedi
napovedni_meseci <- c(as.Date(c("2022-02-01","2022-04-01","2022-06-01", "2022-08-01",
                                "2022-10-01","2022-12-01","2023-02-01", "2023-04-01",
                                "2023-06-01","2023-08-01","2023-10-01", "2023-12-01")))
ratingi <- c(ratingi, napovedi)
napovedi.df <- data.frame(Rating_Magnusa = napovedi, Date = napovedni_meseci, Date.numeric = as.numeric(napovedni_meseci))
igre_magnus_otb_ratingi <- rbind(igre_magnus_otb_ratingi, napovedi.df)

graf_napoved <- ggplot() +
  geom_point(aes(x = Date,y = Rating_Magnusa),data=head(igre_magnus_otb_ratingi,-12),colour = '#3399ff', size=0.8) +
  geom_point(aes(x = Date,y = Rating_Magnusa),data=tail(igre_magnus_otb_ratingi,12),colour = '#ff00ff', size=0.8) +
  xlab(label = 'Leto') +
  ylab(label = 'Rating')

graf_napoved

ratingi

#Razvrščanje v skupine
set.seed(50)
velemojstri_drzave$Stevilo_velemojstrov <- as.numeric(velemojstri_drzave$Stevilo_velemojstrov)
velemojstri_drzave$Populacija <- as.numeric(velemojstri_drzave$Populacija)
velemojstri_drzave$Velemojstri_per_capita <- as.numeric(velemojstri_drzave$Velemojstri_per_capita)
velemojstri_drzave$BDP_per_capita <- as.numeric(velemojstri_drzave$BDP_per_capita)
velemojstri_drzave_skupine <- scale(velemojstri_drzave[,-1])
velemojstri_drzave[,-1] <- velemojstri_drzave_skupine
velemojstri_drzave <- na.omit(velemojstri_drzave)

skupine <- velemojstri_drzave[,-1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()
#print(skupine)

velemojstri_drzave["Skupina"] <- skupine
#velemojstri_drzave[,2:5] <- NULL
velemojstri_drzave_zemljevid <- left_join(velemojstri_drzave_zemljevid, velemojstri_drzave, by="Drzava")

zemljevid4 <- tm_shape(velemojstri_drzave_zemljevid) +
  tm_fill("Skupina", title = "Razvrstitev glede na BDP, število velemojstrov in številu prebivalcev",
          popup.vars = c("Skupina" = "Skupina")) +
  tm_borders() +
  tm_view(view.legend.position = c("right", "bottom"))
zemljevid4

#Preveril optimalno število skupin
r.hc = velemojstri_drzave[, -1] %>% obrisi(hc = TRUE)
r.km = velemojstri_drzave[, -1] %>% obrisi(hc = FALSE)
diagram.obrisi(r.hc)
diagram.obrisi(r.km)
#Diagrama pokažeta, da sta optimalni števili 3 in 5, odločil sem se za 3, saj v primeru 5ih se pri prvem diagramu močno spustimo

#ggpairs(igre_magnus_otb_ratingi)

#datumi <- as.data.frame(as.Date(prediction$Date.numeric, "1970-01-01"))


pairsdf <- function(df, var, hist='yes', color='black') {
    ## usage: pairsdf(mtcars, c('mpg', 'cyl', 'disp'))
    ##        pairsdf(iris, hist='yes', col=iris$Species)
    ##        pairsdf(iris, c('Sepal.Length', 'Petal.Width', 'Petal.Length'),
    ##                hist='yes', col=iris$Species)
    dfcompare <- subset(df,select=var)
    if (hist == 'no') {
        pairs(dfcompare, col=color)
    } else {
        ## add histograms, fits, and correlation coefficients
        if (color == 'black') {
            ## default is black
            ## drop the color so histogram is not solid black
            pairs(dfcompare,
                  lower.panel=panel.cor,
                  upper.panel=panel.smooth,
                  diag.panel=panel.hist)
        } else {
            pairs(dfcompare,
                  lower.panel=panel.cor,
                  upper.panel=panel.smooth,
                  diag.panel=panel.hist,
                  col=color)
        }
    }
}

##----------------------------------------------------------------------------

panel.hist <- function(x, col='black', ...) {
    ## not sure how to get histogram for each color variable
    ## note can use python seaborn for this with R reticulate library
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(usr[1:2], 0, 1.5) )
    h <- hist(x, plot = FALSE)
    breaks <- h$breaks; nB <- length(breaks)
    y <- h$counts; y <- y/max(y)
    rect(breaks[-nB], 0, breaks[-1], y, ...)
}

##----------------------------------------------------------------------------

panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) {
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(0, 1, 0, 1))
    r <- abs(cor(x, y))
    txt <- format(c(r, 0.123456789), digits = digits)[1]
    txt <- paste0(prefix, txt)
    if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
    text(0.5, 0.5, txt, cex = cex.cor * r)
}

## pairs(iris,
##       lower.panel=panel.cor,
##       upper.panel=panel.smooth,
##       diag.panel=panel.hist)
## pairs(iris,
##       lower.panel=panel.cor,
##       upper.panel=panel.smooth,
##       diag.panel=panel.hist,
##       col=iris$Species)


# As one can see from
getDLLRegisteredRoutines(getLoadedDLLs()$base)
# R knows functions bitwiseAnd, bitwiseOr, bitwiseXor and bitwiseNot.
# Here is how to call them (see ?.Call for the calling mechanism):

.Call("bitwiseOr",  as.integer(12), as.integer(10))
.Call("bitwiseXor", as.integer(12), as.integer(10))
.Call("bitwiseAnd", as.integer(12), as.integer(10))
.Call("bitwiseNot", as.integer(12))

# It would be easy to embed these calls in R functions, for better readability
# Also, it's possible to call these functions on integer vectors:

.Call("bitwiseOr", c(5L, 2L), c(3L, 8L))


library(effsize)
 dataA <- c(5,7,9,5,10,10,9,7,8,10,9,8,2,8,10,3,8,1,9,10,10,4,9,7,8,10,8)
dataB <- c(10,8,6,7,10,9,10,9,8,9,10,8,10,8,7,8,8,10,9,9,10)
ks.test(dataA,dataB)
cohen.d(dataA,dataB)
cohen.d(dataA,dataB,hedges.correction=TRUE)


# Plot latency data and perform Test for Significance on spike probability
# across conditions
# Requires installation of packages: 'Skillings.Mack', 'ggplot2', 'cowplot'
library(Skillings.Mack)
library(ggplot2)
library(cowplot)
df = read.csv('data/data_cellAttached_latencies.csv')

# subset for all DAMGO experiments with a baseline value
df_DAMGO = df[rep(!is.nan(df$spike_latency_DAMGO[grep('baseDAMGO', df$conditionDAMGO)]),3),c('spike_latency_DAMGO', 'conditionDAMGO','cellDAMGO','expDAMGO')]
print('DAMGO AP latency Skillings-Mack analysis')
Ski.Mack(df_DAMGO$spike_latency_DAMGO,df_DAMGO$conditionDAMGO,df_DAMGO$cellDAMGO)
print('Paired Wilcoxon signed rank test baseline vs Damgo')
# define here the two groups to compare
first_group = df_DAMGO$spike_latency_DAMGO[df_DAMGO$conditionDAMGO=='baseDAMGO']
second_group = df_DAMGO$spike_latency_DAMGO[df_DAMGO$conditionDAMGO=='DAMGO']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

print('Paired Wilcoxon signed rank test Damgo vs CTAP')
# define here the two groups to compare
first_group = df_DAMGO$spike_latency_DAMGO[df_DAMGO$conditionDAMGO=='DAMGO']
second_group = df_DAMGO$spike_latency_DAMGO[df_DAMGO$conditionDAMGO=='DAMGOCTAP']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

# subset for all DPDPE experiments with a baseline value
df_DPDPE = df[rep(!is.nan(df$spike_latency_DPDPE[grep('baseDPDPE', df$conditionDPDPE)]),3),c('spike_latency_DPDPE', 'conditionDPDPE','cellDPDPE','expDPDPE')]
print('DPDPE AP latency Skillings-Mack analysis')
Ski.Mack(df_DPDPE$spike_latency_DPDPE,df_DPDPE$conditionDPDPE,df_DPDPE$cellDPDPE)
print('Paired Wilcoxon signed rank test baseline vs DPDPE')
# define here the two groups to compare
first_group = df_DPDPE$spike_latency_DPDPE[df_DPDPE$conditionDPDPE=='baseDPDPE']
second_group = df_DPDPE$spike_latency_DPDPE[df_DPDPE$conditionDPDPE=='DPDPE']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

print('Paired Wilcoxon signed rank test DPDPE vs Naltrindole')
# define here the two groups to compare
first_group = df_DPDPE$spike_latency_DPDPE[df_DPDPE$conditionDPDPE=='DPDPE']
second_group = df_DPDPE$spike_latency_DPDPE[df_DPDPE$conditionDPDPE=='DPDPENaltrindole']
# Below is required to calculate n and statistic in a sequence independent way
# (first vs second group and second vs first group)
wilcox_antero = wilcox.test(first_group, second_group, paired = TRUE)
wilcox_retro = wilcox.test(second_group, first_group, paired = TRUE)
statistic = min(c(wilcox_antero$statistic, wilcox_retro$statistic))
diff = c(first_group-second_group)
n = length(na.omit(diff[diff != 0]))
print(paste('W(', n, ') = ', statistic, '. p = ', wilcox_antero$p.value))

#for plotting combine condition and spike_latency columns.
spike_latencies = c(df_DAMGO$spike_latency_DAMGO,df_DPDPE$spike_latency_DPDPE)
conditions = factor(c(as.character(df_DAMGO$conditionDAMGO),as.character(df_DPDPE$conditionDPDPE)), levels=c('baseDAMGO', 'DAMGO','DAMGOCTAP','baseDPDPE','DPDPE','DPDPENaltrindole'))
df_plot = data.frame('condition'=conditions, 'spike_latency'=spike_latencies)
ggplot(data=df_plot, aes(x=condition, y=spike_latencies))+
    geom_boxplot()+
    coord_cartesian(ylim=c(0, 20))


# Generate and plot Dragon curve.
# translation of JavaScript v.#2: http://rosettacode.org/wiki/Dragon_curve#JavaScript
# 2/27/16 aev
# gpDragonCurve(ord, clr, fn, d, as, xsh, ysh)
# Where: ord - order (defines the number of line segments);
#   clr - color, fn - file name (.ext will be added), d - segment length,
#   as - axis scale, xsh - x-shift, ysh - y-shift
gpDragonCurve <- function(ord, clr, fn, d, as, xsh, ysh) {
  cat(" *** START:", date(), "order=",ord, "color=",clr, "\n");
  d=10; m=640; ms=as*m; n=bitwShiftL(1, ord);
  c=c1=c2=c2x=c2y=i1=0; x=y=x1=y1=0;
  if(fn=="") {fn="DCR"}
  pf=paste0(fn, ord, ".png");
  ttl=paste0("Dragon curve, ord=",ord);
  cat(" *** Plot file -", pf, "title:", ttl, "n=",n, "\n");
  plot(NA, xlim=c(-ms,ms), ylim=c(-ms,ms), xlab="", ylab="", main=ttl);
  for (i in 0:n) {
    segments(x1+xsh, y1+ysh, x+xsh, y+ysh, col=clr); x1=x; y1=y;
    c1=bitwAnd(c, 1); c2=bitwAnd(c, 2);
    c2x=d; if(c2>0) {c2x=(-1)*d}; c2y=(-1)*c2x;
    if(c1>0) {y=y+c2y} else {x=x+c2x}
    i1=i+1; ii=bitwAnd(i1, -i1); c=c+i1/ii;
  }
  dev.copy(png, filename=pf, width=m, height=m); # plot to png-file
  dev.off(); graphics.off();  # Cleaning
  cat(" *** END:",date(),"\n");
}
## Testing samples:
gpDragonCurve(7, "red", "", 20, 0.2, -30, -30)
##gpDragonCurve(11, "red", "", 10, 0.6, 100, 200)
gpDragonCurve(13, "navy", "", 10, 1, 300, -200)
##gpDragonCurve(15, "darkgreen", "", 10, 2, -450, -500)
gpDragonCurve(16, "darkgreen", "", 10, 3, -1050, -500)


setwd("C:\\Users\\dudey\\Desktop\\DTLAnalysis\\DowntownLineAnalysis\\csv\\resale_flat_prices")
residential_price_data <- read.csv("final.csv")
residential_price_index <- read.csv("residential-property-price-index-base-quarter-2009-q1-100-quarterly.csv")

library(dplyr)
library(lubridate)
library(zoo)

base_quarter <- "2000-Q1"
# Taking only non-landed and rebasing it for base_quarter
rpi2 <- residential_price_index %>%
  filter(property_type == "Non-Landed") %>%
  mutate(rebased_index = index / residential_price_index[residential_price_index$quarter == base_quarter & residential_price_index$property_type == "Non-Landed", ]$index) %>%
  select(quarter, index, rebased_index) %>%
  mutate(quarter = as.yearqtr(as.character(quarter), "%Y-Q%q"))

# Sanity Check
head(rpi2)
rpi2[rpi2$quarter == "2000 Q1",]
tail(rpi2)

# Preparing Residential Price Data
residential_price_data_2 <- residential_price_data %>%
  mutate(month = as.yearmon(month)) %>%
  mutate(quarter = as.yearqtr(month))

# Sanity Check
head(residential_price_data_2)

# Joining
residential_price_data_3 <- merge(residential_price_data_2,
                                  rpi2,
                                  c("quarter", "quarter"))

# Sanity Check
head(residential_price_data_3)

# Residential Price Data 4
residential_price_data_4 <- residential_price_data_3 %>%
  mutate(resale_price_rebased = resale_price / rebased_index)

# Sanity Check
head(residential_price_data_4)
tail(residential_price_data_4)
residential_price_data_4 %>%
  filter(month == as.yearmon("1990-01")) %>%
  filter(town == "TAMPINES") %>%
  group_by(flat_type, storey_range) %>%
  summarise(mean_rebased_price = mean(resale_price_rebased), mean_price = mean(resale_price))

residential_price_data_4 %>%
  filter(month == as.yearmon("2010-01")) %>%
  filter(town == "TAMPINES") %>%
  group_by(flat_type, storey_range) %>%
  summarise(mean_rebased_price = mean(resale_price_rebased), mean_price = mean(resale_price))

write.csv(x = residential_price_data_4, file = "residential_property_price_base_Q1_2000.csv")


rm(list = ls())
wd <- "H:\\gabilan-turbidity-tmdl\\stream-classification\\"

mon_stations <- read.csv(paste(wd, "gis-stream-classification\\tables\\mon_stations.csv", sep = "\\"))
mon_stations <- mon_stations[c("StationCode", "COMID", "GNIS_NAME", "StreamOrde", "SLOPE", "Q0001E")]
names(mon_stations) <- c("station", "comid", "name", "so", "m", "q")
mon_stations <- mon_stations[is.na(mon_stations$m) == FALSE , ]
mon_stations[c("m_class", "q_class")] <- NA
m_breaks <- c(0, 0.005, 0.02, 0.04, 0.10, 1)
q_breaks <- c(0, 1, 10, 100, 1000)
lapply(1:(length(m_breaks) - 1),
       function(x) {
            mon_stations$m_class[which(  mon_stations$m >= m_breaks[x]
                                       & mon_stations$m <  m_breaks[x + 1])] <<- x
       })
lapply(1:(length(q_breaks) - 1),
       function(x) {
            mon_stations$q_class[which(  mon_stations$q >= q_breaks[x]
                                       & mon_stations$q <  q_breaks[x + 1])] <<- x
       })

mon_data <- read.csv(paste(wd, "gis-stream-classification\\tables\\ceden_ntu_r3_2019-07-26.csv", sep = "\\"))
mon_data <- mon_data[c("StationCode", "SampleDate", "Result")]
names(mon_data) <- c("station", "date", "result")
# mon_data <- # dry months
#     mon_data[which(as.numeric(substr(mon_data$date, 6, 7)) > 4 & as.numeric(substr(mon_data$date, 6, 7)) < 10), ]

sites <- c("309GAB", "309NAD", "309ALG", "309ALD", "309JON", "309TEH", "309TEM", "309TDW", "309OLD", "309ASB", "309MER", "309ESP", "309RTA")
site_data <- droplevels(mon_data[mon_data$station %in% sites, ])
q25 <- tapply(X = site_data$result, INDEX = site_data$station, FUN = quantile, 0.25)
q50 <- tapply(X = site_data$result, INDEX = site_data$station, FUN = quantile, 0.5)
q75 <- tapply(X = site_data$result, INDEX = site_data$station, FUN = quantile, 0.75)
n <- tapply(X = site_data$result, INDEX = site_data$station, FUN = length)
results_tab <- cbind(n, q25, q50, q75)
write.csv(results_tab, "results_tab.csv")


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
setwd("your/working/directory/goes/here")
# Download the NBER-CES data and save it to a working directory
# Then, read in the CSV file
mfgdata <- read.csv("naics5811.csv")

# Convert columns which should be categorical variables from text
# Also pull out NAICS sectors
mfgdata$naicsind <- as.factor(mfgdata$naics)
mfgdata$naicssector <- as.factor(substr(mfgdata$naics, 1, 2))
mfgdata$yearfactor <- as.factor(mfgdata$year)

# Initialize percentage changes for value-added and investment
# Then, go through all the industries and calculate the log-return
# (percentage change) for each industry's value-added and investment.
# Also save last period's (lagged) percentage change in value-added.
mfgdata$varet <- 0
mfgdata$invret <- 0
for (ind in levels(mfgdata$naicsind)) {
    temp <- mfgdata[mfgdata$naicsind == ind,]
    nobs <- dim(temp)[1]
    # add one into logs to guard against zeros
    varet <- c(NA, log(temp$vadd[2:nobs]+1) - log(temp$vadd[1:(nobs-1)])+1)
    invret <- c(NA, log(temp$invest[2:nobs]+1) - log(temp$invest[1:(nobs-1)])+1)
    mfgdata[mfgdata$naicsind == ind,"varet"] <- varet
    mfgdata[mfgdata$naicsind == ind,"lagvaret"] <- c(NA, varet[1:(nobs-1)])
    mfgdata[mfgdata$naicsind == ind,"invret"] <- invret
}

# Some data may have been missing. Build indices to remove
# missing data for procedures which do not handle it.
usable.idx <- !is.na(mfgdata$invret)
usablear.idx <- !is.na(mfgdata$laginvret)

# Fit the model, summarize the data, and plot residuals
simple.model <- lm(invret ~ varet, data=mfgdata, weight=cap)
summary(simple.model)
plot(mfgdata$year[usable.idx], residuals(simple.model), pch=".")
grid(col="gray")

# Do likewise for the year-slope model
yearslope.model <- lm(invret ~ varet + varet:yearfactor,
                      weight=cap, data=mfgdata)
summary(yearslope.model)
plot(mfgdata$year[usable.idx], residuals(yearslope.model), pch=".")
grid(col="gray")

# And do this again for a model with a lagged value-added component
yearslopear.model <- lm(invret ~ varet + lagvaret + varet:yearfactor,
                        data=mfgdata, weight=cap)
summary(yearslopear.model)
plot(mfgdata$year[usablear.idx], residuals(yearslopear.model), pch=".")
grid(col="gray")


weight.construct <- function(fit,data,include.diag=TRUE){

  r <- fit$r
  t <- data$argvals
  subj <- data$subj

  subj_unique <- unique(subj)
  n <- length(subj_unique)
  W <- list(length=n)

  Theta <- fit$Theta
  sigma2 <- fit$sigma2
  knots <- fit$knots
  p <- fit$p

  B <- spline.des(knots=knots, x=t, ord = p+1,
                  outer.ok = TRUE,sparse=TRUE)$design

  for(i in 1:n){

  r1 <- r[subj==subj_unique[i]]
  t1 <- t[subj==subj_unique[i]] # no sort
  m1 <- length(t1) # m_i
  B1 <- matrix(B[subj==subj_unique[i],],nrow=sum(subj==subj_unique[i]))
  Chati <- as.matrix(tcrossprod(B1%*%Matrix(Theta),B1))
  if(m1>1){
       ##still input r w/o any deletion, CovZ.new deletes diagonal entires
    re <- covZ(t1, r1, Chati, sigma2) # <------
    if(include.diag){
    sel <- c()
    for(j in 1:m1) sel <- c(sel,(j-1)*m1 + j:m1)
    }
    if(!include.diag){
      sel <- c()
      for(j in 1:(m1-1)) sel <- c(sel,(j-1)*m1 + (j+1):m1)
    }

    CovZZ.tri <- re$CovZZ[sel,sel]
    if(length(sel)>1){
    V1 <- forceSymmetric(CovZZ.tri)
    V1 <- 0.95*V1 + 0.05*diag(diag(V1))
    # avoid inv
    eSig <- eigen(V1)
    eV = eSig$vectors
    eE = eSig$values
    eE[eE<0] <- 0
    eE = eE + 0.000001*max(eE)
    W[[i]] = eV %*% diag(1/eE) %*% t(eV)
    }
    if(length(sel)==1){
      W[[i]] = 1/CovZZ.tri
    }
    }## for if(m1>1)
  if(m1==1){
    if(include.diag){
      W[[i]]=matrix(1/(Chati + sigma2)^2/2,1,1)
    }
    if(!include.diag){W[[i]]=NULL}
  }
}##for i

#scale W
temp <- sapply(W,max)
W <- lapply(W,function(x) x/mean(temp,na.rm=TRUE))

return(W)
}


smoothWithDer <- function(t, y, d, m = 3,
                          Hstar = c(3, 0.2, 0.1)^2, sigma2eta = 1.0^2) {

  ## define the SSM matrices, depending on 'delta_k' or on 'd_k'
  Tfun <- function(delta) {
    mat <-  matrix(0, nrow = m, ncol = m)
    for (i in 0:(m-1)) {
      mat[col(mat) == row(mat) + i] <- delta^i / gamma(i + 1)
    }
    mat
  }
  Qfun <- function(delta) {
    im <- (m - 1):0
    x <- delta^im / gamma(im + 1)
    mat <- outer(X = x, Y = x, FUN = "*")
    im2 <- outer(im, im, FUN = "+")
    sigma2eta * mat * delta / (im2 + 1)
  }
  Zfun <-  function(d) {
    Z <- matrix(0.0, nrow = 1, ncol = m)
    Z[1, d + 1] <- 1.0
    Z
  }
  Hfun <- function(d) ifelse(d >= 0, Hstar[d + 1], 0.0)
  Rfun <- function() diag(x = 1.0, nrow = m)

  ## define arrays by stacking the SSM matrices. We need one more
  ## 'delta' at the end of the series
  n <- length(t)
  delta <-  diff(t)
  delta <- c(delta, mean(delta))

  Ta <- Qa <- array(0.0, dim = c(m, m, n))
  Za <- array(0.0, dim = c(1, m, n))
  Ha <- array(0.0, dim = c(1, 1, n))
  Ra <-  array(0.0, dim = c(m, m, n))

  for (k in 1:n) {
    Ta[ , , k] <- Tfun(delta[k])
    Qa[ , , k] <- Qfun(delta[k])
    Za[ , , k] <- Zfun(d[k])
    Ha[ , , k] <- Hfun(d[k])
    Ra[ , , k] <- Rfun()
  }

  require(KFAS)
  ## define the SSM and perform Kalman Filtering and smoothing
  mod <- SSModel(y ~ SSMcustom(Z = Za, T = Ta, R = Ra, Q = Qa, n = n,
                               P1 = matrix(0, nrow = m, ncol = m),
                               P1inf = diag(1.0, nrow = m),
                               state_names = paste0("d", 0:(m-1))) - 1)
  out <- KFS(mod, smoothing = "state")
  list(t = t, filtered = out$att, smoothed = out$alphahat)

}
Hst <- c(10, 1, 1)^2
siget <- (.01)^2

a0s <- c(d15$a0, d15$a0)
res1 <- smoothWithDer(t = a0s,
                      y = c(d15$lc_a0, d15$deriv_lc),
                      d = c(rep(0, nrow(d15)), c(-1, rep(1, nrow(d15)-1)) ), m = 5,
                      Hstar = Hst, sigma2eta = siget)

curve(l_a0, 0, 10)
curve(l_a0_p, 0, 10, col = 2, add =  TRUE)
matplot(res1$t, res1$smoothed[, 1:2], pch = 16, cex = 0.7, ylab = "", xlab = "", add = TRUE)

curve(l_a0)
curve(l_a0_p, col = 2, add =  TRUE)
matplot(res1$t, res1$smoothed[, 1:2],
        pch = 16, cex = 0.7, ylab = "", xlab = "", add = TRUE)


#' Shrinkage-based Diagonal Linear Discriminant Analysis (SDLDA)
#'
#' Given a set of training data, this function builds the Shrinkage-based
#' Diagonal Linear Discriminant Analysis (SDLDA) classifier, which is based on
#' the DLDA classifier, often attributed to Dudoit et al. (2002). The DLDA
#' classifier belongs to the family of Naive Bayes classifiers, where the
#' distributions of each class are assumed to be multivariate normal and to
#' share a common covariance matrix. To improve the estimation of the pooled
#' variances, Pang et al. (2009) proposed the SDLDA classifier which uses a
#' shrinkage-based estimators of the pooled covariance matrix.
#'
#' The DLDA classifier is a modification to the well-known LDA classifier, where
#' the off-diagonal elements of the pooled covariance matrix are assumed to be
#' zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of
#' `x` contain the sample observations, and the columns contain the
#' features for each training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations
#' belonging to each class. Otherwise, `prior` should be a vector with the
#' same length as the number of classes in `y`. The `prior`
#' probabilities should be nonnegative and sum to one.
#'
#' @export
#'
#' @inheritParams lda_diag
#' @param num_alphas the number of values used to find the optimal amount of
#' shrinkage
#' @return `lda_shrink_cov` object that contains the trained SDLDA classifier
#'
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]
#' sdlda_out <- lda_shrink_cov(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(sdlda_out, penguins[pred_rows, -1], type = "class")
#'
#' sdlda_out2 <- lda_shrink_cov(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(sdlda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
lda_shrink_cov <- function(x, ...) {
  UseMethod("lda_shrink_cov")
}

#' @rdname lda_shrink_cov
#' @export
lda_shrink_cov.default <- function(x, y, prior = NULL, num_alphas = 101, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x, y, prior, pool = TRUE)

  # Calculates the shrinkage-based estimator of the pooled covariance matrix.
  obj$var_shrink <- var_shrinkage(
    N = obj$N,
    K = obj$num_groups,
    var_feature = obj$var_pool,
    num_alphas = num_alphas,
    t = -1
  )

  # Creates an object of type 'lda_shrink_cov'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "lda_shrink_cov")

  obj
}

#' @inheritParams lda_diag
#' @rdname lda_shrink_cov
#' @importFrom stats model.frame model.matrix model.response
#' @export
lda_shrink_cov.formula <- function(formula, data, prior = NULL, num_alphas = 101, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- lda_shrink_cov.default(x = x, y = y, prior = prior, num_alphas = num_alphas)

  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a SDLDA classifier object.
#'
#' Summarizes the trained SDLDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.lda_shrink_cov <- function(x, ...) {
  cat("Shrinkage-based Diagonal LDA\n\n")
  print_basics(x, ...)
  invisible(x)
}

#' SDLDA prediction of the class membership of a matrix of new observations.
#'
#' The SDLDA classifier is a modification to LDA, where the off-diagonal
#' elements of the pooled sample covariance matrix are set to zero. To improve
#' the estimation of the pooled variances, we use a shrinkage method from Pang
#' et al.  (2009).
#'
#' @rdname lda_shrink_cov
#' @export
#' @inheritParams predict.lda_diag

predict.lda_shrink_cov <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / object$var_shrink) + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- replicate(n=object$num_groups, object$var_shrink, simplify=FALSE)
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)

  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}


#name: RKNNTrain
#meta.mlname: RKNN
#meta.mlrole: train
#description: Custom R Train func for KNN using Caret
#language: r
#input: dataframe df
#input: string predict_column
#input: int n_neighbors {category: Parameters}
#input: int distance = 1 {category: Parameters; range:1-2} [Parameter of Minkowski distance]
#input: string kernel = rectangular {category: Parameters; choices: ["rectangular", "triangular", "epanechnikov", "biweight", "triweight", "cos", "inv", "gaussian", "optimal"]}
#output: blob model

#>>> Initialize local environment and install-require necessary packages

library(caret)
library(e1071)
renv::init()
install.packages('kknn')
library(kknn)
install.packages("MLmetrics")
library(MLmetrics)

#>>> Extract/Prepare train features and target variable
trainY <- df[[predict_column]]
trainX <- df[, -grep(predict_column, colnames(df))]

#>>> Prepare parameters for model training
tuneGrid <- expand.grid(kmax = n_neighbors,  distance = distance, kernel = kernel) #Parms for KKNN
#tuneGrid <-  expand.grid(k = n_neighbors) <-- Uncomment for KNN
ctrl <- trainControl(method="cv", summaryFunction=multiClassSummary, classProbs=TRUE,
        savePredictions=FALSE, returnResamp="final", returnData=FALSE, trim=TRUE)

#>>> Train model
trained_model <- caret::train(
  x=trainX,
  y=trainY,
  method='kknn',
#  method='knn',
  preProcess=c("center", "scale"),
  metric="ROC",
  trControl=ctrl,
  tuneGrid = tuneGrid
  )

#>>> Save trained model
saveRDS(trained_model, file=model)


beta1=-7.859 # caclulated in 11.4
error=1.090
alpha=0.05/2
df=18
t.alpha=qt(1-alpha,df)
print(t.alpha)
# corresponding confidence interval for the true value of beta1
left_i=beta1-t.alpha*error
right_i=beta1+t.alpha*error
print("confidence interval")
print(left_i)
print(right_i)


## ----author info, include=F----------------------------------------------
## Author:  Yanchang Zhao
## Email:   yanchang@RDataMining.com
## Website: http://www.RDataMining.com
## Date:    9 December 2018

## ----load libraries, include=F, echo=F-----------------------------------
## load required packages
library(magrittr) ## for pipe operations
library(ggplot2)
library(igraph)
library(visNetwork)

## ----simple graph, tidy=F------------------------------------------------
library(igraph)
# nodes
nodes <- data.frame(
  name = c("Tom","Ben","Bob","John","Mary","Alice","Wendy","David"),
  gender = c("M", "M", "M", "M", "F", "F", "F", "M"),
  age =    c( 16,  30,  42,  29,  26,  32,  18,  22)
)
# relations
edges <- data.frame(
  from = c("Tom", "Ben",  "Bob", "Mary", "Alice", "Wendy", "Wendy"),
  to  =  c("John", "John", "John", "John","Mary", "Mary", "David")
)
# build a graph object
g <- graph.data.frame(edges, directed=F, vertices=nodes)

## ----plot graph 1--------------------------------------------------------
layout1 <- g %>% layout_nicely() ## save layout for reuse
g %>% plot(vertex.size=30, layout=layout1)

## ----plot graph 2, tidy=F------------------------------------------------
## use blue for male and pink for female
colors <-  ifelse(V(g)$gender=="M", "skyblue", "pink")
g %>% plot(vertex.size=30, vertex.color=colors, layout=layout1)

## ----graph query, tidy=F-------------------------------------------------
## nodes
V(g)
## edges
E(g)
## immediate neighbors (friends) of John
friends <- ego(g,order=1,nodes="John",mindist=1)[[1]] %>% print()
## female friends of John
friends[friends$gender == "F"]

## ----graph query 2, warning=F, tidy=F------------------------------------
## 1- and 2-order neighbors (friends) of John
g2 <- make_ego_graph(g, order=2, nodes="John")[[1]]
g2 %>% plot(vertex.size=30, vertex.color=colors)

## ----plot graph 3, tidy=F, echo=F----------------------------------------
g %>% plot(vertex.size=30, vertex.color=colors, layout=layout1)

## ----centrality measures 1-----------------------------------------------
degree <- g %>% degree() %>% print()
closeness <- g %>% closeness() %>% round(2) %>% print()
betweenness <- g %>% betweenness() %>% print()

## ----centrality measures 2-----------------------------------------------
eigenvector <- evcent(g)$vector %>% round(2) %>% print()
transitivity <- g %>% transitivity(type="local") %>% print()

## ----download graph data, eval=F, warning=F------------------------------
## ## download graph data
## url <- "http://www.rdatamining.com/data/graph.rdata"
## download.file(url, destfile="./data/graph.rdata")

## ----load graph data, tidy=F---------------------------------------------
library(igraph)
# load graph data into R
# what will be loaded: g, nodes, edges
load("./data/graph.rdata")

## ----build graph---------------------------------------------------------
head(nodes, 3)
head(edges, 3)
## buid a graph object
g <- graph.data.frame(edges, directed=F, vertices=nodes)
g

## ----static network visualization 2, out.height="0.75\\textheight", out.width="0.7\\textwidth", tidy=F, crop=T----
library(igraph)
plot(g, vertex.size=12, vertex.label.cex=0.7,
     vertex.color=as.factor(V(g)$type), vertex.frame.color=NA)

## ----interactive network visualization, tidy=F, eval=F-------------------
## library(visNetwork)
## V(g)$group <- V(g)$type
## ## visualization
## data <- toVisNetworkData(g)
## visNetwork(nodes=data$nodes, edges=data$edges) %>%
## visGroups(groupname="tid",shape="icon",icon=list(code="f15c")) %>%
## visGroups(groupname="person",shape="icon",icon=list(code="f007")) %>%
## visGroups(groupname="addr",shape="icon",icon=list(code="f015")) %>%
## visGroups(groupname="phone",shape="icon",icon=list(code="f095")) %>%
## visGroups(groupname="email",shape="icon",icon=list(code="f0e0")) %>%
## addFontAwesome() %>%
## visLegend()


###Spatial Bayesian regression
## Author: Ying-Jung Deweese
## Date: 2017-08-24
## Load the libraries to be used
library(coda)
library(abind)
library(magic)
library(maps)
library(Matrix)
library(Formula)
library(spBayes)
library(MBA)
library(geoR)
library(spam)
library(grid)
library(fields)
library(sp)
library(maptools)
library(rgdal)
library(classInt)
library(lattice)
library(raster)

### Read file
year = 2005
filename = sprintf("all_2005fok_0920.csv", year);

A=read.csv(filename,header=T)

## Data preliminaries
## Read data length
S_num = dim(A)[2]-7

## Compute the spatial Bayesian regression
for (i in 1:S_num)
{

print(sprintf("start of loop %d", i))

## Subset data variable for elevation, rain variables
bio <- A[,i+7]
elv <- A[,2]

## Extract the coordinates
coords <- as.matrix(A[,c("long","lat")])

p <- 2 ## This is the number of columns in the design matrix
## Set the prior mean and precision for the regression
beta.prior.mean <- as.matrix(rep(0, times=p))
beta.prior.precision <- matrix(0, nrow=p, ncol=p)

## For use with bayesGeostatExact, do the following
phi <- 0.5 ## Set the spatial range (from the variogram)
alpha <- 1600/0.5 ## Set the nugget/partial-sill ratio
sigma.sq.prior.shape <- 2.0 ## Set IG shape for sigma.sq (partial sill)
sigma.sq.prior.rate <- 0.5 ## Set IG scale for sigma.sq (partial sill)

## Run bayesGeostatExact to deliver exact posterior samples
sp.exact <- bayesGeostatExact(
bio~elv,
coords=coords, n.samples=1000,
beta.prior.mean=beta.prior.mean,
beta.prior.precision=beta.prior.precision,
cov.model="spherical",
phi=phi, alpha=alpha,
sigma.sq.prior.shape=sigma.sq.prior.shape,
sigma.sq.prior.rate=sigma.sq.prior.rate,
sp.effects=FALSE)

##Produce the posterior summaries
round(summary(sp.exact$p.samples)$quantiles,3)

cook=coords
## Run spLM to deliver MCMC samples from marginal posterior distributions
n.samples <- 1000
bef.sp <- spLM(bio~elv,
coords=cook, starting=list("phi"=3/200,"sigma.sq"=0.08,

                           "tau.sq"=0.02), tuning=list("phi"=0.1, "sigma.sq"=0.05, "tau.sq"=0.05),

priors=list("phi.Unif"=c(3/1500, 3/50), "sigma.sq.IG"=c(2, 0.08),"tau.sq.IG"=c(2, 0.02)), cov.model="spherical",n.samples=n.samples)

round(summary(mcmc(bef.sp$p.theta.samples))$quantiles,3)

## Recover spatial residuals using spRecover
burn.in <- floor(0.75*n.samples)
bef.sp <- spRecover(bef.sp, start=burn.in, thin=2)

## The posterior samples of the regression coefficients and the spatial effects can then be obtained as
beta.samples = bef.sp$p.beta.recover.samples
w.samples = bef.sp$p.w.recover.samples

## Obtain trace plots for regression coefficients
par(mfrow=c(3,2))
plot(beta.samples, auto.layout=TRUE, density=FALSE)

## Obtain posterior means and sd's of spatial residuals for each location
w.hat.mu <- apply(w.samples,1,mean)
w.hat.sd <- apply(w.samples,1,sd)

## Obtain OLS residuals
lm.test = lm(bio~elv)
test.resid = resid(lm.test)

## Plot the spatial residual mean surface and a map of sd's
par(mfrow=c(1,2))
surf <- mba.surf(cbind(coords, test.resid), no.X=100, no.Y=100, extend=FALSE)$xyz.est
z.lim <- range(surf[[3]], na.rm=TRUE)
image.plot(surf, xaxs = "r", yaxs = "r", zlim=z.lim, main="LM residuals")
surf <- mba.surf(cbind(coords, w.hat.mu), no.X=100, no.Y=100, extend=FALSE)$xyz.est
image.plot(surf, xaxs = "r", yaxs = "r", zlim=z.lim, main="Mean spatial effects")

## Predictions
BEF.shp <- readShapePoly("coastalbasinsdata.shp")
shp2poly <- BEF.shp@polygons[[1]]@Polygons[[1]]@coords
BEF.poly <- as.matrix(shp2poly)
BEF.grids <- readGDAL("all_ok_Projec.tif")

## Construct the prediction design matrix for the entire grid extent.
pred.covars <- cbind(BEF.grids[["band1"]], BEF.grids[["band2"]], BEF.grids[["band3"]], BEF.grids[["band4"]], BEF.grids[["band5"]])
pred.covars <- cbind(rep(1, nrow(pred.covars)), pred.covars)
p=SpatialPointsDataFrame(coordinates(BEF.grids),data=BEF.grids@data) # convert spatialgrid dataframe to spatial point dataframe

## Extract the coordinates of the BEF bounding polygon vertices and use the pointsInPoly (spBayes) function to obtain the desired subset of the prediction design matrix and associated prediction coordinates (i.e., pixel centroids).
pred.coords <- SpatialPoints(BEF.grids)@coords
pointsInPolyOut <- pointsInPoly(BEF.poly, pred.coords)
pred.coords <- pred.coords[pointsInPolyOut,]
pred.covars <- p[pointsInPolyOut,]
#convert spdf to matrix
DF <- as.matrix(pred.covars@data)
DF <- cbind(rep(1, nrow(DF)), DF)# generate 2 column
bef.bio.pred <- spPredict(bef.sp, start=burn.in, thin=2, pred.coords=pred.coords, pred.covars=DF)

## Mapping the predicted values
bef.bio.pred.mu = apply(bef.bio.pred$p.y.predictive.samples,1,mean)
bef.bio.pred.sd = apply(bef.bio.pred$p.y.predictive.samples,1,sd)
surf <- mba.surf(cbind(coords,bio), no.X=500, no.Y=500, extend=TRUE, sp=TRUE)$xyz.est

## write out raster

ras3_name = sprintf("All_%d-S%d_spBayes.tif", year, i)
writeGDAL(surf, ras3_name, drivername="GTiff", options=NULL)

}


'%div%'=function(x,y)
{
  if(x%%y==0)
    return(TRUE)
  else
    return(FALSE)
}

`%div%`(10,5)


#The law of Large Numbers

#The rnorm() function in R generates a random number using a normal(bell curve) distribution.
#It takes the sample size as Input and generate that many random numbers.

#E(x) = 68.2 or 0.682
#Try N = input(10, 100, 1000, 10000....)

#Begin
N <- 1000
counter <- 0
for (i in rnorm(N)){
  if(i> -1 & i <1){
    counter <- counter +1

  }
}

answer <- counter/N *100
answer

#END


library(changepoint)
library(dplyr)
library(ggplot2)

air_data <- readRDS("C:/Users/anthony/Desktop/my_project/census-app/data/Air_box.rds")

PM25_of_sensor <- subset(air_data, ID == sensor_ID[13])
del_index_arr = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
summarise( length(PM25) > 4 ) #change point detection is not available when length is shorter than 4

Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))
del_index = which(as.data.frame(del_index_arr[,2])[,1] %in% 0)

if(length(del_index) != 0) PM25_of_sensor <- PM25_of_sensor[ -which( Day_ID[del_index] == as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") ),]
#get Day_ID after deleting the ones with length shorter than 4
Day_ID <- unique(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8"))

sen_of_day <- PM25_of_sensor[which(as.Date(PM25_of_sensor$f_time, tz = "Etc/GMT+8") == Day_ID[1]),]
#ch_id_group = group_by(PM25_of_sensor, as.Date(f_time, tz = "Etc/GMT+8")) %>%
#	summarise(ifelse(length( cpts( cpt.meanvar(PM25) ) ) == 0, NA, cpts( cpt.meanvar(PM25) ) ))

amoc <- cpt.meanvar(PM25_of_sensor$PM25, method = "AMOC") #call by cpts(amoc)
pelt <- cpt.meanvar(PM25_of_sensor$PM25, method = "PELT") #call by cpts(pelt)
segneigh <- cpt.meanvar(PM25_of_sensor$PM25,penalty="Asymptotic",pen.value=0.01,method="SegNeigh",Q=5,class=FALSE)
binseg <- cpt.meanvar(PM25_of_sensor$PM25,penalty="Manual",pen.value="4*log(n)",method="BinSeg",Q=5,class=FALSE)

#other try
pelt_1 <- cpt.meanvar(sen_of_day$PM25, pen.value = c(4,1500), penalty = "CROPS", method = "PELT") #call by cpts(pelt)
cpts.full(pelt_1)
cpt.out(pelt_1)
plot(pelt_1,ncpts = 5)

apply(pelt_1@cpts.full, 2, function(x) length(which(!is.na(x))))

#print pelt
p <- ggplot(PM25_of_sensor,
 		       aes(x = as.POSIXct(f_time, tz = "Etc/GMT+8"), y = PM25)) +
 	          geom_line() + geom_vline(xintercept = as.numeric(PM25_of_sensor$f_time[ cpts(pelt_1) ]), colour = "red")
print(p)
#print SegNeigh
p <- ggplot(PM25_of_sensor,
 		       aes(x = as.POSIXct(f_time, tz = "Etc/GMT+8"), y = PM25)) +
 	          geom_line() + geom_vline(xintercept = as.numeric(PM25_of_sensor$f_time[ segneigh ]), colour = "red")
print(p)

#print BinSeg
p <- ggplot(PM25_of_sensor,
 		       aes(x = as.POSIXct(f_time, tz = "Etc/GMT+8"), y = PM25)) +
 	          geom_line() + geom_vline(xintercept = as.numeric(PM25_of_sensor$f_time[ cpts(pelt_1) ]), colour = "red")
print(p)


vsa=function(fun,par.mins,par.maxs,nrun){
  par.range = par.maxs - par.mins
  k=length(par.range)
  M = array(runif(nrun*k),dim=c(nrun,k))      #CREATE U(0,1) n x k MATRIX
  for (i in 1:k) M[,i] = M[,i] * par.range[i] + par.mins[i] #TRANSFORM TO FIT RANGE OF EACH PAR

  #Now we are going to make a different input matrix, M2, the same way
  M2 = array(runif(nrun*k),dim=c(nrun,k))     #CREATE U(0,1) n x k MATRIX
  for (i in 1:k) M2[,i] = M2[,i] * par.range[i] + par.mins[i] #TRANSFORM TO FIT RANGE OF EACH PAR

  #Now we are going to make K different matrices, where in the jth matrix, all parameters are taken from M2 except parameter j is taken from M
  NJ.list = list()
  for (j in 1:k) {
    temp = M2
    temp[,j] = M[,j]
    NJ.list[[j]] = temp
  }

  #Now, to compute the first-order effects (S) of factor J, we need to compute the values UJ, as discussed in class
  S = numeric(length=k)
  ST = numeric(length=k)
  y1 = y2 = y3 = numeric(length = nrun)
  for (i in 1:nrun) {
      y1[i] = fun(M[i,])
      y2[i] = fun(M2[i,])
  }
 #Now to compute the expected value (EY) and total variance (VY) of Y, for which we will use M2
  EY=mean(y1)
 # VY=var(y3)
 #For computational reasons, we will estimate EY^2 using both M and M2
 # EY2=mean(y1*y2)
#  EY2=EY^2
  VY=sum(y1*y1)/(nrun-1)-EY^2

  for (j in 1:k) {
    NJ = NJ.list[[j]]
    for (i in 1:nrun) y3[i] = fun(NJ[i,])
    UJ = sum(y1*y3) / (nrun-1)   #here everything but factor j is resampled
    UJ2 = sum(y2*y3) / (nrun-1)  #here only factor j is resampled
    S[j] = (UJ - EY^2) / VY
    ST[j] = 1.0 - (UJ2 - EY^2) / VY
  }

  list(S,ST)
}


library(cv.models)
library(testthat)
library(gbm)

#-----------------------------------------------------------------------------
#	Create test data.
#-----------------------------------------------------------------------------
create.test.data <- function() {
	set.seed(12345)
	test.data <- data.frame(
		x = rnorm(1000, 1000, 100),
		offset = runif(1000, 1, 10) %/% 1,
		random = runif(1000, 1, 100) %/% 1
	)
	test.data$y.norm <- rnorm(1000, test.data$x) * test.data$offset
	test.data$y.pois <- rpois(1000, test.data$x) * test.data$offset
	test.data$y.norm.with.random <- (
		rnorm(1000, test.data$x) * test.data$offset
		+ rnorm(100)[test.data$random]
	)
	test.data$y.pois.with.random <- (
		rpois(1000, test.data$x + rnorm(100)[test.data$random])
		* test.data$offset
	)
	test.data$random <- factor(test.data$random)
	return(test.data)
}

#-----------------------------------------------------------------------------
#	Test the model with offset (more correct model) can have
#	higher performance than the model without offset.
#-----------------------------------------------------------------------------
test.offset <- function(call.with.offset, call.without.offset, ...) {
	test_that(
		paste(
			"Test the model with offset having higher performance than the",
			"model without offset."
		), {
			# Run cv.models.
			cv.no.offset <- cv.models(call.without.offset, ...)
			cv.offset <- cv.models(call.with.offset, ...)
			# Check results.
			errors <- c(
				"mse", "rmse", "sd.mse", "sd.rmse", "sd.r.squared",
				"sd.spearman", "sd.kendall", "sd.q.squared"
			)
			cors <- c("r.squared", "spearman", "kendall", "q.squared")
			metrics.no.offset <- extract.metrics(cv.no.offset)
			metrics.offset <- extract.metrics(cv.no.offset)
			expect_true(
				all(metrics.no.offset[errors] >= metrics.offset[errors])
			)
			expect_true(
				all(metrics.no.offset[cors] <= metrics.offset[cors])
			)
		}
	)
}

#-----------------------------------------------------------------------------
#	Test runner.
#
#	Currently, glm and gbm were tested.
#-----------------------------------------------------------------------------
run.test <- function() {
	d <- create.test.data()
	test.data <- list(
		glm = list(
			offset = substitute(
				glm(
					y.pois ~ x + offset(log(offset)), family = poisson,
					data = d
				)
			),
			no.offset = substitute(
				glm(y.pois ~ x, family = poisson, data = d)
			)
		),
		gbm = list(
			offset = substitute(
				gbm(
					y.pois ~ x + offset(log(offset)), n.cores = 1,
					distribution = "poisson", n.trees = 100, data = d
				)
			),
			no.offset = substitute(
				gbm(
					y.pois ~ x, distribution = "poisson", n.trees = 100,
					data = d, n.cores = 1
				)
			)
		)
	)
	for (i in names(test.data)) {
		if (i == "gbm") {
			test.offset(
				test.data[[i]]$offset, test.data[[i]]$no.offset, n.trees = 100
			)
		} else {
			test.offset(test.data[[i]]$offset, test.data[[i]]$no.offset)
		}
	}
}

run.test()


setwd("doc/distributions")
postscript(file = "lognormal.ps", width = 10, height = 8, bg = "white", fg = "black", onefile=TRUE)
colors=c("blue")
x<-seq(-3,3,length=10000)
plot(x, log(dnorm(x,0,1)) ,xlab="", ylab="" ,lwd=3, col=colors[1],type="l", cex.axis=2, col.axis="gray40")
title("Normal Distribution",col.main="gray50",cex.main=1.5)
legend(1.5,0.4,legend="N(0,1)",lwd=c(4,4,4,1),col=colors,cex=1.5)
grid()