# load midwest data
data("midwest")

# Scatter plot of total population versus known poverty population
ggplot(midwest, aes(x = poptotal, y = poppovertyknown, color = state)) + geom_point(size=5) + scale_color_brewer(palette = 'Accent')

# ?mean - this opens help file
# getwd()
# View(diamonds)

diamondsSubset <- diamonds[diamonds$color=="E", ]
head(diamondsSubset, 2)
dim(diamondsSubset)

data(mtcars)
str(mtcars)
subset(mtcars, mpg >= 30 | hp < 60)
mtcars[mtcars$mpg >= 30 | mtcars$hp < 60, ]

reddit <- read.csv('reddit.csv')
table(reddit$employment.status)
str(reddit)
levels(reddit$age.range)

qplot(data = reddit, x = age.range)
qplot(data = reddit, x = income.range)

# QUIZ

levels(reddit$age.range)
reddit$age.range <- ordered(reddit$age.range, levels = c("Under 18", "18-24", "35-44", "45-54", "55-64", "65 or Above"))
qplot(data = reddit, x = age.range)

read.delim('pseudo_facebook.tsv')
list.files()
pf <- read.csv('pseudo_facebook.tsv', sep = "\t") # tsv - tab seperated values file

pf <- read.delim('pseudo_facebook.tsv') # read.delim() function defaults to the tab character as the separator between values and the period as the decimal character.

names(pf)
qplot(x = dob_day, data = pf)

install.packages('ggthemes', dependencies = TRUE)
library(ggthemes)

ggplot(aes(x = dob_day), data = pf) +
  geom_histogram(binwidth = 1) +
  scale_x_continuous(breaks = 1:31) +
  facet_wrap(~dob_month, ncol = 3)

ggplot(aes(x = friend_count), data = subset(pf, !is.na(gender))) +
  geom_histogram(binwidth = 25) +
  scale_x_continuous(limits = c(0, 1000), breaks = seq(0,1000,50))+
  facet_wrap(~gender)

qplot(x = friend_count, data = pf, xlim = c(0, 1000))

table(pf$gender)
by(pf$friend_count, pf$gender, summary)

qplot(x = tenure, data = pf, color = I('black'), fill = I('#FF9429'))

qplot(x = tenure/365, data = pf, binwidth = .25, color = I('white'), fill = I('#FF9429')) +
  scale_x_continuous(breaks = seq(1, 7, 1), limits = c(0, 7)) +
  xlab('Number of years using Facebook') +
  ylab('Number of users in sample')

ggplot(aes(x = tenure), data = pf) +
  geom_histogram(binwidth = 30, color = 'black', fill = 'skyblue')

ggplot(aes(x = tenure/365), data = pf) +
  geom_histogram(binwidth = .25, color = 'white', fill = 'lightblue')

summary(pf$age)

ggplot(aes(x = age), data = pf) +
  geom_histogram(binwidth = 1, color = 'white', fill = '#7760AB') +
  scale_x_continuous(breaks = seq(0, 113, 5)) +
  xlab('Facebook users age') +
  ylab('Number of users in sample')

# TRANSFORMING DATA
# ===============================
install.packages('gridExtra')

summary(pf$friend_count)
summary(log10(pf$friend_count + 1))
summary(sqrt(pf$friend_count))

library(gridExtra)

# scale_x_log10() to adjust the x-axis
plot1 <- qplot(x = friend_count, data = pf)
plot2 <- qplot(x = log10(friend_count + 1), data = pf)
plot3 <- qplot(x = sqrt(friend_count), data = pf)

grid.arrange(plot1, plot2, plot3, ncol = 1)

plot4 <- ggplot(aes(x = friend_count), data = pf) +
  geom_histogram()
plot5 <- plot1 <- ggplot(aes(x = friend_count), data = pf) +
  geom_histogram() + scale_x_log10()
plot6 <- plot1 <- ggplot(aes(x = friend_count), data = pf) +
  geom_histogram() + scale_x_sqrt()

grid.arrange(plot4, plot5, plot6, ncol = 1)

## ADDING A SCALE LAYER

logScale <- qplot(x = log10(friend_count), data = pf)

countScale <- ggplot(aes(x = friend_count), data = pf) +
  geom_histogram() +
  scale_x_log10()

grid.arrange(logScale, countScale, ncol = 2)

## FREQUENCY POLYGONS

qplot(x = friend_count, data = subset(pf, !is.na(gender)),
      binwidth = 10) +
  scale_x_continuous(lim = c(0, 1000), breaks = seq(0, 1000, 50)) +
  facet_wrap(~gender)

qplot(x = friend_count, y = ..count../sum(..count..),
      data = subset(pf, !is.na(gender)),
      xlab = 'Friend Count',
      ylab = 'Proportion of Users with that of friend count',
      binwidth = 10, geom = 'freqpoly', color = gender) +
  scale_x_continuous(lim = c(0, 1000), breaks = seq(0, 1000, 50))

ggplot(aes(x = friend_count, y = ..count../sum(..count..)),
       data = subset(pf, !is.na(gender))) +
  geom_freqpoly(aes(color = gender), binwidth=10) +
  scale_x_continuous(limits = c(0, 1000),
                     breaks = seq(0, 1000, 50)) +
  xlab('Friend Count') +
  ylab('Proportion of users with that friend count')

qplot(x = www_likes, data = subset(pf, !is.na(gender)),
      geom = 'freqpoly', color = gender) +
  scale_x_log10()

ggplot(aes(x = www_likes), data = subset(pf, !is.na(gender))) +
  geom_freqpoly(aes(color = gender)) +
  scale_x_log10()

## LIKES ON THE WEB

by(pf$www_likes, pf$gender, sum)

## BOX PLOTS

qplot(x = gender, y = friend_count,
      data = subset(pf, !is.na(gender)),
      geom = 'boxplot',ylim = c(0, 1000))

qplot(x = gender, y = friend_count,
      data = subset(pf, !is.na(gender)),
      geom = 'boxplot',
      xlab = 'Gender',
      ylab = 'Friend Count') +
  scale_y_continuous(limits = c(0, 1000))

qplot(x = gender, y = friend_count,
      data = subset(pf, !is.na(gender)),
      geom = 'boxplot',
      xlab = 'Gender',
      ylab = 'Friend Count') +
  coord_cartesian(ylim = c(0, 1000))

## BOX PLOTS, QUARTILES, AND FRIEND REQUESTS

qplot(x = gender, y = friend_count,
      data = subset(pf, !is.na(gender)),
      geom = 'boxplot',
      xlab = 'Gender',
      ylab = 'Friend Count') +
  coord_cartesian(ylim = c(0, 250))

by(pf$friend_count, pf$gender, summary)

qplot(x = gender, y = friendships_initiated,
      data = subset(pf, !is.na(gender)),
      geom = 'boxplot',
      xlab = 'Gender',
      ylab = 'Friendship Initiated') +
  coord_cartesian(ylim = c(0, 250))

by(pf$friendships_initiated, pf$gender, summary)

# GETTING LOGICAL

summary(pf$mobile_likes > 0)

mobile_check_in <- NA

pf$mobile_check_in <- ifelse(pf$mobile_likes > 0, 1, 0)
pf$mobile_check_in <- factor(pf$mobile_check_in)
summary(pf$mobile_check_in)
sum(pf$mobile_check_in == 1)/length(pf$mobile_check_in) * 100

# =========== LESSON 4 ================ #
# QUIZ 1
dim(diamonds) # Number of observations and variables
str(diamonds) # ordered factors
str(diamonds$color) # best diamond color

# QUIZ 2
ggplot(diamonds) +
  geom_histogram(aes(x=price), binwidth = 100,
                 color = "coral", fill = "red") +
  xlab("Price")+
  ylab("Diamonds Count") +
  ggtitle("Diamonds Price Plot")

# QUIZ 3

summary(diamonds$price)

# The shape of the graph depicts a right-skewed distribution of diamonds price with a median price of 2401 and a mean price of 3933.

# QUIZ 4
nrow(subset(diamonds, price < 500)) # numberof diamonds < $500
nrow(subset(diamonds, price < 250))
nrow(subset(diamonds, price > 15000 | price == 15000))

# QUIZ 5
ggplot(diamonds) +
  geom_histogram(aes(x=price), binwidth = 15, color = "coral",
                 fill = "red") +
  xlab("Price")+
  ylab("Diamonds Count") +
  ggtitle("Diamonds Price Histogram between $0 and $1000.") +
  coord_cartesian(xlim=c(0,1000)) +
  ggsave("/plots/priceHistogram.png")

# QUIZ 6
ggplot(diamonds) +
  geom_histogram(aes(x=price), binwidth = 100, color = "coral",
                 fill = "red") +
  xlab("Price")+
  ylab("Diamonds Count") +
  ggtitle("Price ~ Cut Histogram") +
  facet_grid(~cut) +
  ggsave("/plots/priceCutHistogram.png")

# QUIZ 7

# Price by cut
diamonds[which.max(diamonds$price),] # highest diamond price
tapply(diamonds$price, diamonds$cut, min) # lowest diamond price
by(diamonds$price,diamonds$cut,summary) # least median

# QUIZ 8

# Scales and Multiple Histograms

qplot(x = price, data = diamonds) + facet_wrap(~cut)

by(diamonds$price, diamonds$cut, summary)

ggplot(aes(x=price), data=diamonds) +
  geom_histogram(binwidth=100, color='coral', fill='red') +
  facet_wrap(~cut, scales="free")

# QUIZ 9

# Price per Carat by Cut

ggplot(aes(x=price/carat), data=diamonds) +
  geom_histogram(binwidth=0.03, color='coral', fill='red') +
  ggtitle("Price per Carat by Cut") +
  xlab("Price per Carat") +
  scale_x_log10() +
  facet_wrap(~cut)

# QUIZ 10

# Price Box Plots

ggplot(aes(x = cut, y = price), data=diamonds) +
  geom_boxplot() +
  ggtitle("Price by box plots") +
  ggsave("/plots/priceBoxPlots.png")

by(diamonds$price, diamonds$cut, summary)

#==============
# CORE
#==============

setwd("/var/www/example.com/public_html/Data-Science-All")
load("//var/www/example.com/public_html/Data-Science-All/workspace.RData")
save.image("/var/www/example.com/public_html/Data-Science-All/workspace.RData")

# ggplot2 comes default
library(ggplot2)

# install RColorBrewer
library(RColorBrewer)


library("modreg")
###CHAPTER 5: BIAS VARIANCE TRADE-OFF
##plot 01
N <- 100
x <- seq(.09,.5,len=N)
f <- 2*sin(1/x)
sigma2 <- 1
y <- f + rnorm(N,0,sigma2)
postscript("Plots/plot-05-01.ps")
plot(x,y,main="True f(x)=5 sin(1/x) and observations")
lines(x,f,type="l")
dev.off()
####plot02
NN <- 5
postscript("Plots/plot-05-02.ps")
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N,0,sigma2)
       ksmooth(x,y,kernel="box",bandwidth=.01)$y
     })
par(mfrow=c(2,2),mai=c(0,0,0,0),oma=c(1,1,1,1))
plot(x,f,type="l",lwd=1.5,ylim=range(c(f,as.vector(results))))
lines(x,results[,1],lty=4)

plot(x,f,ylim=range(results),type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
results <- sapply(1:NN,function(i){
       y <- f + rnorm(N,0,sigma2)
       ksmooth(x,y,kernel="box",bandwidth=.1)$y
     })
plot(x,f,type="l",lwd=1.5)
lines(x,results[,1],lty=4)

plot(x,f,type="l",lwd=1.5)
apply(results,2,function(aux) lines(x,aux,lty=4))
dev.off()

##plot03
postscript("Plots/plot-05-03.ps")
par(mfrow=c(1,2))

x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
plot(x,y)
lines(x,f)

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
plot(x,y)
lines(x,f)
dev.off()

########## plot04
Nl <- 50
#N <- 500
x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
lambdas <- seq(.01,2.2,len=Nl)
cvs <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 200
AUX <-matrix(rnorm(N*NN,0,sigma2),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit0 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse)[1]])
fit1 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs)[1]])
postscript("Plots/plot-05-04.ps")
par(mfrow=c(2,3),oma=c(0,0,2,0))
plot(lambdas,cvs,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs)[1]],lty=1)
plot(lambdas,mse+1,xlab="lambdas",type="l")
abline(v=lambdas[order(mse)[1]],lty=2)
o <- sort(sample(1:length(x),50))
plot(x,f,type="l",ylim=range(c(fit1$y,fit0$y[o])))
lines(x[o],fit1$y[o],lty=2,col=2)
lines(x[o],fit0$y[o],lty=3,col=3)
legend(70,0,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
N1 <- 50
cvs2 <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rt(N*NN,3),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse2 <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit00 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse2)[1]])
fit11 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs2)[1]])
plot(lambdas,cvs2,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs2)[1]],lty=1)
plot(lambdas,mse2+sigma2,xlab="lambdas",type="l")
abline(v=lambdas[order(mse2)[1]],lty=2)
o <- sort(sample(1:length(x),100))
plot(x,f,type="l",ylim=range(c(f,fit11$y,fit00$y[o])))
lines(x[o],fit11$y[o],lty=2,col=2)
lines(x[o],fit00$y[o],lty=3,col=3)
legend(70,1,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))
mtext(side=3,paste("N =",N),cex=1.2,line=0,outer=T)
dev.off()

###NOW for N=500
Nl <- 50
N <- 500
x <- seq(1,100,len=N)
f <- 2*sin(1/(x+18.62)*218)
y <- f + rnorm(N,0,sigma2)
lambdas <- seq(.01,2.2,len=Nl)
cvs <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rnorm(N*NN,0,sigma2),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit0 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse)[1]])
fit1 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs)[1]])
postscript("Plots/plot-05-05.ps")
par(mfrow=c(2,3),oma=c(0,0,2,0))
plot(lambdas,cvs,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs)[1]],lty=1)
plot(lambdas,mse+1,xlab="lambdas",type="l")
abline(v=lambdas[order(mse)[1]],lty=2)
o <- sort(sample(1:length(x),50))
plot(x,f,type="l",ylim=range(c(fit1$y,fit0$y[o])))
lines(x[o],fit1$y[o],lty=2,col=2)
lines(x[o],fit0$y[o],lty=3,col=3)
legend(70,0,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))

#N <- 500
x <- seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f + rt(N,3)
N1 <- 50
cvs2 <- sapply(lambdas,function(l) smooth.spline(x,y,all.knots=T,spar=l,cv=T)$cv.crit)
NN <- 20
AUX <-matrix(rt(N*NN,3),ncol=N)
AUX <- sweep(AUX,2,f,FUN="+")
mse2 <- sapply(lambdas,function(l){
  cat(".")
  aux <- cbind(rep(l,NN),AUX)
  aux<-apply(aux,1,function(yy)
	     sum((f-smooth.spline(x,yy[-1],all.knots=T,spar=yy[1])$y)^2)/500)
  mean(aux)
})
fit00 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(mse2)[1]])
fit11 <- smooth.spline(x,y,all.knots=T,spar=lambdas[order(cvs2)[1]])
plot(lambdas,cvs2,xlab="lambdas",type="l")
abline(v=lambdas[order(cvs2)[1]],lty=1)
plot(lambdas,mse2+sigma2,xlab="lambdas",type="l")
abline(v=lambdas[order(mse2)[1]],lty=2)
o <- sort(sample(1:length(x),100))
plot(x,f,type="l",ylim=range(c(f,fit11$y,fit00$y[o])))
lines(x[o],fit11$y[o],lty=2,col=2)
lines(x[o],fit00$y[o],lty=3,col=3)
legend(70,1,c("truth","CV","MSE"),lty=c(1,2,3),col=c(1,2,3))
mtext(side=3,paste("N =",N),cex=1.2,line=0,outer=T)
dev.off()

postscript("Plots/plot-05-06.ps")
y <- read.table("Data/cholostyramine.dat",header=T)
attach(y)
plot(compliance,improvement)
abline(lm(improvement~compliance,data=y),col=4,lty=1)
o <- order(compliance)
lines(compliance[o],loess(improvement~compliance,data=y)$fitted[o],col=2,lty=2)
dev.off()

###bootsrap.. there is bootstrap function in R, but we need to download library
postscript("Plots/plot-05-07.ps")
B <- 50
N <- length(compliance)
fit1 <- lm(improvement~compliance,data=y)
fit2 <- loess(improvement~compliance,data=y)
thetas <- c(predict(fit1,data.frame(compliance=c(60,80,100))),
            predict(fit2,data.frame(compliance=c(60,80,100))))
par(mfrow=c(1,2))
aux <- matrix(sample(1:N,B*N,replace=T),B,N)
plot(compliance,improvement,type="n")
abline(h=0,v=60)
plot(compliance,improvement,type="n")
abline(h=0,v=60)
thetastars <- apply(aux,1,function(o){
  fit1 <- lm(improvement~compliance,data=y,subset=o)
  fit2 <- loess(improvement~compliance,data=y,subset=o)
  par(mfg=c(1,1,1,2))
  abline(fit1)
  par(mfg=c(1,2,1,2))
  oo <- order(compliance[o])
  lines(compliance[o][oo],fit2$fitted[oo])
  c(predict(fit1,data.frame(compliance=c(60,80,100))),
    predict(fit2,data.frame(compliance=c(60,80,100))))
})
dev.off()
detach("y")

##this prints out the results
junk <- rbind(thetas,
              apply(thetastars,1,function(x) sqrt(var(x))))

print(round(junk))

############
#### CONFIDENCE BANDS STUFF
###############
N <- 100
x <- sort(runif(N,1,100))#seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f+rnorm(N,0,1)
Y <- diag(N)
l <- .7
S <- apply(Y,1,function(yy) loess(yy~x,span=l)$fitted)
aux <- svd(S) ##then ss' is ud^2u'
SS <- aux$u%*%diag(aux$d^2)%*%t(aux$u) ##this is ss'
dfvar <- sum(diag(SS))
dferr <- N - 2*sum(diag(S)) + dfvar
###TRUE
NN <- 5000
AUX <- matrix(rnorm(NN*N,0,1),ncol=N)
Gtrue <- apply(AUX,1,function(error){
  yy <- error+f;resid <- yy-S%*%yy
  sum(error^2)/(sum(resid^2)/dferr)})
fit1 <- S%*%y
residstar <- y - fit1
B <- 500
Gboot <- rep(0,B)
for(i in 1:B){
  	error <- sample(residstar,N,replace=T)
        yy <- error+fit1;resid <- yy-S%*%yy
        Gboot[i] <- sum(error^2)/(sum(resid^2)/dferr)
         }
Gapprox <-dferr+  dfvar*rf(NN,dfvar,dferr)

postscript("Plots/plot-05-08.ps")
par(mfrow=c(1,1))
plot(x,y)
lines(x,f,col=3)
lines(x,fit1,lty=2,col=4)
dev.off()

postscript("Plots/plot-05-09.ps")
par(mfrow=c(1,2))
RANGE <- range(Gtrue,Gapprox,Gboot)
qqplot(Gtrue,Gboot,ylim=RANGE,xlim=RANGE,pch="B",col=3)
lines(sort(Gtrue),sort(Gapprox),pch="F",col=4)
abline(0,1)
##NOW we make bootstrap curves
NNN <- 7
sigmahat <- sqrt((sum(((diag(N)-S)%*%y)^2)/dferr))
G <- Gboot ##we can use others here like Gapprox
qG <- quantile(G,.95)
fs <- sapply(1:NNN,function(i){
	resid<- rnorm(N,0,sigmahat)
        auxG <-  sum(resid^2)/(sigmahat^2)
        ##notice SS' = [UD][UD]'
        newf <- fit1+ aux$u%*%diag(aux$d)%*%resid
        if(auxG < qG) return(c(1,newf))
        else return(c(0,newf))
}
)
ci <- 2*sqrt(diag(SS)*sigmahat^2)
plot(x,fit1,ylim=range(c(fit1+ci,fit1-ci,as.vector(fs[-1,]))),type="l")
polygon(c(x,rev(x)),c(fit1+ci,rev(fit1-ci)),col=655,border=F)
lines(x,fit1)
apply(fs,2,function(yy) lines(x,yy[-1],col=3+yy[1],lty=3-yy[1]))
dev.off()

###NOW for t-distribution
N <- 100
x <- sort(runif(N,1,100))#seq(1,100,len=N)
f <- sin(2*pi*x/100)
y <- f+rt(N,3)
Y <- diag(N)
l <- .7
S <- apply(Y,1,function(yy) loess(yy~x,span=l)$fitted)
aux <- svd(S) ##then ss' is ud^2u'
SS <- aux$u%*%diag(aux$d^2)%*%t(aux$u) ##this is ss'
dfvar <- sum(diag(SS))
dferr <- N - 2*sum(diag(S)) + dfvar
###TRUE
NN <- 5000
AUX <- matrix(rt(NN*N,3),ncol=N)
Gtrue <- apply(AUX,1,function(error){
  yy <- error+f;resid <- yy-S%*%yy
  sum(error^2)/(sum(resid^2)/dferr)})
fit1 <- S%*%y
residstar <- y - fit1
B <- 1000
Gboot <- rep(0,B)
for(i in 1:B){
  	error <- sample(residstar,N,replace=T)
        yy <- error+fit1;resid <- yy-S%*%yy
        Gboot[i] <- sum(error^2)/(sum(resid^2)/dferr)
         }
Gapprox <-dferr+  dfvar*rf(NN,dfvar,dferr)

postscript("Plots/plot-05-10.ps")
par(mfrow=c(1,2))
RANGE <- range(Gtrue,Gapprox,Gboot)
qqplot(Gtrue,Gboot,ylim=RANGE,xlim=RANGE,pch="B",col=3)
lines(sort(Gtrue),sort(Gapprox),pch="F",col=4)
abline(0,1)
##NOW we make bootstrap curves
NNN <- 7
sigmahat <- sqrt((sum(((diag(N)-S)%*%y)^2)/dferr))
G <- Gboot ##we can use others here like Gapprox
qG <- quantile(G,.95)
fs <- sapply(1:NNN,function(i){
	resid<- rnorm(N,0,sigmahat)
        auxG <-  sum(resid^2)/(sigmahat^2)
        ##notice SS' = [UD][UD]'
        newf <- fit1+ aux$u%*%diag(aux$d)%*%resid
        if(auxG < qG) return(c(1,newf))
        else return(c(0,newf))
}
)
ci <- 2*sqrt(diag(SS)*sigmahat^2)
plot(x,fit1,ylim=range(c(fit1+ci,fit1-ci,as.vector(fs[-1,]))),type="l")
polygon(c(x,rev(x)),c(fit1+ci,rev(fit1-ci)),col=655,border=F)
lines(x,fit1)
apply(fs,2,function(yy) lines(x,yy[-1],col=3+yy[1],lty=3-yy[1]))
dev.off()


source('./knn.r', chdir = T)

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(iris[,1] - 1)
  }

  return (ans)
}

par(mfrow=c(1,1), pty="s")
# LOO CV, looking for the best k
stats <- fast_cvloo_knn()
plot(1:(length(iris[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

maxPoint = which(stats == max(stats))
points((1:(length(iris[,1]) - 1))[maxPoint], stats[maxPoint], pch = 19, col = "red")

bestK <- which.max(stats)
cat("Best K =", bestK, "\n")

1 - Nearest neighbors algorithm/knn-loocv.r


import::here(stringr, str_c)
import::here(Hmisc, rcorr.cens)
import::here(
    ggplot2,
    ggplot,
    aes_string,
    geom_point,
    ggtitle
)

#Calculate standardization variables
std = function(v) {
  if (FALSE) {
    #Examples
    std(c(1,2,3,4,5,NA,7))
    # [1] -1.2344268 -0.7715167 -0.3086067  0.1543033  0.6172134         NA  1.5430335

    #apply std on data
    purrr::map(mtcars, std) |> dplyr::bind_cols()
  }
  (v-mean(v, na.rm = TRUE))/sqrt(var(v, na.rm = TRUE))
}

std_fit = function (data) {
  if (FALSE) {
    #Examples
    a = std_fit(mtcars)
    a$stds
    #   mpg   cyl  disp    hp  drat    wt  qsec    vs    am  gear  carb
    # 1  6.03  1.79  124.  68.6 0.535 0.978  1.79 0.504 0.499 0.738  1.62
  }
  means = purrr::map_df(data, function(v) mean(v, na.rm = TRUE))
  stds = purrr::map_df(data, function(v) sqrt(var(v, na.rm = TRUE)))

  return(list(
    "variables"=colnames(means),
    "means"=means,
    "stds"=stds
  ))
}

std_transform = function(parameters, data) {
  if (FALSE) {
    #Examples
    std_paras = std_fit(mtcars[c("hp","mpg","vs")])
    std_transform(std_paras, mtcars) |> summary()
    std_transform(std_paras, rbind(mtcars,mtcars)) |> summary()
    std_transform(std_paras, mtcars[c("vs","mpg")]) |> summary()
    std_transform(std_paras, mtcars[c("carb","wt")]) |> summary()
  }
  common_var = intersect(colnames(data), parameters$variables)
  data = data[common_var]
  means = as.numeric(parameters$means[common_var])
  stds = as.numeric(parameters$stds[common_var])
  purrr::pmap(list(data, means, stds),
    function(v, m, std) (v-m)/std) |> dplyr::bind_cols()
}

# Make adjusted/unadjusted R squared
#
# Examples
# --------------
# > fit = lm(mpg ~ cyl + disp, mtcars); summary(fit)
#
# Residuals:
#     Min      1Q  Median      3Q     Max
# -4.4213 -2.1722 -0.6362  1.1899  7.0516
#
# Residual standard error: 3.055 on 29 degrees of freedom
# Multiple R-squared:  0.7596,    Adjusted R-squared:  0.743
# F-statistic: 45.81 on 2 and 29 DF,  p-value: 1.058e-09
#
# > make_r2(predict(fit, mtcars), mtcars$mpg)
# [1] 0.7595658
# > make_adjr2(predict(fit, mtcars), mtcars$mpg, 2)
# [1] 0.7429841
# > fit = lm(mpg ~ 0 + cyl + disp, mtcars); summary(fit)
#
# Residual standard error: 8.164 on 30 degrees of freedom
# Multiple R-squared:  0.8576,    Adjusted R-squared:  0.8481
# F-statistic: 90.33 on 2 and 30 DF,  p-value: 2.008e-13
#
# > make_r2(predict(fit, mtcars), mtcars$mpg, model_has_intercept = FALSE)
# [1] 0.8575967
# > make_adjr2(predict(fit, mtcars), mtcars$mpg, 2, model_has_intercept = FALSE)
# [1] 0.8481031
make_r2 <- function (preds, actual, model_has_intercept = TRUE){
    if (model_has_intercept){
        rss <- sum((preds - actual) ^ 2, na.rm = TRUE)
        tss <- sum((actual - mean(actual)) ^ 2, na.rm = TRUE)
        return(1 - rss/tss)
    } else if (!model_has_intercept) {
        rss <- sum((preds - actual) ^ 2, na.rm = TRUE)
        tss <- sum((actual) ^ 2, na.rm = TRUE)
        return(1 - rss/tss)
    } else {
        return('invalid model_has_intercept')
    }
}

make_adjr2 <- function (preds, actual, k, model_has_intercept = TRUE) {
    n = sum(!is.na(preds))
    r2 = make_r2(preds, actual, model_has_intercept)
    if (model_has_intercept){
        return(1 - (1 - r2) * (n - 1)/(n - k - 1))
    } else if (!model_has_intercept) {
        return(1 - (1 - r2) * (n)/(n - k))
    } else {
        return('invalid model_has_intercept')
    }
}

# Make rmse
#
# Examples
# -----------
# > fit = lm(mpg~cyl+disp, mtcars)
# > summary(fit)
# > make_rmse(fit$fitted.value, mtcars$mpg)
# > sqrt(sum(fit$residuals^2)/length(fit$residuals))
make_rmse = function(preds, actual){
    sqrt(mean((preds - actual) ^ 2, na.rm=TRUE))
}

# Linear regression parameters and weights conversion
#
# Examples
# -----------
# > data = purrr::map(mtcars, std) |> dplyr::bind_cols()
# > data$mpg = mtcars$mpg
# > ce = lm(mpg ~ cyl+disp, data)$coefficients; ce
# (Intercept)         cyl        disp
#   20.090625   -2.834752   -2.551109
# > w = parameters_to_weights(ce); w
# $weights
#       cyl      disp
# 0.5263322 0.4736678
#
# $signs
#  cyl disp
#   -1   -1
#
# $calibration
#         a         b
#  5.385861 20.090625
#
# > weights_to_parameters(w$weights, w$signs, w$calibration[1])
#       cyl      disp
# -2.834752 -2.551109
parameters_to_weights <- function(parameters){
    inter = parameters[1]
    names(inter) = NULL
    non_inter = parameters[2:length(parameters)]
    list(
        'weights' = abs(non_inter)/sum(abs(non_inter)),
        'signs' = ifelse(non_inter > 0, 1, -1),
        'calibration' = c('a' = sum(abs(non_inter)), 'b' = inter)
    )
}

#does not give intercept back
weights_to_parameters <- function(weights, signs, calibration_a){
    weights*signs*sum(abs(calibration_a))
}

# Linear regression parameters to R formula
parameters_to_formula = function(parameters, target){
    if (FALSE) {
        #Examples
        #-----------
        fit = lm(mpg ~ cyl+disp, mtcars)
        ce = fit$coefficients; ce
        #(Intercept)         cyl        disp
        #34.66099474 -1.58727681 -0.02058363
        fml = parameters_to_formula(ce, 'mpg'); fml
        #mpg ~ 34.6609947413328 + -1.58727680900718 * cyl + -0.0205836333707016 *
        #    disp
        #<environment: 0x000000000b9ac710>
        pred_from_fml = eval(parse(text = fml), mtcars)
        pred_from_fit = predict(fit, mtcars)
        names(pred_from_fit) = NULL
        sum(abs(pred_from_fml - pred_from_fit) > 1e-10)
        # [1] 0
    }
    inter = parameters[1]
    non_inter = parameters[2:length(parameters)]
    fml_no_inter = str_c(non_inter, names(non_inter), sep = ' * ', collapse = ' + ')
    fml = str_c(inter, fml_no_inter, sep=' + ')
    fml_target = str_c(target, fml, sep=' ~ ')
    as.formula(fml_target)
}

predict_from_formula = function (formula, data) {
    if (FALSE) {#Examples
        fit = lm(mpg ~ cyl+disp, mtcars)
        #save model as a formula
        fml = parameters_to_formula(fit$coefficients, 'mpg'); fml
        #mpg ~ 34.6609947413328 + -1.58727680900718 * cyl + -0.0205836333707016 *
        #  disp
        #<environment: 0x000001c323afa760>
        #apply formula to new data
        predict_from_formula(fml, mtcars*2-1)[1:5]
        #[1] 10.634771 10.634771 19.124576  6.600379 -3.947790
        #check against hard code calc
        data = mtcars*2-1
        res = (34.6609947413328 + -1.58727680900718 * data["cyl"] + -0.0205836333707016 * data["disp"])
        dplyr::pull(res)[1:5]
        #[1] 10.634771 10.634771 19.124576  6.600379 -3.947790

        #predict into a new column
        data = mtcars*2-1
        data["calc"] = predict_from_formula(fml, data)
    }
    eval(parse(text = formula), data)
}

# Make R formula from linear regression variable choice specifications
#
# Examples
# -------------
# > fml = make_formula(c('cyl', 'disp', 'hp', 'drat'), 'mpg')
# > lm(fml, mtcars)$coefficients
# (Intercept)         cyl        disp          hp        drat
# 23.98524441 -0.81402201 -0.01389625 -0.02317068  2.15404553
# > fml = make_formula(c('cyl', 'disp', 'hp', 'drat'), 'mpg', 0)
# > lm(fml, mtcars)$coefficients
#          cyl         disp           hp         drat
#  0.711008285 -0.009176678 -0.043640211  6.701808900
make_formula = function(variables, target, intercept = 1){
    fml = str_c(c(intercept, variables), collapse = ' + ')
    fml_target = str_c(target, fml, sep=' ~ ')
    as.formula(fml_target)
}

# Linear regression parameters to parameters that would have achived if normalised prior to regression
#
# Examples
# --------------
# > std <- function(v) (v-mean(v, na.rm = TRUE))/sqrt(var(v, na.rm = TRUE))
# > means = (purrr::map(mtcars, mean) |> unlist())[c('cyl','disp')]
# > stds = (purrr::map(mtcars, ~sqrt(var(., na.rm = TRUE))) |> unlist())[c('cyl'$
# > ce = lm(mpg ~ cyl+disp, mtcars)$coefficients; ce
# (Intercept)         cyl        disp
# 34.66099474 -1.58727681 -0.02058363
# > parameters_to_norm_parameters(ce[1], ce[2:length(ce)], means, stds)
# $norm_intercept
# (Intercept)
#    20.09062
#
# $norm_parameters
#       cyl      disp
# -2.834752 -2.551109
#
# > norm_data = purrr::map(mtcars, std) |> dplyr::bind_cols()
# > norm_data['mpg'] = mtcars['mpg']
# > lm(mpg ~ cyl+disp, norm_data)$coefficients
# (Intercept)         cyl        disp
#   20.090625   -2.834752   -2.551109
parameters_to_norm_parameters <- function(intercept, parameters, means, stds) {
    list(
        'norm_intercept' = sum(parameters * means) + intercept,
        'norm_parameters' = parameters * stds
    )
}

# Make scatter plot
#
# Examples
# -----------
# > plot_scatter(mtcars, 'mpg', 'disp')
# > data = mtcars
# > data['cyl_gt_5'] = ifelse(data['cyl'] > 5, 1, 0)
# > plot_scatter(data, 'mpg', 'disp', 'cyl_gt_5')
plot_scatter = function(data, x, y, z = NA) {
    if (is.na(z)) {
        plt = ggplot(data, aes_string(x = x, y = y)) +
            geom_point() +
            ggtitle(paste0(x, ' vs ', y))
    } else {
        plt = ggplot(data, aes_string(x = x, y = y, colour = z)) +
            geom_point() +
            ggtitle(paste0(x, ' vs ', y, ' coloured by ', z))
    }
    return(plt)
}

# Fit linear model, additionally report weights, additional metrics
#
# Examples
# ------------
# > std <- function(v) (v-mean(v, na.rm = TRUE))/sqrt(var(v, na.rm = TRUE))
# > data = purrr::map(mtcars, std) |> dplyr::bind_cols()
# > data$mpg = mtcars$mpg
# > fit_lm(c('cyl', 'disp'), 'mpg', data, 2)
# > fit_lm(c('cyl', 'disp'), 'mpg', data, 2, concise=FALSE)
# > vars = setdiff(colnames(mtcars),'mpg')
# > fit_lm(vars, 'mpg', data, 10)
# > fit_lm(c('disp', 'hp', 'wt', 'qsec', 'am'), 'mpg', data, 5)
fit_lm = function(
        variables,
        target,
        data,
        k,
        model_has_intercept=TRUE,
        concise=TRUE
    ){
    fml = make_formula(variables, target, model_has_intercept*1)
    fit = lm(fml, data)
    ce = fit$coefficients
    if (model_has_intercept){
        wts = parameters_to_weights(ce)
    } else {
        wts = parameters_to_weights(c(0, ce))
    }
    preds = predict(fit, data)
    actual = data[[target]]
    r2 = make_r2(preds, actual, model_has_intercept)
    adjr2 = make_adjr2(preds, actual, k, model_has_intercept)
    dxy = rcorr.cens(preds, actual)['Dxy']

    plt_data = data.frame(fitted=preds, actual=actual)
    plt = plot_scatter(plt_data, 'fitted', 'actual')

    if (concise){
        metrics = c(r2, adjr2, dxy)
        names(metrics) = c('r2', 'adjr2', 'dxy')
        return(list(
            'fml'=fml,
            'fit'=fit$coefficients,
            'weights'=round(wts$weights*100,2),
            'signs'=wts$signs,
            'metrics'=metrics
        ))
    } else{
        print(summary(fit))
        plt
        return(list(
            'fml'=fml,
            'fit'=fit,
            'weights'=wts,
            'r2'=r2,
            'adjr2'=adjr2,
            'dxy'=dxy,
            'plt'=plt
        ))
    }
}

# Test linear model specified via weights, report calibration parameters, and metrics
#
# Examples
# -------------
# > std <- function(v) (v-mean(v, na.rm = TRUE))/sqrt(var(v, na.rm = TRUE))
# > data = purrr::map(mtcars, std) |> dplyr::bind_cols()
# > data$mpg = mtcars$mpg
# > fit = fit_lm(c('disp', 'hp', 'wt', 'qsec', 'am'), 'mpg', data, 5)
# > fit
# > test_wts(c('disp', 'hp', 'wt', 'qsec', 'am'), c(0.1, 0.15, 0.4, 0.2, 0.15),
# >     fit$signs, 'mpg', data, 5)
# > test_wts(c('disp', 'hp', 'wt', 'qsec', 'am'), c(0, 0.2, 0.4, 0.2, 0.2),
# >     fit$signs, 'mpg', data, 4)
test_wts = function(
        variables,
        weights,
        signs,
        target,
        data,
        k,
        concise=TRUE
    ){
    man_wts = weights
    names(man_wts) = variables
    fml = parameters_to_formula(c(0, man_wts * signs), target)
    x = eval(parse(text = fml), data)
    y = data[[target]]
    ce = lm(y ~ 1 + x)$coefficients
    calibration_a = ce[2]
    calibration_b = ce[1]

    preds = eval(parse(text = fml), data) * calibration_a + calibration_b
    actual = data[[target]]
    r2 = make_r2(preds, actual)
    adjr2 = make_adjr2(preds, actual, k)
    dxy = rcorr.cens(preds, actual)['Dxy']

    plt_data = data.frame(fitted=preds, actual=actual)
    plt = plot_scatter(plt_data, 'fitted', 'actual')

    if (concise){
        metrics = c(r2, adjr2, dxy)
        names(metrics) = c('r2', 'adjr2', 'dxy')
        return(list(
            'fml'=fml,
            'calibration'=ce,
            'weights'=round(weights*100,2),
            'metrics'=metrics
        ))
    } else{
        plt
        return(list(
            'fml'=fml,
            'calibration_a'=calibration_a,
            'calibration_b'=calibration_b,
            'weights'=weights,
            'r2'=r2,
            'adjr2'=adjr2,
            'dxy'=dxy,
            'plt'=plt
        ))
    }
}

if (identical(environment(), globalenv())){
    1
}


library(mixtools)
library(animation)

plotClusteringState <- function(data, clustering, components, likelihoods, idx) {
  nComponents = length(unique(clustering))
  par(mfrow = c(2,1))
  plot(data, col = clustering + 1, xlim= c(-4, 4), ylim= c(-4, 4), main = "Cluster Membership Evolution", xlab = "", ylab = "")
  for(k in seq_len(nComponents)){
    mean = as.numeric(strsplit(components[1, (k - 1) *2 + 1],":")[[1]])
    covMat = matrix(as.numeric(strsplit(components[1, k * 2],":")[[1]]),2,2)
    ellipse(mu=mean, sigma=covMat, alpha = .005, npoints = 250, col=k)
    ellipse(mu=mean, sigma=covMat, alpha = .01, npoints = 250, col=k)
    ellipse(mu=mean, sigma=covMat, alpha = .05, npoints = 250, col=k)
    ellipse(mu=mean, sigma=covMat, alpha = .10, npoints = 250, col=k)
  }
  plot(y=likelihoods, x = 1:length(likelihoods), t="l", xlab = "Iteration", ylab = "LogLikelihood", main = "LogLikelihood Evolution")
  points(x= idx, y= likelihoods[idx], col="red", cex=1)
  points(x= idx, y= likelihoods[idx], col="red", cex=2)

}

dirPath = [RESULT PATH HERE]

data = read.csv(paste0(dirPath, "/data.csv"), header = F)[,-1]
# Final clustering obtained after dpmm
clusteringEveryIteration = read.csv(paste0(dirPath, "/membershipHistory.csv"), header = F)[,-1]
nClusterMax = max(clusteringEveryIteration) + 1
# One line = every components of a given iteration
componentsEveryIterations = read.csv(paste0(dirPath, "/componentsHistory.csv"),
                      stringsAsFactors = F, header = F,
                      col.names = paste0("V",seq_len(2*nClusterMax+1)),
                      fill = TRUE)[,-1]
# likelihoods
likelihoods = read.csv(paste0(dirPath, "/likelihoods.csv"),
                                     stringsAsFactors = F, header = F)[-1,-1]

nIter = length(likelihoods)
colnames(data) <- c("X", "Y")

nIteration = nrow(clusteringEveryIteration)
oopt = ani.options(interval = 0.4)

des = c("Bivariate Gaussian DPMM.\n\n")
saveGIF({
  par(mar = c(4, 4, 2, 2))
  for (i in 1:nIter) {
    print(i)
    plotClusteringState(data,
                        clustering = unlist(clusteringEveryIteration[i,]),
                        components = componentsEveryIterations[i, ],
                        likelihoods, i)
    ani.pause()
  }
}, title = "Evolution of DPMM clustering",
description = des,ani.width = 400, ani.height = 700)


=begin
[((<index-ja|URL:index-ja.html>))]
= Algebra::JordanForm
((*(ジョルダン行列クラス)*))

ジョルダン行列を表現するクラスです。

== ファイル名:
* ((|jordan-form.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

なし

== 関連する関数:

--- Algebra::MatrixAlgebra#jordan_form
    ((|self|))のジョルダン標準形を返します。

--- Algebra::MatrixAlgebra#jordan_form_info
    ((<Algebra::JordanForm.decompose>))(self) と同じです。

== クラスメソッド:

--- ::new(array)
    ((<JordanForm>)) オブジェクトを返します。((|array|)) は、
    (({[対角成分, サイズ]})) を要素とする配列です。行列を得るには
    メソッド ((<to_matrix>)) を施すことにより、（上三角）ジョルダン
    行列が得られます。下三角にするには((<to_matrix_l>))を用います。

    例:
      j = Algebra::JordanForm.new([[2, 3], [-1, 2]])
      j.to_matrix.display #=>
      #  2,   1,   0,   0,   0
      #  0,   2,   1,   0,   0
      #  0,   0,   2,   0,   0
      #  0,   0,   0,  -1,   1
      #  0,   0,   0,   0,  -1

--- ::construct(elem_divs, facts, field, pfield)
    略。

--- ::decompose(m)
    行列 ((|m|)) のジョルダン行列を ((|jm|))、((|m|)) を ((|jm|)) に
    変形するために必要な左変形を ((|tL|))、右変形を ((|sR|))、ジョルダン
    分解をするのに必要な最小分解体を ((|field|)) 、最小分解体まで基礎体
    を拡大するのに必要な方程式の配列を ((|modulus|)) とするとき、

      [jm, tL, sR, field, modulus]

    を返します。（(({tL * sR == 単位行列})) です。）

    例:
      m = Algebra.SquareMatrix(Rational, a.size)[
       [-1, 1, 2, -1],
       [-5, 3, 4, -2],
       [3, -1, 0, 1],
       [5, -2, -2, 0]
      ]
      jf, p, q, field, modulus = Algebra::JordanForm.decompose(m)
      jf.display; puts #=>
      #  2,   0,   0,   0
      #  0,   a,   0,   0
      #  0,   0,   b,   0
      #  0,   0,   0, -b - a

      p modulus #=> [a^3 + 3a - 1, b^2 + ab + a^2 + 3]

      print "P =\n"; p.display; puts
      print "P^-1 =\n"; q.display; puts

      m = m.convert_to(field)
      p jf == p * m * q #=> true

== メソッド:

--- to_matrix(ring)
    ((|ring|)) 上のジョルダン行列（上三角）を返します。

    例:
      j = Algebra::JordanForm.new([[2, 3], [-1, 2]])
      j.to_matrix(Integer).display #=>
      #  2,   1,   0,   0,   0
      #  0,   2,   1,   0,   0
      #  0,   0,   2,   0,   0
      #  0,   0,   0,  -1,   1
      #  0,   0,   0,   0,  -1

--- to_matrix_r(ring)
    ((<to_matrix>)) と同じ。

--- to_matrix_l(ring)
    ジョルダン行列（下三角）を返します。

=end


d <- function(piece) (sum(piece$mktcap*piece$spread)/sum(piece$mktcap))


library(readxl)
library(pracma)

setwd ("c://R")
VehicleData <- read_excel("VehiclesItaly.xlsx")
head(VehicleData)
summary(VehicleData)

y<-VehicleData$Registrations
x<-(VehicleData$Population)
alpha <- mldivide(x,y)

plot(x,y,cex = 1.3,lwd = 10)
abline(a=0,b=alpha,lwd=5)

VehicleRegFit<-c(alpha)*x
Residual=y-VehicleRegFit

plot(Residual,cex = 1.3,lwd = 10)
abline(a=0,b=0,lwd=5)
stem(Residual)

Rsq1 = 1 - sum((y - VehicleRegFit)^2)/sum((y - mean(y))^2)

x1<-cbind(x,1)
alpha_beta <- mldivide(x1,y)
VehicleRegFit2<-x1%*%alpha_beta

plot(x,y,cex = 1.3,lwd = 10)
abline(a=0,b=alpha,lwd=5,col="red")
abline(a=alpha_beta[2,],b=alpha_beta[1,],lwd=5,lty=3)

Rsq2 = 1 - sum((y - VehicleRegFit2)^2)/sum((y - mean(y))^2)


#' @title findMoments
#' @description to find the first two moments of a distrbution from quantile breaks (defined by the upper and lower percent)
#' @note Gamma distribution returns shape and scale rather than rate (as per winbugs distribution) for use in r rate=1/scale lo and l.perc are the value and percentile for the low end of the distribution, up and u.perc are the upper values and percentiles
#' @family abysmally documented
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export
#source('C:/Documents and Settings/cooka/Desktop/Scripts/Surplus Production dec 2011/bugs/finding moments of distributions.R')
####Date:			February 10, 2012

findMoments <- function(lo=0.1,up=0.8,l.perc=0.025,u.perc=0.975,dist=c('norm','lnorm','weibull','gamma','inv.gamma'),plot=T) {
	if(dist=='norm') {
			 sig2 = ((up-lo)/(qnorm(u.perc)-qnorm(l.perc)))^2
			 xbar = (lo*qnorm(u.perc)-up*qnorm(l.perc))/(qnorm(u.perc)-qnorm(l.perc))
			 if(plot) {
			 plot(density(rnorm(10000,xbar,sqrt(sig2))),main='')
			 abline(v=lo)
			 abline(v=up)
			 }
			 return(list(xbar=xbar,sig2=sig2))
	  }
	if(dist=='lnorm') {
			 sig2 = ((log(up)-log(lo))/(qnorm(u.perc)-qnorm(l.perc)))^2
			 xbar = (log(lo)*qnorm(u.perc)-log(up)*qnorm(l.perc))/(qnorm(u.perc)-qnorm(l.perc))
			 if(plot) {
			 plot(density(rlnorm(10000,xbar,sqrt(sig2))),main='')
			 abline(v=lo)
			 abline(v=up)
			 }
			  return(list(xbar=xbar,sig2=sig2))
	 }
	if(dist=='weibull') {
			gam = (log(-log(1-u.perc))-log(-log(1-l.perc)))/(log(up)-log(lo))
			beta = lo/(-log(1-l.perc))^(1/gam)
			if(plot) {
		 	plot(density(rweibull(10000,gam,beta)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=gam,beta=beta))
	}
	if(dist=='gamma') {
			a=mean(c(lo,up))
			alpha <- function(a) {
			b <- qgamma(u.perc,a,1) / qgamma(l.perc,a,1)
			o = (b-(up/lo))^2
			return(list(a=a,o=o))
			}
			op<-function(a) alpha(a)$o
			ot <- optimize(f=op,interval=c(0,up))
			alp <- ot$minimum
			en <- lo/qgamma(l.perc,alp,1)
			if(plot) {
		 	plot(density(rgamma(10000,alp,scale=en)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=alp,scale=en))
	}
		if(dist=='inv.gamma') {
			a=mean(c(1/lo,1/up))
			ilo<-1/lo
			iup<-1/up
			alpha <- function(a) {
			b <- qgamma((1-u.perc),a,1) / qgamma((1-l.perc),a,1)
			o = (b-(iup/ilo))^2
			return(list(a=a,o=o))
			}
			op<-function(a) alpha(a)$o
			ot <- optimize(f=op,interval=c(0,up))
			alp <- ot$minimum
			en <- ilo/(1/qgamma((1-l.perc),alp,1))
			if(plot) {
		 	plot(density(1/rgamma(10000,alp,scale=1/en)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=alp,scale=en))
	}
}


CK <- c(20, 60, 100, 140, 180, 220, 260, 300, 340, 380, 420, 460, 500)
y <- cbind( c(2, 13, 30, 30, 21, 19, 18, 13, 19, 15, 7, 8, 35) , c(88, 26, 8, 5, 0, 1, 1, 1, 0, 0, 0, 0, 0))
model1=glm(y~CK, family = binomial)
summary(model1)
cbind(CK,PRED=predict(model1,type = "response"))
 #  probability that a patient had a heart attack when the CK level in the patient was 140 is .868


#' Probability of path choices
#'
#' This function calculates probabilities for selection of each path on the network based on set of path disutilities (costs). The function uses either a logit or probit random utility model.
#' @param u Vector of utlities on each path
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param RUM Choice of random utility model. Can be "logit" (the default) or "probit".
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @return Vector of route choice probabilities
#' @keywords path route probability
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' ODpair <- c(1,1,2,2)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' u <- PathCost(x,A,Alpha,Beta)
#' PathProb(u,ODpair,A,RUM="logit",theta=0.7)
#' @export

PathProb <- function(u,ODpair,A,RUM="logit",theta=1){
	if(RUM=="logit"){
		p <- LogitPathProb(u=u,ODpair=ODpair,theta=theta)
	}
	if(RUM=="probit"){
		p <- ProbitPathProb(u=u,ODpair=ODpair,A=A,theta=theta)
	}
	p
}


suppressPackageStartupMessages(library(float))
set.seed(1234)
tol=1e-6

same = function(test, truth) stopifnot(all.equal(test, truth, tol=tol))

x1 = matrix(-4:5, 5)
s1 = fl(x1)
y = 1L
z = 1.0
s2 = flrunif(5)

test = dbl(sum(s1))
truth = sum(x1)
same(test, truth)

test = dbl(sum(s1, s2))
truth = sum(x1, dbl(s2))
same(test, truth)

test = dbl(sum(s1, y))
truth = sum(x1, y)
same(test, truth)

x2 = x1
x2[3, 1] = NA_integer_
x2[4, 2] = NA_integer_
s2 = fl(x2)

test = dbl(sum(s2, na.rm=FALSE))
truth = sum(x2, na.rm=FALSE)
same(test, truth)

test = dbl(sum(s2, na.rm=TRUE))
truth = sum(x2, na.rm=TRUE)
same(test, truth)


#' f_loss
#'
#' Return the quantile loss criteria
#'
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param taustar vector of estimated tau for each observations
#' @param v_y vector of y
#'
#' @param m_sigma $K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_1K_2$ vector $H_1$
#' @param h2 $K_1K_2$ vector $H_2$
#'
#' @return the quantile loss
#'
f_loss <- function(til_beta, taustar, v_y, m_sigma, h1, h2) {
    loss <- crossprod((taustar - 0.5), v_y)
    loss <- loss - crossprod((h1 + h2), m_sigma %*% til_beta)
    loss <- loss / length(v_y)
    return(c(loss))
}

#' f_criteria
#'
#' Return the QR criteria
#'
#' @param beta the current estimation for $\beta$
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param taustar vector of estimated tau for each observations
#' @param v_y vector of y
#'
#' @param m_sigma $K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_1K_2$ vector $H_1$
#' @param h2 $K_1K_2$ vector $H_2$
#' @param s $K_1K_2 \times K_1K_2$ $S$ matrix
#'
#' @return the quantile loss
#'
f_criteria <- function(beta, til_beta, taustar, v_y, m_sigma, h1, h2, s) {
    loss <- f_loss(til_beta, taustar, v_y, m_sigma, h1, h2)
    criteria <- loss + crossprod(beta, s %*% beta)
    return(c(criteria))
}


library(dplyr)
library(ggplot2)
library(magick)
library(gganimate)

d <- mtcars
fit <- lm(mpg ~ hp, data = d)
d$predicted <- predict(fit)   ## predicted values
d$residuals <- residuals(fit) ## residuals
coefs<-coef(lm(mpg ~ hp, data = mtcars))
x<-d$hp
move_line<-c(seq(-6,6,.5),seq(6,-6,-.5))
total_error<-length(length(move_line))
cnt<-0
for(i in move_line){
    cnt<-cnt+1
    predicted_y <- coefs[2]*x + coefs[1]+i
    error_y <- (predicted_y-d$mpg)^2
    total_error[cnt]<-sqrt(sum(error_y)/32)
}
move_line_sims<-rep(move_line,each=32)
total_error_sims<-rep(total_error,each=32)
sims<-rep(1:50,each=32)
d <- d %>% slice(rep(row_number(), 50))
d <- cbind(d,sims,move_line_sims,total_error_sims)

anim <- ggplot(d, aes(x = hp, y = mpg, frame=sims)) +
    geom_smooth(method = "lm", se = FALSE, color = "darkgrey",lty = 2) +
    geom_abline(intercept = 30.09886+move_line_sims, slope = -0.06822828)+
    lims(x = c(0,400), y = c(-10,40))+
    geom_segment(aes(xend = hp, yend = predicted+move_line_sims, color="red"), alpha = .5) +
    geom_point() +
    theme_classic()+
    theme(legend.position="none")+
    xlab("Explanatory variable")+ylab("Response variable")+
    transition_manual(frames=sims)+
    enter_fade() +
    exit_fade()+
    ease_aes('sine-in-out')

anim_save("lm.gif",animate(anim,fps=5))


# one sided test
sigma=2.4
delta=1.5
z_alpha=qnorm(0.05)
z_beta=qnorm(0.10)
sample_size=2*(sigma^2)*((z_alpha+z_beta)^2)/(delta^2)
print(sample_size)


library(rstudioapi)
library(ellipse)
this.dir <- dirname(rstudioapi::getActiveDocumentContext()$path)
setwd(this.dir)

##### DATA #####

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

##### 8.3 ######
eigen(as.matrix(rbind(c(2,0,0),c(0,4,0),c(0,0,4))))

##### 8.6 #####
s = as.matrix(cbind(c(7476.45,303.62),c(303.62,26.19)))
eigen = eigen(s)

xbar =c(155.6,14.7)
plot(ellipse(s,centre =xbar),type = 'l',xlim=c(-100,400),ylim=c(0,30),xlab = "X1",ylab = "X2",main = "constant density ellipse")
points(xbar[1],xbar[2],pch = 17)
c = sqrt(1.4)
ax1=c*sqrt(eigen$values[1])*eigenS$vectors[,1]
ax2=c*sqrt(eigen$values[2])*eigenS$vectors[,2]
lines(c(xbar[1]-ax1[1],xbar[1]+ax1[1]),c(xbar[2]-ax1[2],xbar[2]+ax1[2]),lty=1)
lines(c(xbar[1]-ax2[1], xbar[1]+ax2[1]),c(xbar[2]-ax2[2],xbar[2]+ax2[2]),lty=2)
legend(x = "topleft", c("y1","y2"), lty = c(1,2))

##### 8.7 #####
p  = cov2cor(s)
eigen = eigen(p)

##### 8.18 #####
e8_18 = read.table("e8_18.txt",header = TRUE)
#assuming PCA output is based on correlation matrix (or variables of unit variance)
pc_correlations <- function(pca_output) {
  p <- ncol(pca_output$rotation)
  pccor=matrix(NA, nrow=p, ncol=p)
  for(i in 1:p){
    for(k in 1:p){
      pccor[k,i]=pca_output$rotation[k,i]*pca_output$sdev[i]
    }
  }
  colnames(pccor) <- paste0("PC", 1:p)
  rownames(pccor) <- rownames(pca_output$rotation)
  pccor
}
data("iris")
pca <- prcomp(iris[,1:4])
summary(pca)
pc_correlations(pca)


library(ggplot2)
library(reshape2)
library(Hmisc)
library(stats)
#library(wesanderson)

#pal <- wes_palette("Cavalcanti1", 100, type = "continuous")

cormatrix = rcorr(as.matrix(radar_data), type='spearman')

cordata = melt(cormatrix$r)
ggplot(cordata, aes(x=Var1, y=Var2, fill=value)) +
  geom_tile() + xlab("") + ylab("") + theme(text = element_text(size = 18),
                                            axis.text.x = element_text(angle = 45, hjust = 1),
                                            legend.text=element_text(size=13),
                                            legend.title=element_text(size=15)) +
  guides(fill=guide_legend(title=" \u03C1")) +
  scale_fill_continuous(high = "#132B43", low = "#56B1F7")


# Authors: Grzegorz Protaziuk, Robert Bembenik
# Script EDAMI lab6
# Clustering

#setting working directory - adjust a path to your directory with a dataset

install.packages("fpc")

library(dbscan)
library(fpc)
library(cluster)
library(factoextra)

##### kmeans ##################
set.seed(7777)

data("iris")
summary(iris)
iris2 = iris[,-5]
iris2

?kmeans
iris2.kmeans = kmeans(iris2,3, iter.max = 20, nstart=20)

#getting information about clustering
print(iris2.kmeans)
print(iris2.kmeans$iter)
print(iris2.kmeans$centers)

#compare clusters with original class labels
table(iris$Species,iris2.kmeans$cluster)

#plot clusters
plot(iris2[,1:2], col = iris2.kmeans$cluster)
#add cluster centers
points(iris2.kmeans$centers[,1:2], col = 1:3, pch = 8, cex=2)

# Quality of the clustering

km<-kmeans(iris2,3)

#alternative execution of kmeans
km_alt<-eclust(iris2, "kmeans", k=3, graph=FALSE)
fviz_silhouette(km_alt, palette="jco")

# From the output, avg.silwidth represents the average silhouette width. A silhouette is a measurement
# that considers how closely related objects are within the cluster and how clusters are separated
# from each other. The silhouette value usually ranges from 0 to 1; a value closer to 1 suggests
# the data is better clustered.

silinfo<-km_alt$silinfo
names(silinfo)

#silhouette length for each observation
head(silinfo$widths[,1:3],10)
#silhouette length for each cluster
silinfo$clus.avg.widths
#average silhouette length
silinfo$avg.width

# Rand index
# The corrected Rand index provides a measure for assessing the similarity between
# two partitions, adjusted for chance. Its range is -1 (no agreement) to 1 (perfect agreement).
species <- as.numeric(iris$Species)
clust_stats<-cluster.stats(d=dist(iris2), species, km_alt$cluster)
clust_stats$corrected.rand

#### data scaling
?scale
irisScale <- scale(iris2, center = FALSE)
str(irisScale)
iris2.kmeansS = kmeans(irisScale,3, iter.max = 20)
str(iris2.kmeansS)
table(iris$Species,iris2.kmeansS$cluster)

plot(irisScale[,3:4], col = iris2.kmeansS$cluster)
#add cluster centers
points(iris2.kmeansS$centers[,3:4], col = 1:3, pch = 8, cex=2)

###############################################################
# finding the optimal number of groups with the "elbow" method
###############################################################

wss <- vector(mode = "integer" ,length = 15)

#  1 to 15 clusters
for (i in 1:15) {
  kmeans.group <- kmeans(irisScale, centers = i, nstart=20)
  # total within-cluster sum of squares
  wss[i] <- kmeans.group$tot.withinss
}

# total within-cluster sum of squares per number of groups
plot(1:15, wss, type = "b",
     xlab = "number of groups",
     ylab = "total within-cluster sum of squares")

####################################
# PAM - partitioning around medoids#
####################################

# deciding on the optimal number of clusters
fviz_nbclust(iris2, pam, method = "silhouette")+theme_classic()

# division into 2 clusters
pam.res <- pam(iris2, 2)

# clustering results together with information on objects being cluster centers
print(pam.res)

#adding information on cluster assignment
iris_clus<-cbind(iris2, pam.res$cluster)
head(iris_clus)

#cluster centers
print(pam.res$medoids)

#cluster assignment
pam.res$clustering

#clustering visualization
fviz_cluster(pam.res,
             palette = c("#00AFBB", "#FC4E07"), # color palette
             ellipse.type = "t", # ellipse of concentration
             repel = TRUE, # avoid overlapping (slows down)
             ggtheme = theme_light() #background color
)

#### hierarchical clustering
#sample data
idx <- sample(1:nrow(iris), 50)
irisSample <- iris[idx,1:4]

?hclust
#calculation of a distance matrix
?dist
distM = dist(irisSample)
distT = as.matrix(distM)

dim(distT)
distT[1:5,1:5]

#hierarchical clustering for different linkage methods
iris2.hc_complete <- hclust(distM, method="complete")
iris2.hc_single <- hclust(distM, method="single")
iris2.hc <- hclust(distM, method="average")
iris2.hc_centroid <- hclust(distM, method="centroid")

#dendrograms for different clustering
?plot
par(mfrow=c(2,2))
plot(iris2.hc, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc, k=3, border=2:4)

plot(iris2.hc_complete, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_complete, k=3, border=2:4)

plot(iris2.hc_single, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_single, k=3, border=2:4)

plot(iris2.hc_centroid, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_centroid, k=3, border=2:4)
par(mfrow=c(1,1))

#generates clusters
?cutree
iris2.hc.groups <- cutree(iris2.hc, k=3)
iris2.hc.groups

#compare clusters with original class labels
table(iris$Species[idx], iris2.hc.groups)

##### dbscan algorithm ##########################

?dbscan

# MinPts parameter estimation
# The idea is to calculate the average of the distances of every point to its k nearest
# neighbors. The value of k will be specified by the user and corresponds to MinPts.
# Next, these k-distances are plotted in an ascending order. The aim is to determine
# the “knee”, which corresponds to the optimal eps parameter.
# A knee corresponds to a threshold where a sharp change occurs along the k-distance
# curve.

dbscan::kNNdistplot(iris2, k=5)
abline(h=0.5, lty="dashed")

# dbscan alg. execution

iris2.dbscan <- dbscan(iris2, eps=0.5, MinPts=5)

#compare clusters with original class labels
#cluster 0 means noise
table(iris$Species, iris2.dbscan$cluster)

iris2.dbscan <- dbscan(iris2, eps=0.4, MinPts=5)
table(iris$Species, iris2.dbscan$cluster)

# plot clusters
plot(iris2.dbscan, iris2)
plot(iris2.dbscan, iris2[c(1,4)])

############ Laboratory task ###################
#calculation of accuracy
accuracyCalc <- function(confTbl, startCol)
{
  corr = 0;
  for(i in startCol:ncol(confTbl))
  {
    corr = corr + max(confTbl[,i])
  }
  accuracy = corr/sum(confTbl)
  accuracy
}

#data set for the laboratory task
#http://archive.ics.uci.edu/ml/datasets/Cardiotocography

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/cardioto_noClass_corr.csv','cardioto_noClass_corr.csv')
ctg_noClass <- read.csv("cardioto_noClass_corr.csv",row.names = 1)

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/cardioto_all_corr.csv','cardioto_all_corr.csv')
ctg_all <- read.csv("cardioto_all_corr.csv",row.names = 1)

#example
card.kmeans = kmeans(ctg_noClass,10)
res3 = table(ctg_all$CLASS,card.kmeans$cluster )
res3
accuracyCalc(res3,1)

#wines
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-red.csv', 'wine_red.csv');
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv', 'wine_white.csv');
wineRed_ds = read.table("wine_red.csv", header = TRUE, sep=";", na.strings= "*")
wineRed_dsC <- wineRed_ds[,-12]

#example - wines
card.kmeans = kmeans(wineRed_dsC,6)
res3 = table(wineRed_ds$quality,card.kmeans$cluster )
res3
accuracyCalc(res3,1)


setwd("~/Desktop/Projects/data_mining/labs/5")

library(XLConnect)
library(readxl)
library(caret)
library(tidyverse)
library(dbscan)
library(fpc)
library(cluster)
library(factoextra)
library(dplyr)

#install.packages("car")
#install.packages("tidyverse")
#install.packages("factoextra")
#install.packages("dply")

#R.Version()

wine_raw <- read.table("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv", header=TRUE, sep=';')
summary(wine_raw)
head(wine_raw)
names(wine_raw)
str(wine_raw)
table(wine_raw$quality)

# How many observations in the column are NA
na_columns_rate = sapply(wine_raw, FUN = function(x) sum(is.na(x))/length(x))
print(na_columns_rate)
#no NA columns
# Remove almost fully NA columns
#new_dataset = wine[,na_columns_rate < 0.9]
#new_dataset

# Make all the columns numeric
original_data_types = sapply(wine_raw, typeof)
print(original_data_types) # already ok

# Last column shoould be dropped acording to task description (quality)
wine_raw %>% select(1:11) -> wine

names(wine)

# we define a seed for purposes of reprodutability
set.seed(123)
?kmeans
wine.kmeans<-kmeans(wine, centers = 6, nstart = 20)
#getting information about clustering
print(wine.kmeans)
print(wine.kmeans$iter)
print(wine.kmeans$centers)

#compare clusters with original class labels
table(wine_raw$quality,wine.kmeans$cluster)

#Plotting the result of K-means clustering can be difficult because of the high dimensional nature of the data.
#To overcome this, the plot.kmeans function in useful performs
#multidimensional scaling to project the data into two dimensions and then color codes the points according to cluster membership
#install.packages("useful",repos = "http://cran.us.r-project.org")
#library(useful)
#plot(data, data=wine)

#distance <- get_dist(wine)
# very costly computation
#fviz_dist(distance, gradient = list(low = "#00AFBB", mid = "white", high = "#FC4E07"))

#If there are more than two dimensions (variables) fviz_cluster will perform principal
#component analysis (PCA) and plot the data points according to the first two principal
#components that explain the majority of the variance.
fviz_cluster(wine.kmeans, data = wine_raw)

# Average Silhouette Method
# function to compute average silhouette for k clusters
avg_sil <- function(k) {
  km.res <- kmeans(df, centers = k, nstart = 25)
  ss <- silhouette(km.res$cluster, dist(df))
  mean(ss[, 3])
}

#In short, the average silhouette approach measures the quality of a clustering.
#That is, it determines how well each object lies within its cluster.
#A high average silhouette width indicates a good clustering.
#The average silhouette method computes the average silhouette of observations for different values of k.
#The optimal number of clusters k is the one that maximizes the average silhouette over a range of possible values for k.

# function to compute average silhouette for k clusters
avg_sil <- function(k) {
  km.res <- kmeans(df, centers = k, nstart = 25)
  ss <- silhouette(km.res$cluster, dist(df))
  mean(ss[, 3])
}

#alternative execution of kmeans
wine.kmeans_alt<-eclust(wine, "kmeans", k=6, graph=FALSE)
fviz_silhouette(wine.kmeans_alt, palette="jco")

silinfo<-wine.kmeans_alt$silinfo
names(silinfo)

#silhouette length for each observation
head(silinfo$widths[,1:3],10)
#silhouette length for each cluster
silinfo$clus.avg.widths
#average silhouette length
silinfo$avg.width

# Average silhoutte lenght is 0.3138577 for data without preprocessing etc.

?scale
#### data scaling
wineScale <- scale(wine, center = FALSE)
str(wineScale)

wine.kmeansS = kmeans(wineScale, 6, iter.max = 20)
str(wine.kmeansS)

#after scaling
table(wine_raw$quality,wine.kmeansS$cluster)
#before
table(wine_raw$quality,wine.kmeans$cluster)

#alternative execution of kmeans
wine.kmeansS_alt<-eclust(wineScale, "kmeans", k=6, graph=FALSE)

silinfo<-wine.kmeansS_alt$silinfo
names(silinfo)

#silhouette length for each observation
head(silinfo$widths[,1:3],10)
#silhouette length for each cluster
silinfo$clus.avg.widths
#average silhouette length
silinfo$avg.width

#after scaling
fviz_silhouette(wine.kmeansS_alt, palette="jco")
#before scaling
fviz_silhouette(wine.kmeans_alt, palette="jco")
#worse 0.18 to  0.31

accuracyCalc <- function(confTbl, startCol)
{
  corr = 0;
  for(i in startCol:ncol(confTbl))
  {
    corr = corr + max(confTbl[,i])
  }
  accuracy = corr/sum(confTbl)
  accuracy
}

# Accuracy without scaling
res3 = table(wine_raw$quality,wine.kmeans_alt$cluster)
res3
accuracyCalc(res3,1)

# Accuracy with scaling
res3 = table(wine_raw$quality,wine.kmeansS_alt$cluster)
res3
accuracyCalc(res3,1)

#0.4583503 > 0.4505921

###############################################################
# finding the optimal number of groups with the "elbow" method
###############################################################

########### from laboratory ######################

wss <- vector(mode = "integer" ,length = 10)

#  1 to 10 clusters
for (i in 1:10) {
  kmeans.group <- kmeans(wine, centers = i, nstart=20)
  # total within-cluster sum of squares
  wss[i] <- kmeans.group$tot.withinss
}

# total within-cluster sum of squares per number of groups
plot(1:10, wss, type = "b",
     xlab = "number of groups",
     ylab = "total within-cluster sum of squares")

########## from data mining book ###################

#Fortunately, this process to compute the
#“Elbow method” has been wrapped up in a single function (fviz_nbclust):
set.seed(123)

fviz_nbclust(wine, kmeans, method = "wss")

#Average Silhouette Method
#In short, the average silhouette approach measures the quality of a clustering.
#That is, it determines how well each object lies within its cluster. A high average silhouette width indicates a good clustering.
#The average silhouette method computes the average silhouette of observations for different values of k

fviz_nbclust(wine, kmeans, method = "silhouette")

# BEST NUMBER OF CLUSTERS -> 4

# for scaling data -> 4 too
fviz_nbclust(wineScale, kmeans, method = "silhouette")

############# TEST FOR K = 2 ##########################
#alternative execution of kmeans
wine.kmeans2_alt<-eclust(wine, "kmeans", k=2, graph=FALSE)

fviz_silhouette(wine.kmeans2_alt, palette="jco")

res2 = table(wine_raw$quality,wine.kmeans2_alt$cluster)
res2
accuracyCalc(res2,1)

### accuracy -> 0.4487546

############# TEST FOR K = 4 ##########################
#alternative execution of kmeans
wine.kmeans4_alt<-eclust(wine, "kmeans", k=4, graph=FALSE)

fviz_silhouette(wine.kmeans4_alt, palette="jco")

res4 = table(wine_raw$quality,wine.kmeans4_alt$cluster)
res4
accuracyCalc(res4,1)

### accuracy -> 0.4510004

############# TEST FOR K = 6 ##########################
#alternative execution of kmeans
wine.kmeans6_alt<-eclust(wine, "kmeans", k=6, graph=FALSE)

fviz_silhouette(wine.kmeans6_alt, palette="jco")

res6 = table(wine_raw$quality,wine.kmeans6_alt$cluster)
res6
accuracyCalc(res6,1)

### accuracy -> 0.4583503

wine <- read.table("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv", header=TRUE, sep=';')

#### changing nstart parameter to 50
k6 <- kmeans(wine, centers = 6, nstart = 50)

res6_50 = table(wine_raw$quality,k6$cluster)
accuracyCalc(res6_50,1)

### accuracy -> 0.4577379

####################################
# PAM - partitioning around medoids#
####################################

# deciding on the optimal number of clusters
fviz_nbclust(wine, pam, method = "silhouette")+theme_classic()

# division into 2 clusters
pam.res <- pam(wine, 2)
print(pam.res)

#adding information on cluster assignment
wine_clus<-cbind(wine, pam.res$cluster)
head(wine_clus)

#cluster centers
print(pam.res$medoids)

#cluster assignment
pam.res$clustering

#clustering visualization
fviz_cluster(pam.res,
             palette = c("#00AFBB", "#FC4E07"), # color palette
             ellipse.type = "t", # ellipse of concentration
             repel = TRUE, # avoid overlapping (slows down)
             ggtheme = theme_light() #background color
)

wine_raw <- read.table("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv", header=TRUE, sep=';')
wine_raw %>% select(1:11) -> wine_raw
#df <- na.omit(df_raw)
#df <- na.omit(df)
#df <- scale(df)
#head(df)

#alternative execution of kmeans
#df.kmeans6_alt<-eclust(df, "kmeans", k=6, graph=FALSE)
#fviz_silhouette(df.kmeans6_alt, palette="jco")

#res6 = table(wine_raw$quality,df.kmeans6_alt$cluster)
#res6
#accuracyCalc(res6,1)

##### dbscan algorithm ##########################

?dbscan
dbscan::kNNdistplot(wine_raw, k=6)
abline(h=13, lty="dashed")

#alg execution
wine.dbscan <- dbscan(wine_raw, eps=13, MinPts=5)

#compare clusters with original class labels
#cluster 0 means noise
table(wine_raw$quality, wine.dbscan$cluster)

wine.dbscan <- dbscan(wine, eps=0.4, MinPts=5)
table(wine_raw$quality, wine.dbscan$cluster)

# plot clusters
plot(wine.dbscan, wine_raw)
plot(wine.dbscan, wine_raw[c(1,2)])

res_dbscan = table(wine_raw$quality,wine.dbscan$cluster)
res_dbscan
accuracyCalc(res_dbscan,1)

#######################################################################3
wine_raw <- read.table("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv", header=TRUE, sep=';')
wine_raw %>% select(1:11) -> wine

cor(wine)
print(cor(wine))

wine_scale <- scale(wine[-1])
wine_scale

head(wine_scale,3)

library(cluster)
library(factoextra)

# determination the optimal number of clusters
fviz_nbclust(wine_scale,kmeans,method= 'wss',) + geom_vline(xintercept=3,linetype=5,col='darkred')

# extracting results
k.means <- kmeans(wine_scale, 3, nstart=20)
k.means

# Centroids
k.means$size

#visualization
clusplot(wine_scale, k.means$cluster, main='2D representation of the Cluster', color=TRUE, shade=TRUE, labels=,lines=0)

fviz_cluster(object=k.means, #kmeans object
            data=wine_scale, # data used for clustering
            ellipse.type="norm",
            geom="point",
            palette="jco",
            main="",
            ggtheme= theme_minimal())

res_dbscan = table(wine_raw$quality,k.means$cluster)
res_dbscan
accuracyCalc(res_dbscan,1)

# accuracy 0.455492


#!/usr/bin/env Rscript

# Author  : Bhishan Poudel
# Date    : Feb 11, 2016
# Program :

# Setting working directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

# Start device driver to save output
#postscript( file = "asteroid.eps", height = 12, width = 8)

# Data plots and summaries for asteroid densities
asteroids <- read.table("asteroid_dens.dat", header = T)
astnames <-
    asteroids[, 1]
dens <- asteroids[, 2]
err <- asteroids[, 3]
dotchart(dens,
         labels = astnames,
         cex = 0.9,
         xlab = expression(Density ~ (g / cm ^ 3)))
plot(
    dens,
    ylim = c(0, 8),
    xlab = "Asteroids",
    ylab = expression(Density ~ (g / cm ^ 3)),
    pch = 20
)
num <- seq(1, length(dens))
segments(num, dens + err, num, dens - err)
# Boxplot and summary statistics for asteroid data
boxplot(
    asteroids[, 2:3],
    varwidth = T,
    notch = T,
    xlab = 'Asteroids',
    ylab = 'Density',
    pars = list(
        boxwex = 0.3,
        boxlwd = 1.5,
        whisklwd = 1.5,
        staplelwd = 1.5,
        outlwd = 1.5,
        font = 2
    )
)
summary(dens)
mean(dens)
sd(dens)
median(dens)
mad(dens)
weighted.mean(dens, 1 / err ^ 2)

# Tests for normality
shapiro.test(dens)
#install.packages('nortest')
library('nortest')
ad.test(dens)
cvm.test(dens)
lillie.test(dens)
pearson.test(dens)

#install.packages('outliers')
library('outliers')
dixon.test(dens)
chisq.out.test(dens)
grubbs.test(dens)
grubbs.test(dens, type = 20)

# Turn off device driver
#dev.off()


#' Iterator of numeric sequence with initial value and step size
#'
#' Constructs an iterator that generates a sequence of evenly spaced values
#' starting with \code{icount}. The step size is given by \code{step}. By
#' default, the sequence is neverending unless the optional \code{stop} is
#' provided.
#'
#' NOTE: Use a negative \code{step} size to generate decreasing sequences.
#'
#' Often used as an argument to \code{\link[itertools2]{imap}} to
#' generate consecutive data points.
#'
#' @export
#' @param start sequence's initial value
#' @param step sequence's step size
#' @param stop optional stopping point to sequence
#' @return sequence's iterator
#'
#' @examples
#' it <- icount()
#' iterators::nextElem(it)
#' iterators::nextElem(it)
#' iterators::nextElem(it)
#'
#' it2 <- icount(start=5.5, step=1.5)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#'
#' it3 <- icount(start=1, stop=3)
#' iterators::nextElem(it3)
#' iterators::nextElem(it3)
#' iterators::nextElem(it3)
#'
icount <- function(start=0, step=1, stop=NULL) {
  start <- as.numeric(start)
  step <- as.numeric(step)

  if (length(start) != 1) {
    stop("'start' must be a numeric value of length 1")
  }
  if (length(step) != 1) {
    stop("'step' must be a numeric value of length 1")
  }

  if (!is.null(stop)) {
    stop <- as.numeric(stop)
    if (length(stop) != 1) {
      stop("'stop' must be a numeric value of length 1")
    }
  }

  current_val <- start - step
  nextElem <- function() {
    current_val <<- current_val + step

    if (!is.null(stop) && current_val > stop) {
      stop("StopIteration", call.=FALSE)
    }

    current_val
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


# The algorithm is written in R. The lines starting with or followed by "#" are comments for functions, command lines, or delimiters of separate functions.
###### Load packages
###### Author: Qingyuan Yang and Marcus Bursik
###### License: GPL. Use at your own risk.
###### Requires: to run the examples, the appropriate CSV files are needed.
library(gstat)
library(sp)
library(rgdal)
library(RandomFields)
library(maptools)
library(raster)
library(deldir)
library(ggplot2)
library(segmented)
library(poweRlaw)
library(segmented)
library(geoR)
library(combinat)

###### Workflow #########################################################################################################################################
######(1) Calculate the distances, downwind distances of sample sites with respect to the input       <------ function "prep"				######
######    source vent location and wind direction.	 															######
######																								######
######(2) Apply segmented/simple linear regression to the datasets: the log-thickness is the linear   <------ function "sample.reg"			######
######    combination of distance and downwind distance plus a constant.													######
######																								######
######(3) Record the fitted values and residuals from the fitting in step (2)                         <------ implemented by command lines		######
######																								######
######(4) Form a grid for mapping of the trend and the final result		            		          <------ function "form.grid"			######
######																								######
######(5) Form the trend model 											                              <------ function "prep2" and "trendmodel"	######
######																								######
######(6) Form and fit the variogram function of the residuals recorded in step (3)	                  <------ function "var.read"			######
######																								######
######(7) Implemnt ordinary kriging using the residuals in step (3) and the variogram models          <------ function "prediction"			######
######    from step (6) to form the local thickness variation. We take the sum of 			                    							######
######    the trend model in step (5) and the local variation to form the final thickness distribution								######
######																								######
###### End of workflow ##################################################################################################################################

###### Functions ########################################################################################################################################
prep <- function(sv, td, ang){

### See step (1) in the workflow above
### Input variables: 									  ### Data type			  ### Column naes
###		sv: the source vent location							dataframe				"x" and "y"
###		td: the tephra thickness dataset						dataframe				"x", "y", "rz" (real thickness), "z"(log-transformed thickness)
###		ang: the inferred wind direction (from north clockwise)		a single value			     	   -

### Intermediate variables:
###		pts: the coordinates of sample sites
###		nr: the number of observations
###		sv.mtx: the matrix prepared for the computation of distance and downwind distance
###		disp.mtx: the unit vector pointing along the wind direction for the computation of downwind distance
###		dist, dd, cd: computed distances, downwind distances, and crosswind distances from the sample sites to
###		the source vent with the inferred wind direction

### Output:
###		The output is a dataframe that contains the original thickness dataset and the calculated distances, downwind
###		distances, and the crosswind distances of the sample sites.

### Method:
###		This function uses a simple dot product to calculate the downwind distance

	pts <- as.matrix(td[,c(1,2)])									### Extract the coordinates of sample sites
	sv <- as.matrix(sv)
	nr <- nrow(pts)

	sv.mtx <- matrix(ncol=2, nrow=nr)								### Repeated rows of the coordinates of the source vent
	sv.mtx[,1] <- rep(sv[1], nr)
	sv.mtx[,2] <- rep(sv[2], nr)

	disp.mtx <- c(sin(ang*pi/180),cos(ang*pi/180))						### Form the unit vector pointing to the wind direction

	pts.mtx <- pts-sv.mtx										### Calculate the distances, downwind distances, and crosswind distances
	pts.sq <- (pts.mtx)^2										### of the sample sites
	dist<- (pts.sq[,1]+pts.sq[,2])^0.5
	dd <- pts.mtx %*% disp.mtx
	cd <-(dist^2-dd^2)^0.5

	output <- as.data.frame(cbind(pts, dist, dd, cd, td[, c(3,4)]))			### Reorganize the data for output
	colnames(output) <- c("x", "y", "dist", "dd", "cd", "rz", "z")

	return(output)
}

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

prep2 <- function(sv, td, ang){

### This function is written for the computation of the trend model, which requires distances and
### downwind distances of all the cells within the region of interest. Therefore this function works
### exactly the same way as function "prep", except that the trend thicknesses of these cells are to
### be computed. This function is called in the function "trendmodel" for further calculation of trend thickness.

### Input variables: 									  ### Data type			  ### Column names
###		sv: the source vent location			     				dataframe				"x" and "y"
###		td: the coordinates of the cells of the grid				dataframe or matrix		does not matter, as they are transfered into matrix in this function
###		ang: the inferred wind direction (from north clockwise)		a single value			     -

### Output variables:
### 		The output is a dataframe that records the coordinates, distances, downwind distances, and crosswind distances
###		of the cells of the grid.

	pts <- as.matrix(td[,c(1,2)])
	sv <- as.matrix(sv)
	nr <- nrow(pts)

	sv.mtx <- matrix(ncol=2, nrow=nr)
	sv.mtx[,1] <- rep(sv[1], nr)
	sv.mtx[,2] <- rep(sv[2], nr)
	disp.mtx <- c(sin(ang*pi/180),cos(ang*pi/180))

	pts.mtx <- pts-sv.mtx
	pts.sq <- (pts.mtx)^2
	dist<- (pts.sq[,1]+pts.sq[,2])^0.5
	dd <- pts.mtx %*% disp.mtx
	cd <-(dist^2-dd^2)^0.5

	output <- as.data.frame(cbind(pts, dist, dd, cd))
	colnames(output) <- c("x", "y", "dist", "dd", "cd")

	return(output)
}

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

sample.reg <- function(td, segdist, segdd){

### See step (2) of the workflow above
### This function provides two alternative fitting schemes for the fitting of thickness with distance and downwind distance:
### 	(1) Use linear regression with the "segmented" fitting function to simulate
###	    the different decay rates of tephra thickness within and outside the plume corner.

###	(2) Use simple linear regression for the fitting.

###	This method will tend to use the segmented fitting option as it is better reconciled with the physics of tephra settling.
###   If error occurs, meaning that the data are inappropriate for option(1), a "tryCatch" function is set up to switch to
###	option(2).

###	Input variables:
###		td: the output from function "prep"
###		segdist: the inferred breakpoint for distance, this can be estimated by plotting the thickness against distance of the observations.
###		segdd: the inferred breakpoint for downwind distance.

### 	Intermediate functions:
###		segfit: segmented fitting function
###		simplefit: simple linear regression

### 	Output variables:
###		An object that can be regarded as the fitted model. It contains the fitted values, residuals and the
###		coefficients of the fitting. It can be used to predict the trend thickness for the grid and also store the residuals
###		for ordinary kriging.

###	*** NOTES ***
###		The segemented fitting runs iterative processes. Sometimes even with the same "segdist" and "segdd" inputs, it still
###		comes up with different breakpoints and consequently slightly different coefficients. Most of the time, such variation
###		in the models is negligible, but we still suggest users to be careful when dealing with the segmented fitting.
###		The goodness of fit can be examined by printing or plotting the residuals, which are stored in the output.
### 		If option (1) is being used, the output also contains the values of the breakpoints for the two variables.

	segfit <-function(segdist, segdd){															### Segmented fitting function
		reg.mod <- lm(z~ dist + dd,data=td)
			seg.lmmodel <- segmented(reg.mod, seg.Z = ~dist + dd, psi = list(dist = c(segdist), dd = c(segdd)))
      	return(seg.lmmodel)
	}

	simplefit <-function(){																	### Simple linear regression function
		reg.mod <- lm(z ~ dist + dd ,data=td)
      	return(reg.mod)
	}

	result = tryCatch(segfit(segdist, segdd),error=function(e){simplefit()})									### TryCatch structure to automatically switch to simple linear regression

  return(result)																			### when error occurs
  }

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

form.grid <- function(td, cellsize, displacement.coef, expanding.coef){
### See step (4) in the workflow above
### This function first finds the bounding box of the sample sites. It can be used as the extent of the grid.
### However, sometimes one needs a larger extent. To do that, "displacement.coef" and "expanding.coef" are set.
### "displacement.coef" determines if the lowerleft corner of the bounding box should be further shifted to
### the lower left. "expanding.coef" determines if the length and width of the bouding box should be expanded.
### These two values are all ratios. For example, for a 500*500 squared bounding box, if the 'displacement.coef"
### is set to be 1, then the lowerleft corner (if it was 0,0), will be moved to -500, -500. If the "expanding.coef"
### is set to be 2, then the size of the new bounding box will be 1000*1000.

### Input variables:
### td: the output from function "prep"
### cellsize: cellsize (a single value, as they are squared cells)
### displacement.coef: explained above (a single value)
### expanding.coef: explained above (a single value)

### Output variables:
### An empty grid

  td.sp <- SpatialPoints(cbind(td$x, td$y))
  bbox <- bbox(td.sp)
  cs <- c(cellsize, cellsize)
  cc <- as.numeric(ceiling(bbox[,1] + (cs / 2) - diff(t(bbox)) * displacement.coef))
  cd <- ceiling(diff(t(bbox)) / cs) * expanding.coef
  td.temp.grid <- GridTopology(cellcentre.offset = cc, cellsize = cs, cells.dim = cd)
  td.grid <- SpatialGrid(td.temp.grid)
  return(td.grid)
}

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

trendmodel <- function(td, sv, grid, ang, ftng.rslt){
### See step (5) in the workflow above
### This function calculates the distances, downwind distances of the cells of the grid, and makes the
### prediction of trend thickness using the model from function "sample.reg".

### Input variables:
###		td: the output from function "prep"
###		sv: the source vent coordinate
###		grid: the output from function "form.grid"
###		ang: the inferred wind direction (from north clockwise)
###		ftng.rslt: the output from function "sample.reg"

### Output variables:
### A dataframe that contains the coordinates, distances, downwind and crosswind distances, trend thicknesses and
### trend thicknesses in logarithm form for all the cells within the grid.

	td.grid <- SpatialPoints(as(grid, "SpatialPixels"))
	td.grid.coord <- coordinates(td.grid)

		grided<- prep2(sv, td.grid.coord, ang)

		gridz <- predict(ftng.rslt, data.frame(cbind(dist = grided$dist, dd = grided$dd)))
		gridrz <- 10^gridz

	output <- as.data.frame(cbind(grided, gridrz, gridz))
	colnames(output) <- c("x", "y", "dist", "dd", "cd", "zr", "z")

	return(output)
}

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

var.read <- function(td, width.val, cutoff.val, var.par, var.model){
### This function reads the locations of the sample sites and the residuals from the fitting in function "sample.reg" to
### form and fit a variogram model. This function serves as a preparation for ordinary kriging.

### Input variables:
###		td: the output from function "prep"
###		width.val & cutoff.val: the parameters to calculate the experimental variogram. "width.val" denotes the
###		averaged lag for the computation, and "cutoff.val" is the maximum lag that is taken into consideration for the
###		calculation.
###		var.par: the parameters required for fitting variogram models. It includes three values, namely sill, range, and nugget.
###		Detailed explanations of these parameters can be found in any geostatistics reference.
###		var.model: a text variable which describes the shape of different variogram models, type the command line "show.vgms()" to view a list
###		of variogram models.

### Output variables:
###		The output is a list, the first object of the list is the variogram model, which is the main output.
###		The second object is the plot of the experimental variogram and the fitted variogram curve.
###		The third  object is the values of the experimental variogram

  td.sp <- SpatialPointsDataFrame(cbind(td$x, td$y), td)
  td.var <- variogram(res ~ 1, td.sp, width=width.val, cutoff = cutoff.val)

  td.vgm <- vgm(psill=var.par[1], model=var.model, range=var.par[2], nugget=var.par[3])
  td.fit <- fit.variogram(td.var, td.vgm, fit.sills = c(TRUE, TRUE))
  return(list(td.fit,plot(td.var,td.fit),td.var))
}

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

prediction <- function(td, max, min, maxdist, grid, trend, variog){
### This function first implements ordinary kriging on the residuals to construct the local variation map, and then
### takes the sum of trend and local variation to present the final result.

### Input variables:
###		td: the output from function "prep"
###		max:
###		min:
###		maxdist:
###			The "max" and "min" variables describe the maximum and minimum number of observations taken into account
###			for the kriging estimation at a single cell. "maxdist" is used to define a maximum radius beyond which the
###			sample sites are assumed non-related to a particular cell.
###		grid: the output from function "form.grid"
###		trend: the output from function "trendmodel"
###		variog: the first object of the output from function "var.read"

### Output variables:
###		The output is a dataframe that contains the columns of the output of function "trendmodel". In addition to that,
###		it also has the predicted thickness and its logarithm, and the variance of kriging estimation.
###		Here the variance only represents the variance from kriging the log-residuals of the observations and thus cannot
###		be used to characterize the total variance of this method.

	td.sp <- SpatialPointsDataFrame(cbind(td$x, td$y), td)
	td.temp.k <- krige(res ~ 1, td.sp, nmax = max, nmin = min, maxdist = maxdist, grid, variog)
	k.result <- td.temp.k$var1.pred
	k.result[is.na(k.result)] <- 0
	k.variance <- td.temp.k$var1.var
	k.rz <- 10^(k.result + trend$z)

	output <- cbind(trend, k.result, k.variance, k.rz)

return(output)
}

###### End of functions ####################################################################################################

###### Demo ################################################################################################################

setwd("C:\\Users\\working directory")										### Set working directory, "\" has to be replaced by "\\".  Change to "/" for *nix, mac.
td <- read.table("thickness dataset.csv", header=TRUE, sep=",")						### Read the thickness dataset
sv <- read.table("source vent.csv", header=TRUE, sep=",")							### Read source vent location

td <- prep(sv, td, 20)													### Calculate the distances, downwind distances, and crosswind distances of the sample sites,
																### here the wind direction is 20 degree from north clockwise.

model <- sample.reg(td, 3000,3000)											### Form either the segmented or the simple linear regression model of thickness against
																### distance and downwind distance. The breakpoints for the two variables are set as
																### 3000 and 3000 meters.

td$fit <- model$fitted.values												### Expand "td" by storing the fitted values and
td$res <- model$residuals												### residuals from the fitting in the last command line

grid <- form.grid(td, 500, 0.1, 1.2)											### Form the grid.

trend <- trendmodel(td, sv, grid, 20, model)									### Form the trend. Note the wind direction has to be set again for
																### the calculation of grid cells, and the two wind directions have to be the same.

var <- var.read(td, 300,10000, c(0.04,5000,0.01), "Cir")							### Form the variogram model. The parameters are explained in the
																### description of function "var.read"

result <- prediction(td, 50,20, 5000, grid,trend, var[[1]])							### Calculate the local variation, and take its sum and trend thickness for final result.

result.sp <- SpatialPixelsDataFrame(cbind(trend$x, trend$y), result)					### Turn the final result into "SpatialPixelsDataFrame" for visualization.
spplot(result.sp["k.rz"])	or	spplot(result.sp["zr"])							### Plot the final result or the trend model.

levels <- c(0,250,500,1000,2000,3000,5000,10000,20000)								### Set up the levels for plotting the isopach map.
isomap <- ContourLines2SLDF(contourLines(as.image.SpatialGridDataFrame(result.sp["k.rz"]), levels = levels))
																### Form the isopach map

plot(isomap)															### Plot the isopach map
																### Note: "isomap" is a "SpatialLinesDataFrame" and can be used in GIS programs for further mapping purposes.
																### Geo-referencing can be done in R or GIS programs.

																### ***Notes on infer the extent of tephra fall deposits:
																### (1) Add one unit thickness to all the observations and log-transform them.
																### (2) Apply these transformed log-thickness to the method
																### (3) Specify the "levels <- c(1)" and apply it to "ContourLines2SLDF" function to find the unit thickness isopach
																### (4) The resultant contour is the inferred extent.
																### ***
																### The resultant contour is strongly influenced by the trend model,
																### as normally fewer observations are made on the distal and thin parts of a tephra fall deposit

###### End of demo ##########################################################################################################


# Visualization of Multivariate Data
# install.packages("HSAUR2")
library("HSAUR2")
data("USairpollution")
X=as.matrix(USairpollution)

var.names=names(USairpollution)
city.names=abbreviate(row.names(USairpollution),4)
# if it is a matrix, use rownames(X)

# (1) scatter plot

# 2-d scatter plot
win.graph() # X11() in mac
attach(USairpollution)
plot(popul, SO2, xlab="popul", ylab="SO2", col="brown")

# label the scatter by unit names.
win.graph()
plot(popul, SO2, xlab="popul", ylab="SO2", type="n")
text(popul,SO2, labels=row.names(USairpollution),cex=0.6)
rug(popul, side=1, col="red")
rug(SO2, side=2, col="green")

# (2) box plot
boxplot(USairpollution)
boxplot(USairpollution[,1:2])
boxplot(USairpollution[,3:4])

# bivariate boxplot
# install.packages("MVA")
library("MVA")
win.graph()
bvbox(USairpollution[,c(4,1)], xlab="popul",ylab="SO2",main="Bivariate Boxplot")
lab=c("Chicago","Providence","Philadelphia","Detroit")
outcity=match(lab, rownames(USairpollution))
text(X[outcity, 4], X[outcity,1], labels=lab, cex=0.7)

# chi-plot is used to test independence of two variables
win.graph()
chiplot(popul,SO2)

# bubble plot
win.graph()
plot(popul, SO2, xlab="popul", ylab="SO2",type="n",main="bubbles: temp")
symbols(popul, SO2, circles=temp,inches=0.2, add=TRUE)

# star plot
win.graph()
palette(rainbow(20,s=0.7,v=0.9))
stars(USairpollution, len=0.8, cex=0.55, key.loc=c(15,1.6),
      main="star plot", draw.segments=TRUE)

# pairwise scatter plot
win.graph()
pairs(USairpollution, pch=".",cex=2)

#
win.graph()
panel.hist <- function(x, ...)
     {
         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, col="cyan", ...)
     }
panel.reg<-function(x,y,...)
    {
         points(x, y) #pch=".",cex=1.5)
         abline(lm(y ~ x,...), col = "red")
    }
pairs(USairpollution, panel=panel.reg, cex.labels=1, font.labels=1, diag.panel=panel.hist)

# 3-d scatter plot
library("scatterplot3d")
win.graph()
scatterplot3d(temp,wind, SO2, type="h", angle=55)

# trellis graphics
plot(xyplot(SO2 ~temp| cut(wind,2)))

# statlactite plot
stalac(USairpollution)


# Selection of matrix elements
# my_matrix[1,2]: selects the element at the first row and second column.
# my_matrix[1:3,2:4]: results in a matrix with the data on the rows 1, 2, 3 and columns 2, 3, 4.
# my_matrix[,1]: selects all elements of the first column.
# my_matrix[1,]: selects all elements of the first row.

# all_wars_matrix is available in your workspace
all_wars_matrix

# Select the non-US revenue for all movies
non_us_all <- all_wars_matrix[,2]

# Average non-US revenue
mean(non_us_all)

# Select the non-US revenue for first two movies
non_us_some <- all_wars_matrix[1:2, 2]

# Average non-US revenue for first two movies
mean(non_us_some)


# 1 Vector
# create
x <- vector("character", 10)

x1 <- 1:4

x2 <- c(1,2,3,4)

x3 <- c(TRUE, 10, "a") # R will transfer

# type transfer
x4 <- c("a", "b", "c")
as.numeric(x2)
as.logical(x4)
as.character(x4)

# give vector's variable name
names(x1) <- c("a", "b", "c", "d")
print(x1)

# 2 matrix and array
# create
x <- matrix(1:6, nrow = 3, ncol = 2)
print(x)

# see dim attribute
dim(x)
# see attribute of a variable
attributes(x)

# create a matrix by add dim attribute
y <- 1:6
print(y)
dim(y) <- c(2,3)
print(y)

# matrix splicing
y2 <- matrix(1:6, nrow = 2, ncol = 3)
rbind(y,y2)
cbind(y,y2)

# array:
x <- array(1:24, dim = c(4,6))
print(x)

x2 <- array(1:24, dim = c(2,3,4))
print(x2)

# 3 list: type could be different
l <- list("a", 2, 10L, 2+4i, TRUE)
# create list with name
l2 <- list(a=1, b=2, c=3)
# creare list with list
l3 <- list(c(1,2,3), c(4,5,6))
print(l3)

x <- matrix(1:6, nrow = 2, ncol = 3)
print(x)
dimnames(x) <- list(c("a","b"), c("c","d", "e"))
print(x)

# 3 factor


x_values <- c(9,11,15)

y_values <- c(-15,-8,2,8)

prxs <- c(0.38, 0.29, 0.33)

prys <- c()

prCongiunta <- c()

pry_x <- c(0.25, 0.30, 0.20, 0.25,
           0.22, 0.27, 0.25, 0.26,
           0.20, 0.30, 0.23, 0.27)

matrixy_x <- matrix(data = pry_x, ncol = length(y_values), nrow = length(x_values), byrow = TRUE);

valoreAttesoX <- 0

for( i in 1:length(x_values) ){

  valoreAttesoX <- valoreAttesoX + prxs[i] * x_values[i];

}

varianzaX <- 0

for( i in 1:length(x_values) ){

  varianzaX <- varianzaX + prxs[i] * (x_values[i] - valoreAttesoX)^2;

}

for( i in 1:length(x_values) ){

  for( j in 1:length(y_values) ){

    prCongiunta <- c(prCongiunta, matrixy_x[i,j] * prxs[i]);

  }

}

matrixCongiunta <- matrix(data = prCongiunta, nrow = length(x_values), ncol = length(y_values), byrow = TRUE);

for( i in 1:length(y_values) ){

  prys <- c(prys, sum(matrixCongiunta[,i]));

}

prx_y <- c()

for( i in 1:length(x_values)){

  for( j in 1:length(y_values)){
    prx_y <- c(prx_y, matrixCongiunta[i,j] / prys[j] )
  }

}

matrixx_y <- matrix(data=prx_y, nrow = length(x_values), ncol = length(y_values), byrow = TRUE);

valoreAttesoX_Y <- c();

for( j in 1:length(y_values) ){

  somma <- 0
  for( i in 1:length(x_values) ){

    somma <- somma + x_values[i] * matrixx_y[i,j];

  }

  valoreAttesoX_Y <- c(valoreAttesoX_Y, somma);

}

varianzaValoreAttesoX_Y <- 0

for( j in 1:length(y_values) ){

  varianzaValoreAttesoX_Y <- varianzaValoreAttesoX_Y + (valoreAttesoX_Y[j] - valoreAttesoX)^2 * prys[j];

}

valoreAttesoVarianzaX_Y <- varianzaX - varianzaValoreAttesoX_Y;

cat("X\n")
print(matrix(data=c(x_values,prxs), ncol = length(x_values), byrow = TRUE))

cat("\nY\n")
print(matrix(data=c(y_values,prys), ncol = length(y_values), byrow = TRUE))

cat("\nProbabilita congiunta\n")
print(matrixCongiunta)

cat("\nX|Y\n")
print(matrixx_y)

cat("\nY|x\n")
print(matrixy_x)

cat("\nRisposte\n")
print(valoreAttesoX);
print(varianzaX)
print(varianzaValoreAttesoX_Y)
print(valoreAttesoVarianzaX_Y)


# Outer code, set initialization parameters and loop lengths

library ('rjags')
#setwd("D:/Users/David/Dropbox/Other/Schoolwork/Machine Learning/part 2")

# True values underlying the data generation
core_mu <- 4
core_sigma <- 0.4
core_lambda <- 10
num_data <- 400

# Convert Sigma to Tau
core_tau <- core_sigma^(-2)

# Generate the data to analyze
# Essentially: z = (rpois + 1) ^ rnorm
x <- rnorm(num_data, mean = core_mu, sd = core_sigma)
y <- rpois(num_data, core_lambda) + 1
z <- y ^ x

# ** Prior Distribution Parameters **
#   Notes:
#    tau = 1/(sigma ^ 2)
#    gamma mean = r/lambda
#    gamma var = r/(lambda^2) = (gamma mean)/lambda
#   So uninformative priors have tau, r, and lambda all relatively low.
#   I do not recommend r less than 0.05, as it approaches the limit of floating-point precision.
mu_mu <- 4 # Initial mean for normal estimator for mu
mu_tau <- 0.3 # Initial tau for normal estimator for mu, lower is less precise
tau_r <- 0.1 # Initial shape of Gamma estimator for tau
tau_glambda <- 0.08 # Initial rate (lambda) of Gamma estimator for tau
poi_r <- 0.1 # Initial shape of Gamma estimator for lambda
poi_glambda <- 0.02 # Initial rate (lambda) of Gamma estimator for lambda

# Gibbs sampling variables
num_samples <- 1000 # Number of Gibbs samples
burn_cycles <- 1000 # Number of cycles to ignore, as it "burns in" to the limiting distribution
num_adapt <- 1000 # Length of adaptation step, which theoretically improves performance
num_thin <- 10 # Thinning size, i.e. how many iterations to wait per sample, for independence

# Load gibbs sampling code
source("mcmc_analyzer.r")

# Execute sampling and get results
var_samples <- poiss_norm_analysis (z, mu_mu, mu_tau, tau_r, tau_glambda, poi_r, poi_glambda,
									                  num_samples, burn_cycles, num_adapt, num_thin)

# Unpack the results into vectors
norm_mus <-unlist(var_samples[1], use.names=FALSE)
norm_taus <- unlist(var_samples[2], use.names=FALSE)
pois_lams <- unlist(var_samples[3], use.names=FALSE)
norm_sigmas <- vector(mode='numeric',length(norm_taus))
for (i in 1:length(norm_taus))
{
	norm_sigmas[i] = 1/sqrt(norm_taus[i])
}

# Graph the results
plot(pois_lams, norm_mus, xlab='Poisson Lambda estimates',
     ylab='Normal Mu estimates',main='Posterior Pairs for underlying values')

# Median is much more accurate as a point estimate than the mean due to curvature
# The Mode is possible to deduce, but tricky
median_mu <- median(norm_mus) # Final median mu estimate
median_sigma <- median(norm_sigmas) # Final median SD estimate
median_tau <- median(norm_taus) # Final median tau estimate
median_lambda <- median(pois_lams) # Final median lambda estimate

# Differences between original and median estimate mu/sigma/lambda
diff_mu <- median_mu - core_mu
diff_sigma <- median_sigma - core_sigma
diff_lambda <- median_lambda - core_lambda
diff <- list(diff_mu,diff_sigma,diff_lambda)

# Percentage difference between estimates and underlying values
# (Note that because the data is randomly generated, and the estimates are based
#   on the data, even perfect induction results in error)
perc_diff <- list(diff_mu/core_mu, diff_sigma/core_sigma, diff_lambda/core_lambda)

# This repeats the procedure done in poiss_norm_analysis so it shows up in environment overlay/can be queried
# "ones_i" will be the number of ones, z2_i the number of non-ones
ones_i = 0
ones = list()
z2_i = 0
z2 = list()
for (i in 1:length(z))
{
  if (z[i] == 1)
  {
    ones_i = ones_i + 1
    ones[ones_i] = 0
  } else {
    z2_i = z2_i + 1
    z2[z2_i] = z[i]
  }
}


shannon.h<-function(data){
  H<-numeric(nrow(data))
  mult<-numeric(length(data[1,]))

  for(i in 1:nrow(data)){
    prop<-data[i,]/sum(data[i,])

    for(j in 1:ncol(data)){
      mult[j]<-prop[j]*log(prop[j])
    }

    H[i]<- -sum(mult, na.rm=T)
  }
  plot.number<-1:nrow(data)
  return(rbind(plot.number,H))
}
####


=begin
  # sample-m-factorize02.rb

  require "algebra"

  Z7 = ResidueClassRing(Integer, 7)
  P = MPolynomial(Z7)
  x, y, z = P.vars("xyz")
  f = x**3 + y**3 + z**3 - 3*x*y*z
  p f.factorize #=> (x + 4y + 2z)(x + 2y + 4z)(x + y + z)
((<_|CONTENTS>))
=end


library(sgd)
N <- 10000
d <- 10
set.seed(42)
X <- matrix(rnorm(N*d), ncol=d)
theta <- rep(5, d+1)
eps <- rnorm(N)
y <- cbind(1, X) %*% theta + eps
dat <- data.frame(y=y, x=X)
sgd.theta <- sgd(y ~ ., data=dat, model="lm")
sprintf("Mean squared error: %0.3f", mean((theta - as.numeric(sgd.theta$coefficients))^2))

plot(sgd.theta, theta, type="mse-param")


'

The file "regression_on_indicators.r" computes the regression estimates
of the main indicators (mortality, expropriation risk and GDP) on the
indicators for campaigning soldiers and laborers, as well as
the correlations of the main indicators with log mortality.
The results are then plotted in the corresponding file in
the final folder "table1_reg_on_indicators.r"

'

rm(list=ls())
options(digits=3)

source("project_paths.r")

library(foreign)

source(paste(PATH_IN_MODEL_CODE, "functions.r", sep = "/"))

data <- read.table(
     file=paste(PATH_OUT_DATA, "ajrcomment_all.txt", sep = "/"),
     header = TRUE
)

## We run the regressions here of tabel 1

slave = data[,"slave"]
campaign = data[,"campaign"]
logmort = data[,"logmort0"]
risk = data[,"risk"]
loggdp = data[,"loggdp"]

fmmort = lm(logmort ~ slave + campaign)

fmrisk = lm(risk ~ slave + campaign)

fmgdp = lm(loggdp ~ slave + campaign)

## full correlation
cor_mo_gdp = cor(logmort, loggdp)
cor_mo_ris = cor(logmort, risk)

## partial correlation
cor_mo_gdp_par = cor(fmmort$resid, fmgdp$resid)
cor_mo_ris_par = cor(fmmort$resid, fmrisk$resid)

## write anything into a latex tabel

 mat = c(
           ## first column

               "",
               summary(fmmort)$coefficients["campaign","Estimate"],
               summaryw(fmmort)[[1]]["campaign",2],
               summary(fmmort)$coefficients["slave","Estimate"],
               summaryw(fmmort)[[1]]["slave",2],
               summary(fmmort)$r.squared,
               "",
               "",
               "1.00",
               "1.00",

           ## second column

               "",
               summary(fmrisk)$coefficients["campaign","Estimate"],
               summaryw(fmrisk)[[1]]["campaign",2],
               summary(fmrisk)$coefficients["slave","Estimate"],
               summaryw(fmrisk)[[1]]["slave",2],
               summary(fmrisk)$r.squared,
               "",
               "",
               cor_mo_ris,
               cor_mo_ris_par,

           ## third column

               "",
               summary(fmgdp)$coefficients["campaign","Estimate"],
               summaryw(fmgdp)[[1]]["campaign",2],
               summary(fmgdp)$coefficients["slave","Estimate"],
               summaryw(fmgdp)[[1]]["slave",2],
               summary(fmgdp)$r.squared,
               "",
               "",
               cor_mo_gdp,
               cor_mo_gdp_par
)

## export the vector

dput(
     mat, file=paste(PATH_OUT_ANALYSIS,"/","regression_on_indicators.txt",sep="")
)