library(ggplot2)
library(Rcpp)
library(gridExtra)
library(rstan)
library(reshape2)

set.seed(112358)

printvar <- function(v) {
  	name <- deparse(substitute(v))
  	print(paste(name, ":", v))
}

## External files
##

stocsirfile 	<- paste(getwd(), "../../sir-functions", "StocSIR.r", sep = "/")
stocsirstanfile <- paste(getwd(), "../../sir-functions", "StocSIRstan.r", sep = "/")
if2file 		<- paste(getwd(),"../../if2", "if2.cpp", sep="/")
hmcfile 		<- paste(getwd(), "../../hmc", "sirode_euler.stan", sep="/")
source(stocsirfile)
source(stocsirstanfile)

## Beta process plot
###########################################################################################

T <- 7*60
berr <- 0.5
B <- numeric(T)
B0 <- 3.0 * 0.1 / 500;
B[1] <- B0
eta <- 0.5

for (t in 2:T) {
	B[t] <- exp( log(B[t-1]) + eta*(log(B0) - log(B[t-1])) + rnorm(1,0,berr) )
}

bplot <- qplot(1:T, B, geom = "line", xlab = "Time", ylab = expression(beta)) +
			scale_y_continuous(limits=c(0, 0.002)) +
			theme_bw()

ggsave(bplot, filename = "betaplot.pdf", height = 4, width = 6.5)

bdensity <- qplot(B, geom = "density", xlab = expression(beta), ylab = "frequency") +
				scale_x_continuous(limits=c(0, 0.002)) +
				theme_bw()

ggsave(bdensity, filename = "betadensity.pdf", height = 4, width = 6.5)

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

## print Beta theoretical stats

mu <- log(3*0.1/500)
sigma <- 0.5
mean <- exp(mu + sigma^2/2)
printvar(mean)

var <- sqrt( sigma^2 / (1-(1-eta)^2) )
sd <- sqrt( (exp(var^2) - 1) * exp(2*mu + var^2) )
printvar(sd)

## print Beta computed stats

printvar(mean(B))
printvar(sd(B))

## Model behaviour plot
###########################################################################################

set.seed(1004)

T 		<- 60
i_infec <- 5
steps 	<- 7
N 		<- 500
sigma 	<- 10
Tlim 	<- T

## Generate true trajecory and synthetic data

pars_true <- c(R0 = 3.0, 	# new infected people per infected person
          r = 0.1, 		# recovery rate
		  N = 500, 		# population size
		  eta = 0.5, 	# geometric random walk
		  berr = 0.5) 	# Beta geometric walk noise

true_init_cond <- c(S = N - i_infec,
					I = i_infec,
					R = 0)

sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

datapart <- c(infec_counts[1:(Tlim+1)],rep(NA,T-Tlim))

numtraj <- 100

trajData <- matrix(NA, nrow = numtraj, ncol = (T+1))
for(i in 1:numtraj) {
    sdeout <- StocSIR(true_init_cond, pars_true, T, steps)
    colnames(sdeout) <- c('S','I','R','B')
    trajData[i,] <- sdeout[,'I']
}

meanTraj    <- colMeans(trajData)
avTraj      <- meanTraj
quantTraj   <- t(apply(trajData, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

sirmean <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
		    geom_line(aes(x = 0:T, y = meanTraj), linetype = "dotted") +
		    geom_ribbon(aes(ymin = quantTraj[,'025'], ymax=quantTraj[,'975']), alpha=0.1) +
		    geom_point(aes(y = datapart)) +
		    theme_bw()

ggsave(sirmean, filename = "sirmean.pdf", width = 6.5, height = 4)

## IF2 fit
###########################################################################################

## Setup

NP          <- 2500
nPasses     <- 50
coolrate    <- 0.975

## fit

sourceCpp(if2file)
if2time <- system.time( if2data <- if2(infec_counts[1:(Tlim+1)], Tlim+1, N, NP, nPasses, coolrate) )

## extract

paramdata <- data.frame( if2data$paramdata )
names(paramdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

convergedata <- data.frame( if2data$means )
names(convergedata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

statedata <- data.frame( if2data$statemeans )
names(statedata) <- c("S","I","R")

sdsdata <- data.frame( if2data$sds )
names(sdsdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

## compute stats

if2means <- colMeans(paramdata[c("R0","r","Iinit","sigma","eta","berr")])
names(if2means) <- c("R0","r","I0","sigma","eta","berr")
printvar(if2means)

truevals <- c( pars_true[c("R0","r")], I0 = i_infec, sigma = sigma, pars_true[c("eta","berr")])
relerrs <- (if2means - truevals) / truevals
printvar(relerrs)

## fitted state plot

if2state <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection counts") +
				geom_point(aes(y = infec_counts)) +
				geom_line(aes(y = statedata[,'I']), linetype = "dashed") +
				theme_bw()

ggsave(if2state, filename = "if2state.pdf", width = 6.5, height = 4)

## IF2 Convergence plots
#############################################################################################################

## Parameter values
##

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0converge <- qplot(1:dim(convergedata)[1], convergedata$R0, geom = "line", xlab = "", ylab = expression(R[0])) +
    			geom_hline(aes(yintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rconverge <- qplot(1:dim(convergedata)[1], convergedata$r, geom = "line", xlab = "", ylab = "r") +
    			geom_hline(aes(yintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmaconverge <- qplot(1:dim(convergedata)[1], convergedata$sigma, geom = "line", xlab = "", ylab = expression(sigma)) +
    			geom_hline(aes(yintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infecconverge <- qplot(1:dim(convergedata)[1], convergedata$Iinit, geom = "line", xlab = "", ylab = "Initial Infected") +
    			geom_hline(aes(yintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etaconverge <- qplot(1:dim(convergedata)[1], convergedata$eta, geom = "line", xlab = "", ylab = expression(eta)) +
    			geom_hline(aes(yintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrconverge <- qplot(1:dim(convergedata)[1], convergedata$berr, geom = "line", xlab = "", ylab = expression(epsilon[proc])) +
    			geom_hline(aes(yintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

pdf("if2convergence.pdf", width = 6.5, height = 4)
grid.arrange(R0converge, rconverge, sigmaconverge, infecconverge, etaconverge, berrconverge, ncol = 3, nrow = 2)
dev.off()

## Standard devs
##

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0sds <- qplot(1:dim(sdsdata)[1], sdsdata$R0, geom = "line", xlab = "", ylab = expression(R[0])) +
				theme_bw()

rsds <- qplot(1:dim(sdsdata)[1], sdsdata$r, geom = "line", xlab = "", ylab = "r") +
				theme_bw()

sigmasds <- qplot(1:dim(sdsdata)[1], sdsdata$sigma, geom = "line", xlab = "", ylab = expression(sigma)) +
				theme_bw()

infecsds <- qplot(1:dim(sdsdata)[1], sdsdata$Iinit, geom = "line", xlab = "", ylab = "Initial Infected") +
				theme_bw()

etasds <- qplot(1:dim(sdsdata)[1], sdsdata$eta, geom = "line", xlab = "", ylab = expression(eta)) +
				theme_bw()

berrsds <- qplot(1:dim(sdsdata)[1], sdsdata$berr, geom = "line", xlab = "", ylab = expression(epsilon[proc])) +
				theme_bw()

pdf("if2sdconvergence.pdf", width = 6.5, height = 4)
grid.arrange(R0sds, rsds, sigmasds, infecsds, etasds, berrsds, ncol = 3, nrow = 2)
dev.off()

## IF2 densities

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0kernel <- qplot(paramdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rkernel <- qplot(paramdata$r, geom = "density", xlab = "r", ylab = "") +
    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmakernel <- qplot(paramdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infeckernel <- qplot(paramdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etakernel <- qplot(paramdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrkernel <- qplot(paramdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

# show grid
pdf("if2kernels.pdf", width = 6.5, height = 4)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)
dev.off()

## HMCMC Fitting
#############################################################################################################

datlen <- T*7 + 1

data <- matrix(data = -1, nrow = T+1, ncol = steps)
data[,1] <- infec_counts
standata <- as.vector(t(data))[1:datlen]

sir_data <- list( T = datlen,   	# simulation time
                  y = standata, 	# infection count data
                  N = 500,      	# population size
                  h = 1/steps )   	# step size per day

rstan_options(auto_write = TRUE)

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1)   		# thinning number

#hmcfile <- paste(getwd(), "../../code/hmc", "sirode_euler.stan", sep="/")

hmctime <- system.time(fit <- with(stan_options,
		            	stan(file  	= hmcfile,
				            data    = sir_data,
				            chains  = chains,
				            iter    = iter,
				            warmup  = warmup,
				            thin    = thin)
		        		)
			)

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
               			r = melt(exfit[,,'r'])$value,
               			sigma = melt(exfit[,,'sigma'])$value,
               			eta = melt(exfit[,,'eta'])$value,
               			berr = melt(exfit[,,'berr'])$value,
               			Sinit = melt(exfit[,,'y0[1]'])$value,
               			Iinit = melt(exfit[,,'y0[2]'])$value,
               			Rinit = melt(exfit[,,'y0[3]'])$value )

for (j in 1:datlen) {
	varname <- paste('Bnoise[', j, ']', sep = '')
	paramdata[[varname]] <- melt( exfit[,,varname] )$value
}

## Compute stats

hmcmeans <- colMeans(paramdata[c("R0","r","Iinit","sigma","eta","berr")])
names(hmcmeans) <- c("R0","r","I0","sigma","eta","berr")
printvar(hmcmeans)

truevals <- c( pars_true[c("R0","r")], I0 = i_infec, sigma = sigma, pars_true[c("eta","berr")])
relerrs <- (hmcmeans - truevals) / truevals
printvar(relerrs)

## HMCMC Kernels

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0kernel <- qplot(paramdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rkernel <- qplot(paramdata$r, geom = "density", xlab = "r", ylab = "") +
    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmakernel <- qplot(paramdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infeckernel <- qplot(paramdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etakernel <- qplot(paramdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrkernel <- qplot(paramdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

pdf("hmckernels.pdf", width = 6.5, height = 4)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)
dev.off()

## HMCMC bootstrapping

nTraj <- 100
# sample from parameter distributions

pardatlen 	<- dim(paramdata)[1]
inds 	    <- sample.int(pardatlen,nTraj,replace = TRUE)
params 	    <- paramdata[inds,]

bootstrapdata <- matrix(NA, nrow = nTraj, ncol = T+1)

for (i in 1:nTraj) {

	paramset <- params[i,]

	init_cond <- c(S = paramset$Sinit,
	               I = paramset$Iinit,
	               R = paramset$Rinit)
	pars <- c(R0 = paramset$R0,
	          r = paramset$r,
	          N = 500.0,
	          eta = paramset$eta,
	          berr = paramset$berr)

	berrvec <- numeric(datlen)
	for (j in 1:datlen) {
		varname <- paste("Bnoise[", j, "]", sep = "")
		berrvec[j] <- paramset[[varname]]
	}

	sdeout <- StocSIRstan(init_cond, pars, T, steps, berrvec, datlen)
	colnames(sdeout) <- c('S','I','R','B')

	bootstrapdata[i,] <- sdeout[,'I']

}

# remove NaN rows (why in the hell are these showing up????)
bootstrapdata <- bootstrapdata[complete.cases(bootstrapdata),]

meanTraj 	<- colMeans(bootstrapdata, na.rm = FALSE)
quantTraj 	<- t( apply(bootstrapdata, 2, quantile, probs = c(0.025,0.975), na.rm = FALSE) )

colnames(quantTraj) <- c("025","975")

hmcboot <- qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
			geom_ribbon(aes(ymin = quantTraj[,'025'], ymax=quantTraj[,'975']), alpha=0.1) +
			geom_line(aes(y = meanTraj), linetype = "dashed") +
			geom_point(aes(y = datapart)) +
		    geom_line(aes(y = avTraj), linetype = "dotted") +
			theme_bw()

ggsave(hmcboot, filename = "hmcboot.pdf", width = 6.5, height = 4)

## Multi-fit densities
######################################################################################################

load("sc1-multi-time.RData")

# extract if2 data

if2names <- c("if2.R0","if2.r","if2.sigma","if2.eta","if2.berr","if2.Iinit")
if2data <- estmat[,if2names]
colnames(if2data) <- c("R0","r","sigma","eta","berr","Iinit")
if2times <- estmat[,7]

# extract hmc data

hmcnames <- c("hmc.R0","hmc.r","hmc.sigma","hmc.eta","hmc.berr","hmc.Iinit")
hmcdata <- estmat[,hmcnames]
colnames(hmcdata) <- c("R0","r","sigma","eta","berr","Iinit")
hmctimes <- estmat[,14]

# average times

avif2time <- mean(if2times)
avhmctime <- mean(hmctimes)

# times plot

timedf <- data.frame(if2 = if2times, hmc = hmctimes)
#timedf$variable <- factor(timedf$variable, levels = c("if2", "hmc"), ordered = TRUE)
timedata <- melt(timedf)
timeplot <- ggplot(timedata, aes(factor(variable, ordered = TRUE), value)) +
				geom_boxplot() +
				scale_x_discrete(labels = c("IF2", "HMCMC")  ) +
				labs(x = "", y = "Time (seconds)") +
				coord_flip() +
				theme_bw()

ggsave(timeplot, filename = "timeplot.pdf", width = 6.5, height = 4)

# sort results

printvar(avif2time)
printvar(avhmctime)

if2sorted <- apply(if2data, 2, sort)
hmcsorted <- apply(hmcdata, 2, sort)

## take centre 95%

nTrials <- dim(estmat)[1]

cinds <- (0.025*nTrials+1):(0.975*nTrials)
if295 <- if2sorted[cinds,]
hmc95 <- hmcsorted[cinds,]

if2plotdata <- data.frame(if295)
hmcplotdata <- data.frame(hmc95)

linecolour <- "grey50"
lineweight <- 0.5

## IF2 multi densities

R0kernel <- qplot(if2plotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$R0)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

rkernel <- qplot(if2plotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$r)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(if2plotdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$sigma)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(if2plotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$Iinit)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(if2plotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$eta)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(if2plotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(if2plotdata$berr)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

# show grid
pdf("if2-multi.pdf", width = 6.5, height = 4)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)
dev.off()

## HMCMC multi densities

R0kernel <- qplot(hmcplotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$R0)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

rkernel <- qplot(hmcplotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$r)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(hmcplotdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$sigma)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(hmcplotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$Iinit)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(hmcplotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$eta)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(hmcplotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    geom_vline(aes(xintercept=median(hmcplotdata$berr)), linetype="dashed", size=lineweight, color=linecolour) +
    theme_bw()

# show grid
pdf("hmc-multi.pdf", width = 6.5, height = 4)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)
dev.off()

## Combined plots

R0kernel <- qplot(if2plotdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    geom_density(aes(x = hmcplotdata$R0), color = "grey") +
    geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight) +
    theme_bw()

rkernel <- qplot(if2plotdata$r, geom = "density", xlab = "r", ylab = "") +
    geom_density(aes(x = hmcplotdata$r), color = "grey") +
    geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

sigmakernel <- qplot(if2plotdata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
    geom_density(aes(x = hmcplotdata$sigma), color = "grey") +
    geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

infeckernel <- qplot(if2plotdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    geom_density(aes(x = hmcplotdata$Iinit), color = "grey") +
    geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

etakernel <- qplot(if2plotdata$eta, geom = "density", xlab = expression(eta), ylab = "") +
    geom_density(aes(x = hmcplotdata$eta), color = "grey") +
    geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

berrkernel <- qplot(if2plotdata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
    geom_density(aes(x = hmcplotdata$berr), color = "grey") +
    geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    theme_bw()

pdf("combined-multi.pdf", width = 6.5, height = 4)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel, ncol = 3, nrow = 2)
dev.off()


next.perm <- function(p) {
	n <- length(p)
	i <- n - 1
	r = TRUE
	for(i in (n-1):1) {
		if(p[i] < p[i+1]) {
			r = FALSE
			break
		}
	}

	j <- i + 1
	k <- n
	while(j < k) {
		x <- p[j]
		p[j] <- p[k]
		p[k] <- x
		j <- j + 1
		k <- k - 1
	}

	if(r) return(NULL)

	j <- n
	while(p[j] > p[i]) j <- j - 1
	j <- j + 1

	x <- p[i]
	p[i] <- p[j]
	p[j] <- x
	return(p)
}

print.perms <- function(n) {
	p <- 1:n
	while(!is.null(p)) {
		cat(p,"\n")
		p <- next.perm(p)
	}
}

print.perms(3)
# 1 2 3
# 1 3 2
# 2 1 3
# 2 3 1
# 3 1 2
# 3 2 1


#' @title plot3AgeComparisons
#' @description plot triplets of age readings on a hexagon to compare 3 age readers or to compare 3 aging methods
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
plot3AgeComparisons = function(triplets,color="grey60",offset=.20){

# triplets is a matrix with number of rows equal to number of fish aged, and 3 columns.
# Each column contains the age readings obtained from one reader (or one aging method).
# The object is to compare the columns to see how the readers may differ.

# color sets the darkness of the grid of reference points. What you see on the screen may differ from
# what your printer gives you.

# offset determines how close to the reference point the number of observations is printed.

# makes use of the function regpolygon()

# This function will implement the graphing procedure described by Evans,
# G.T. and J.M. Hoenig.  1998.  Viewing and Testing Symmetry in Contingency
# Tables, with Application to Fish Ages.  Biometrics 54:620-629.

# Programmed by J. Hoenig, Virginia Institute of Marine Science, hoenig@vims.edu

# First, test if the matrix triplets is numeric.

 if(!is.numeric(triplets)) {return("matrix is not numeric")}

# determine if there are NAs and, if so, eliminate them and alert the user.

test = complete.cases(triplets)
warn = sum(!test)
if (warn > 0) cat("warning: there are ",warn," records with missing values")
triplets = triplets[test,]

# now, subtract the lowest value in each row of triplets from each entry in the row

rowmins = apply(triplets,1,min)
triplets = triplets - rowmins
maxdif = max(triplets)

# draw a regular hexagon

 hexagon = regpolygon(lenside=maxdif)
 xvalues = hexagon$x
 yvalues = hexagon$y

 par(fin=c(5,5.62))

 plot(xvalues,yvalues,ylab="",xlab="",type="l",xlim=c(-maxdif,maxdif),
    ylim=c(-maxdif,maxdif),xaxt="n",yaxt="n")

# now add radii
  for (i in 1:6) {
    lines(x=c(0,xvalues[i]),y=c(0,yvalues[i]))
  }

# now add a grid of plotting nodes
x = matrix(NA,nrow=2*maxdif+1,ncol=2*maxdif+1)
y = matrix(NA,nrow=2*maxdif+1,ncol=2*maxdif+1)

for (i in 1:(2*maxdif+1)){
  for (j in 1:(maxdif+1)) {
    x[i,j] = i-maxdif-1-(j-1)*cos(pi/3)
    y[i,j] = (j-1)*sin(pi/3)
  }
}

for (i in 1:maxdif){
  for (j in (i+1):(maxdif+1)) {
    x[i,j] = NA
    y[i,j] = NA
  }
}

for (i in 1:(2*maxdif+1)){
  for (j in 1:(maxdif+1)) {
    points(x[i,j],y[i,j],pch=20,col=color)
    points(x[i,j],-y[i,j],pch=20,col=color)
  }
}

# now count how many observations there are at each plotting point

numcells = (maxdif + 1)^3
count = rep(NA,numcells)
dim(count) = c((maxdif+1),(maxdif+1),(maxdif+1))
xcoord = rep(NA,numcells)
dim(xcoord) = c((maxdif+1),(maxdif+1),(maxdif+1))
ycoord = rep(NA,numcells)
dim(ycoord) = c((maxdif+1),(maxdif+1),(maxdif+1))

for (i in 1:dim(triplets)[1]) {
   if (is.na(count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)])) {
       count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] = 0 }
   count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] =
       count[(triplets[i,1]+1),(triplets[i,2]+1),(triplets[i,3]+1)] + 1
}
for (i in 1:(maxdif+1)) {
   for (j in 1:(maxdif+1)) {
     for (k in 1:(maxdif+1)) {
       # compute the x & y coordinates for the plotting location
       xcoord[i,j,k] = i - j*cos(pi/3) - k*cos(pi/3)
       ycoord[i,j,k] = j*sin(pi/3) - k*sin(pi/3)
     }
   }
}

# now plot the data

for (i in 1:(maxdif+1)){
   for (j in 1:(maxdif+1)){
      for (k in 1:(maxdif+1)){
        if(!is.na(count[i,j,k])) points((xcoord[i,j,k]+offset),ycoord[i,j,k],pch=as.character(count[i,j,k]))
      }
   }
}

text(4.06,.45,"A")
text(-2.3,3.8,"B")
text(-2.3,-3.8,"c")

 return(list(triplets=triplets,x=x,y=y,count=count,xcoord=xcoord,ycoord=ycoord))

}

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

# regpolygon: compute (x,y) pairs that define the locations of the vertices of a regular polygon
# CJG, Aug. 7, 1995    modified by JM Hoenig June 2007 to run in R

regpolygon <- function(n=6,lenside=1,startang=0){

  # n        : the number of sides
  # lenside  : the length of each vertex to the center of the regular polygon
  # startang : the angle (degrees) of the first point on the polygon
  #            w.r.t. the x-axis

  startang <- startang*(pi/180)  # convert to radians

  vertices <- seq(startang, startang+(2*pi), length=(n+1) )
  x <- cos(vertices)
  y <- sin(vertices)

  x <- x*lenside
  y <- y*lenside

  return(list(x=x,y=y))

}


## beta via MLE in R

#' Title
#'
#' @param fmu formula object
#' @param method character string
#' @param data dataset
#' @param brange vector
#'
#' @export
#'
betamle <-function(fmu,method='BFGS', data, brange){

    #attach(data, warn.conflicts=FALSE)

    Fmu <- terms(fmu, data=data)
    X.vars <- as.character(attr(Fmu, "variables"))[c(-1, -2)]
    X.data <- model.matrix(fmu)

    Y.var <- as.character(attr(Fmu, "variables"))[2]
    Y.data <- model.frame(fmu)[,1]

    setrange <- function(z, brange) {
      t <- (z-brange[1])/(brange[2]-brange[1])
      t[which(t == 0)] <- .001
      t[which(t == 1)] <- .999
      t
    }

    dv <- setrange(Y.data, brange)
    nx <- ncol(X.data)

    neglnl<-function(theta){
	    nu <- theta[1:nx]
	    omega <- theta[(nx+1):(2*nx)]

	    X <- X.data

	    p1 <-exp(as.vector(X%*%nu))
	    p2 <- exp(as.vector(X%*%omega))

	    -sum(lgamma(p1 + p2) + (p1-1)*log(dv) + (p2-1)*log(1-dv) - lgamma(p1) - lgamma(p2) )
	   }

    result <- optim(rep(0,2*nx), neglnl, hessian=T, method="BFGS")

    coef<-result$par
    coef_nu <- coef[1:nx]
    coef_omega <- coef[(nx+1):(2*nx)]
    var<-solve(result$hessian)
    var_nu <- var[1:nx]
    var_omega <- var[(nx+1):(2*nx)]
    se<-sqrt(diag(var))
    se_nu <- se[1:nx]
    se_omega <- se[(nx+1):(2*nx)]
    zscore<-coef/se
    zscore_nu <- zscore[1:nx]
    zscore_omega <- zscore[(nx+1):(2*nx)]
    pvalue<-2.0*(1.0-pnorm(abs(zscore)))
    pscore_nu <- pvalue[1:nx]
    pscore_omega <- pvalue[(1+nx):(2*nx)]

    res <- cbind(coef_nu, se_nu, zscore_nu, pscore_nu,
                 coef_omega, se_omega, zscore_omega, pscore_omega)
	  colnames(res) <- c("Nu Coef.","Nu SE","Nu Z","Nu p", "Omega Coef", "Omega SE", "Omega Z", "Omega p")
	  rownames(res) <- c("constant",X.vars)

    cat("\n",paste("Beta MLE Model of",Y.var),"\n")

	  print(round(res,2))
    if (print(result$convergence==0))
	    cat("\nLikelihood:",-result$value,"\n")
    else
	    cat("\nDid NOT converge\n")

	  rval <- list("coef"=coef,
	               "coef_nu"=coef_nu,
	               "coef_omega"=coef_omega,
	               "var"=var,
	               "var_nu"=var_nu,
	               "var_omega"=var_omega,
	               "results" = res,
	               "Likelihood"=-result$value)
	  rval
  }


library(MASS)

f <- function(n) {
  factorial(n)
}

dispn <- function(n, m) {
  f(n)/f(n-m)
}

stirling <- function(n) {
  n*log(n) - n + (1/2)*log(2*pi*n)
}

# ESERCIZIO 1

white <- 4
red <- 3
green <- 4

# formule

permutazioni_es1 <- f(white+red+green)/(f(white)*(f(green)*(f(red))))

print(permutazioni_es1)

# ESERCIZIO 2
consonanti <- 9
vocali <- 5

consonanti_parola <- 6
vocali_parola <- 4

# formule

disp_cons <- choose(consonanti, consonanti_parola)
disp_voca <- choose(vocali, vocali_parola)
permutazioni_es2 <- f(consonanti_parola+vocali_parola)
parole <- disp_cons * disp_voca * permutazioni_es2
parole_log <- log(parole)
print(parole_log)

# ESERCIZIO 3
n_terzo <- 1548
print(stirling(n_terzo), digits=22)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# Outlier Treatment
#==============================================================================
# Title          : Outlier treatment.r
# Description    : Outlier Treatment
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20170822
# Version        : 0.0.2
# Usage          : Run in R 3.4
# Notes          : Source r-statistics.co by Selva Prabhakaran
# R version      : 3.4
#==============================================================================
# install.packages('car')
# install.packages('outliers')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(car)
library(outliers)

#==============================================================================
# Data
#==============================================================================

# Inject outliers into data.
cars1 <- cars[1:30, ]  # original data
cars_outliers <- data.frame(
	speed=c(19,19,20,20,20),
	dist=c(190, 186, 210, 220, 218))  # introduce outliers.
cars2 <- rbind(cars1, cars_outliers)  # data with outliers.

# Plot of data with outliers.
par(mfrow=c(1, 2))
plot(cars2$speed, cars2$dist, xlim=c(0, 28), ylim=c(0, 230),
	main="With Outliers", xlab="speed", ylab="dist", pch="*", col="red", cex=2)
abline(lm(dist ~ speed, data=cars2), col="blue", lwd=3, lty=2)

# Plot of original data without outliers. Note the change in slope (angle) of
# best fit line.
plot(cars1$speed, cars1$dist, xlim=c(0, 28), ylim=c(0, 230),
	main="Outliers removed \n A much better fit!", xlab="speed", ylab="dist",
	pch="*", col="red", cex=2)
abline(lm(dist ~ speed, data=cars1), col="blue", lwd=3, lty=2)

#==============================================================================
# Detect outliers
#==============================================================================

#------------------------------------------------------------------------------
# Univariate approach ----------------------------------------------------------
#------------------------------------------------------------------------------
url <- "http://rstatistics.net/wp-content/uploads/2015/09/ozone.csv"
inputData <- read.csv(url)  # import data

outlier_values <- boxplot.stats(inputData$pressure_height)$out  # outlier values.
boxplot(inputData$pressure_height, main="Pressure Height", boxwex=0.1)
mtext(paste("Outliers: ", paste(outlier_values, collapse=", ")), cex=0.6)

#------------------------------------------------------------------------------
# Bivariate approach ----------------------------------------------------------
#------------------------------------------------------------------------------
ozone <- read.csv(url)
# For categorical variable
boxplot(ozone_reading ~ Month, data=ozone,
	main="Ozone reading across months")  # clear pattern is noticeable.
boxplot(ozone_reading ~ Day_of_week, data=ozone,
	main="Ozone reading for days of week")
	# this may not be significant, as day of week variable is a subset of the
	# month var.

# For continuous variable (convert to categorical if needed.)
boxplot(ozone_reading ~ pressure_height, data=ozone,
	main="Boxplot for Pressure height (continuos var) vs Ozone")
boxplot(ozone_reading ~ cut(pressure_height,
	pretty(inputData$pressure_height)), data=ozone,
	main="Boxplot for Pressure height (categorial) vs Ozone", cex.axis=0.5)

#------------------------------------------------------------------------------
# Multivariate approach -------------------------------------------------------
#------------------------------------------------------------------------------

# Cooks Distance --------------------------------------------------------------
# https://onlinecourses.science.psu.edu/stat501/node/340

mod <- lm(ozone_reading ~ ., data=ozone)
cooksd <- cooks.distance(mod)

# In general use, those observations that have a cook’s distance greater than
# 4 times the mean may be classified as influential. This is not a hard
# boundary.

# plot cook's distance
plot(cooksd, pch="*", cex=2, main="Influential Obs by Cooks distance")
abline(h = 4*mean(cooksd, na.rm=T), col="red")  # add cutoff line
text(x=1:length(cooksd)+1, y=cooksd,
	labels=ifelse(cooksd>4*mean(cooksd, na.rm=T),
	names(cooksd),""), col="red")  # add labels
# influential row numbers
influential <- as.numeric(names(cooksd)[(cooksd > 4*mean(cooksd, na.rm=T))])
head(ozone[influential, ])  # influential observations.

#==============================================================================
# Outliers Test
#==============================================================================
car::outlierTest(mod)

# outliers package ------------------------------------------------------------
set.seed(666)
y=rnorm(100)
outlier(y)
outlier(y,opposite=TRUE)
dim(y) <- c(20,5)  # convert it to a matrix
outlier(y)
outlier(y,opposite=TRUE)

set.seed(666)
x = rnorm(10)
scores(x)  # z-scores => (x-mean)/sd
scores(x, type="chisq")  # chi-sq scores => (x - mean(x))^2/var(x)
scores(x, type="t")  # t scores
scores(x, type="chisq", prob=0.9)  # beyond 90th %ile based on chi-sq
scores(x, type="chisq", prob=0.95)  # beyond 95th %ile
scores(x, type="z", prob=0.95)  # beyond 95th %ile based on z-scores
scores(x, type="t", prob=0.95)  # beyond 95th %ile based on t-scores

#==============================================================================
# Treating the outliers
#==============================================================================
# 1. Imputation
# 2. Capping
#     For missing values that lie outside the 1.5*IQR limits, we could cap it
#     by replacing those observations outside the lower limit with the value of
#     5th-ile and those that lie above the upper limit, with the value of 95th
#     -ile. Below is a sample code that achieves this.
# 3. Prediction

x <- ozone$pressure_height
qnt <- quantile(x, probs=c(.25, .75), na.rm = T)
caps <- quantile(x, probs=c(.05, .95), na.rm = T)
H <- 1.5 * IQR(x, na.rm = T)
x[x < (qnt[1] - H)] <- caps[1]
x[x > (qnt[2] + H)] <- caps[2]


#sin(ax²+bx+c)^x
a = 2
b = 3
c = 1
delta = b*b-4*a*c
x1 = (-b+sqrt(delta))/(2*a)
x2 = (-b-sqrt(delta))/(2*a)
if(delta > 0) {
  #tem duas
  print(x1)
  print(x2)
} else {
  #pode ter uma ou nenhuma
  if(delta == 0) {
    print(x1)
  } else {
    print("Nao existe raiz real")
  }
}


#Define our Birthday Sim Function
pbirthdaysim <- function(n, nsims=100000, feb29=TRUE) {
  ## Using nsims simulations, estimate the probability
  ## that a room of n people includes a shared birthday
  bdays <- 1:366
  ## Feb 29 represented as day 366
  ## We'll sample other days 4 times as often
  ## compared to day 366
  probs <- c(rep(4,365),1)
  if(!feb29) {
    # drop Feb 29 from bdays and probs
    bdays <- bdays[-366]
    probs <- probs[-366]
  }
  probs <- probs/sum(probs)
  anydup <- function(ignored)
    ## simulate n birthdays, return TRUE if
    ## there's a duplicate
    any(duplicated(sample(bdays, n, prob=probs, replace=TRUE)))

  sum(sapply(seq(nsims), anydup)) / nsims
}

#Run on a single core
bdayp <- 1:100
system.time(for (n in 1:100) bdayp[n] <- pbirthdaysim(n))
plot(bdayp, xlab="People in room",
     ylab="Probability of shared birthday")
abline(h=0.5)

#Run locally on all cores
library(doParallel)
cl <- makeCluster(2)
registerDoParallel(cl)
system.time(bdayp <- foreach(n=1:100) %dopar% pbirthdaysim(n))
bdayp <- unlist(bdayp)
plot(bdayp, xlab="People in room",
     ylab="Probability of shared birthday")
abline(h=0.5)


confidenceInterval <- function(x, confidenceLevel=0.95){
N <- length(x)
alpha <- 1-confidenceLevel
if (N<30)
  stat <- qt(1-alpha/2, N-1)
else
  stat <- qnorm(1-alpha/2)
interval <- stat * sd(x) / sqrt(N)
mean_value <- mean(x)
result <- c(mean_value-interval, mean_value+interval)
names(result) <- c("lower", "upper")
result
}


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

# Funkcja przykładowa z dokumentacji
# f <- function(x) (x^2+x)*cos(x) # Badana funkcja
# lbound <- -10 # Dolne ograniczenie funkcji
# rbound <- 10 # Górne ogranicznie funkcji

f <- function(x) x*sin(10*pi*x)+1

fitnessF <- function(x)
{
  f <- f(x)

  penalty1 <- 0
  if (x <= -1) {
    penalty1 <- -x-1
  }

  penalty2 <- 0
  if (x >= 2) {
    penalty2 <- x - 2
  }

  f + penalty1 + penalty2
}

lbound <- -1000
rbound <- 1000

fA <- function(x) -fitnessF(x) # Funkcja odwrotna do badanej, ponieważ minimalizujemy funkcję

# Genetic algorithm
GA <- ga(
   type = "real-valued",
   fitness = fA,
   lower = c(th = lbound), upper = rbound,
   popSize = 50, maxiter = 100000, run = 1000
)
summary(GA)
plot(GA)

curve(f, from = lbound, to = rbound, 200) # rysowanie wykresy funkcji
#points(GA@solution, GA@fitnessValue, col = 2, pch = 19) # ozaczanie punktu na wykresie / tutaj szukanego ekstremum w zakresie
points(GA@solution, fitnessF(GA@solution), col = 2, pch = 19) # Musimy uzyskać wartość z funkcji wyjściowej, gdyż badamy funkcje odwrotną


# independent.test.equal.var.r
  x <- c(21.6,20.8,17.6,20.1,20.1,21.9,20.6,19.4,21.5,26.1)
  y <- c(20.6,20.4,20.2,20.2,18.0,19.8,20.9,19.7,20.3,19.7,22.7)
  mx <- mean(x); my <- mean(y)
  sdx <- sd(x); sdy <- sd(y)
  sp <- sqrt( (9*sdx^2+10*sdy^2)/(10+11-2) )
  t0 <- (mx-my)/(sp*sqrt(1/10+1/11))
  t0
  1-pt(t0, 19)
  lbd <- (mx-my) - qt(0.995, 19)*sp*sqrt(1/10+1/11)
  lbd
  ubd <- (mx-my) + qt(0.995, 19)*sp*sqrt(1/10+1/11)
  ubd


# import library
library(ggplot2)

# read the data
data <- read.csv("houses.csv")

# head of the data
head(data)

# statistics of the data
summary(data)

# plot the data
ggplot(data, aes(x = lotsize, y = price)) +
  geom_point()

# botplot of the bedrooms and price
ggplot(data, aes(x = as.factor(bedrooms), y = price)) +
    geom_boxplot()

# botplot of the bathrooms and price
ggplot(data, aes(x = as.factor(bedrooms), y = price)) +
    geom_boxplot()

# boxplot of stories and price
ggplot(data, aes(x = as.factor(stories), y = price)) +
    geom_boxplot()

# boxplot of driveway and price
ggplot(data, aes(x = as.factor(driveway), y = price)) +
    geom_boxplot()

# boxplot of recroom and price
ggplot(data, aes(x = as.factor(recroom), y = price)) +
    geom_boxplot()

# boxplot of gashw and price
ggplot(data, aes(x = as.factor(gashw), y = price)) +
    geom_boxplot()

# boxplot of airco and price
ggplot(data, aes(x = as.factor(airco), y = price)) +
    geom_boxplot()

# boxplot of garagepl and price
ggplot(data, aes(x = as.factor(garagepl), y = price)) +
    geom_boxplot()

# boxplot of prefarea and price
ggplot(data, aes(x = as.factor(prefarea), y = price)) +
    geom_boxplot()

# liner model between lotsize and price
lm1<- lm(data$lotsize ~ data$price)
lm1

# the residuals
res1 <- residuals(lm1)
data$res1 <- res1

# add number of bedrooms and bathrooms as a predictor
lm2<- lm(data$price ~ data$lotsize + data$bedrooms+ data$bathrms)
lm2
# the residuals
res2 <- residuals(lm2)
data$res2 <- res2

# plot the first model as a line
ggplot(data, aes(x = lotsize, y = price)) +
  geom_point() + stat_smooth(method = "lm", color = "red")

# plot the first cofficient of the second model
ggplot(data, aes(x = lotsize, y = price)) +
  geom_point() + geom_abline(slope=lm2$coefficients[2], color = "red")

# plot the second cofficient of the second model
ggplot(data, aes(x = bedrooms, y = price)) +
  geom_point() + geom_abline(slope=lm2$coefficients[3], color = "red")

# plot the third cofficient of the second model
ggplot(data, aes(x = bathrms, y = price)) +
  geom_point() + geom_abline(slope=lm2$coefficients[4], color = "red")

# convert driveway column as a factor
data$driveway <- factor(data$driveway)

# add driveway as a predictor
lm3<- lm(data$price ~ data$lotsize + data$bedrooms+ data$bathrms)
lm3
# the residuals
res3 <- residuals(lm3)
data$res3 <- res3

# convert number of bathrooms as a factor
data$bathrms <- factor(data$bathrms)

# re-fit model 2
lm2_new<- lm(data$price ~ data$lotsize + data$bedrooms+ data$bathrms + data$driveway)
lm2_new

# the residuals
res2_new <- residuals(lm2_new)
data$res2_new <- res2_new

# the scatter plot of residuals, mean and standard deviation of the residuals
mean(res1)
sd(res1)
ggplot(data, aes(x = price, y = res1)) +
  geom_point()

mean(res2)
sd(res2)
ggplot(data, aes(x = price, y = res2)) +
  geom_point()

mean(res3)
sd(res3)
ggplot(data, aes(x = price, y = res3)) +
  geom_point()

mean(res2_new)
sd(res2_new)
ggplot(data, aes(x = price, y = res2_new)) +
  geom_point()

# convert columns to factors
data$bedrooms <- factor(data$bedrooms)
data$driveway <- factor(data$driveway)
data$stories <- factor(data$stories)
data$recroom <- factor(data$recroom)
data$fullbase <- factor(data$fullbase)
data$gashw <- factor(data$gashw)
data$airco <- factor(data$airco)
data$garagepl <- factor(data$garagepl)
data$prefarea <- factor(data$prefarea)

# liner model between al the columns and price
lm4<- lm(data$price ~ data$lotsize + data$bedrooms+ data$bathrms + data$driveway + data$stories + data$recroom + data$fullbase + data$gashw + data$airco + data$garagepl + data$prefarea)

# the residuals
res4 <- residuals(lm4)
data$res4 <- res4

# stepwise regression
lm4_step<- step(lm4)

# the residuals
res4_step <- residuals(lm4_step)
data$res4_step <- res4_step

# step with interaction
lm4_step_intera<- step(lm4_step, scope = ~.*.)
res4_step_intera <- residuals(lm4_step_intera)
data$res4_step_intera <- res4_step_intera

# plot the residuals
mean(res4)
sd(res4)
ggplot(data, aes(x = price, y = res4)) +
  geom_point()

mean(res4_step)
sd(res4_step)
ggplot(data, aes(x = price, y = res4_step)) +
  geom_point()

mean(res4_step_intera)
sd(res4_step_intera)
ggplot(data, aes(x = price, y = res4_step_intera)) +
  geom_point()


?mtcars

df <- mtcars

str(df)

# creating factor about num
df$vs <- factor(df$vs, labels=c("V", "S"))

df$am <- factor(df$am, labels=c("Auto", "Manual"))

# simple static functions
median(df$mpg)

mean(df$disp)

sd(df$hp)

range(df$cyl)

mean_disp <-mean(df$disp)
print(mean_disp)

# example 1
mean(df$mpg[df$cyl == 6])

# example 2
mean(df$mpg[df$cyl == 6 & df$vs == "V"])

# example 3
sd(df$hp[df$cyl != 3 & df$am =="Auto"])

# trouble №1
mean(df$qsec[df$cyl != 3 & df$mpg >= 20])

?aggregate

# create realesed dataframe by FUN func
mean_hp_vs <- aggregate(x = df$hp, by= list(df$vs), FUN= mean)
# named
colnames(mean_hp_vs) <- c("VS", "Mean HP")

aggregate(hp ~ vs, df, mean)

aggregate(hp ~ vs + am, df, mean)

aggregate(x=df$hp, b=list(df$vs,df$am), FUN = mean)

aggregate(x=df[,-c(8,9)], by=list(df$am), FUN=median)

# trouble №2
aggregate(hp ~ disp + am, df, sd)
aggregate(x=df[c(3,4)],by=list(df$am), FUN=sd)

library(psych)

?describe

describe(x=df)

descr <- describe(x=df[,-c(8,9)])

?describeBy()

descr2 <- describeBy(x = df[,-c(8,9)], group = df$vs)

descr2 <- describeBy(x = df[,-c(8,9)], group = df$vs, mat = TRUE, digits = 1)

descr3 <- describeBy(x = df[,-c(8,9)], group = df$vs, mat = TRUE, digits = 1, fast = TRUE)

describeBy(df$qsec, group = list(df$vs,df$am), mat = TRUE, digits = 1, fast = TRUE)

#trouble №3
df <- airquality

dfd <- subset(df, Month == 7 | Month == 8 | Month == 9)
aggregate(Ozone ~ Month,dfd, FUN=length)

#trouble №4
df <- airquality
dfd <- describeBy(x= df, group = df$Month, digits = 1)
print(dfd)

sum(is.na(df))


library(downloader)
url <- "https://raw.githubusercontent.com/genomicsclass/dagdata/master/inst/extdata/femaleControlsPopulation.csv"
filename <- basename(url)
download(url, destfile = filename)
data <- unlist(read.csv(filename))

population_mean <- mean(data)

# sample 1 mean
set.seed(1)
abs(mean(sample(data, 5)) - population_mean)

# sample 2 mean
set.seed(5)
abs(mean(sample(data, 5)) - population_mean)


if(FALSE){
"Time series is a series of data points in which each data point is associated with a timestamp.
A simple example is the price of a stock in the stock market at different points of time on a given day.
Another example is the amount of rainfall in a region at different months of the year.
R language uses many functions to create, manipulate and plot the time series data.
The data for the time series is stored in an R object called time-series object.
It is also a R data object like a vector or data frame."

#The time series object is created by using the ts() function
#timeseries.object.name <-  ts(data, start, end, frequency)
"data is a vector or matrix containing the values used in the time series.
start specifies the start time for the first observation in time series.
end specifies the end time for the last observation in time series.
frequency specifies the number of observations per unit time."

}
function1 <- function(){
#We create an R time series object for a period of 12 months and plot it.
# Get the data points in form of a R vector.
rainfall <- c(799,1174.8,865.1,1334.6,635.4,918.5,685.5,998.6,784.2,985,882.8,1071)

# Convert it to a time series object.
rainfall.timeseries <- ts(rainfall,start = c(2012,1),frequency = 12)

# Print the timeseries data.
print(rainfall.timeseries)

# Give the chart file a name.
png(file = "rainfall.png")

# Plot a graph of the time series.
plot(rainfall.timeseries)

# Save the file.
dev.off()
}
# function1()

if(FALSE){
"The value of the frequency parameter in the ts() function decides the time intervals
at which the data points are measured"
"frequency = 12 pegs the data points for every month of a year.
frequency = 4 pegs the data points for every quarter of a year.
frequency = 6 pegs the data points for every 10 minutes of an hour.
frequency = 24*6 pegs the data points for every 10 minutes of a day."
}

function2 <- function(){
# Get the data points in form of a R vector.
rainfall1 <- c(799,1174.8,865.1,1334.6,635.4,918.5,685.5,998.6,784.2,985,882.8,1071)
rainfall2 <-
           c(655,1306.9,1323.4,1172.2,562.2,824,822.4,1265.5,799.6,1105.6,1106.7,1337.8)

# Convert them to a matrix.
combined.rainfall <-  matrix(c(rainfall1,rainfall2),nrow = 12)

# Convert it to a time series object.
rainfall.timeseries <- ts(combined.rainfall,start = c(2012,1),frequency = 12)

# Print the timeseries data.
print(rainfall.timeseries)

# Give the chart file a name.
png(file = "rainfall_combined.png")

# Plot a graph of the time series.
plot(rainfall.timeseries, main = "Multiple Time Series")

# Save the file.
dev.off()
}
function2()


function medcouple(vector X):
       // X is a vector of size n

       // compute initial ingredients as for the naïve medcouple
       sort_decreasing(X)

       xm := median(X)
       xscale := 2*max(X)

       Zplus  := [(x - xm)/xscale | x in X such that x >= xm]
       Zminus := [(x - xm)/xscale | x in X such that x <= xm]

       p := size(Zplus)
       q := size(Zminus)

       function h(i,j):
           a := Zplus[i]
           b := Zminus[j]

           if a == b:
               return signum(p - 1 - i - j)
           else:
               return (a + b)/(a - b)
           endif
       endfunction

       // begin Kth pair algorithm (Johnson & Mizoguchi)

       // the initial left and right boundaries, two vectors of size p
       L := [0, 0, ..., 0]
       R := [q - 1, q - 1, ..., q - 1]

       // number of entries to the left of the left boundary
       Ltotal := 0

       // number of entries to the left of the right boundary
       Rtotal := p*q

       // since we are indexing from zero, the medcouple index is one
       // less than its rank
       medcouple_index := floor(Rtotal/2)

       // iterate while the number of entries between the boundaries is
       // greater than the number of rows in the matrix
       while Rtotal - Ltotal > p:

           // compute row medians and their associated weights, but skip
           // any rows that are already empty
           middle_idx  := [i | i in [0, 1, ..., p - 1] such that L[i] <= R[i]]
           row_medians := [h(i, floor((L[i] + R[i])/2) | i in middle_idx]
           weights := [R[i] - L[i] + 1 | i in middle_idx]

           WM := weighted median(row_medians, weights)

           // new tentative right and left boundaries
           P := greater_h(h, p, q, WM)
           Q := less_h(h, p, q, WM)

           Ptotal := sum(P) + size(P)
           Qtotal := sum(Q)

           // determine which entries to discard, or if we've found the medcouple
           if medcouple_index <= Ptotal - 1:
               R := P
               Rtotal := P
           else:
               if medcouple_index > Qtotal - 1:
                   L := Q
                   Ltotal := Qtotal
               else:
                   // found the medcouple, rank of the weighted median equals medcouple index
                   return WM
               endif
           endif

       endwhile

       // did not find the medcouple, but there are very few tentative entries remaining
       remaining := [h(i,j) | i in [0, 1, ..., p - 1],
                              j in [L[i], L[i] + 1, ..., R[i]]
                              such that L[i] <= R[i] ]

       // select the medcouple by rank amongst the remaining entries
       medcouple := select_nth(remaining, medcouple_index - Ltotal)

       return medcouple
   endfunction


#Section 6.4

x<-seq(-10,10,1)
y<-x^2
z<-x
a<-rep(1,21)

plot(x,y,type="l",ylim=c(-10,100))
lines(x,z,col="red")
lines(x,a,col="blue")

cor(y,x)
cor(x,z)

library(infotheo)
mutinformation(x,a)
mutinformation(x,z)
mutinformation(x,y)

#Section 6.5
RandMatrixNormal <-function(n){
mats<-matrix(rnorm(n^2,0,1),ncol=n)
return((mats+t(mats))/2)
}

RandMatrixStudent <-function(n,df){
  mats<-matrix(rt(n^2,df,0),ncol=n)
  return((mats+t(mats))/2)
}

Normal<-eigen(RandMatrixNormal(1000))
Student3<-eigen(RandMatrixStudent(1000,3))
Cauchy<-eigen(RandMatrixStudent(1000,1))

hist(Normal$values)
hist(Student3$values)
hist(Cauchy$values)

#Section 6.7

#Y= aX+b +e

sampleCauchy<-function(n,a,b){

  X<-seq(1,n,1)
  e<-rcauchy(n,0,1)
  Y<-a*X+b+e
  return(Y)
}

xx<-sampleCauchy(50,2,15)

plot(xx)

Session 3/Chapter 6 - Higher Dimensions - JS.r


#!/usr/bin/Rscript

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

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

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

# Estimates of Pareto shape parameter (power-law slope)
npts <- 100
alpha.MLE <- function(x) 1 / mean(log(x))
alpha.MVUE <- function(x) (1-(2/npts)) / mean(log(x))
alpha.mom <- function(x) 1 / (1-1/mean(x))
alpha.LS.EDF <- function(x) {
    lsd <- log(sort(x)) ; lseq <- log((npts:1) / npts)
    tmp <- lm(lseq~lsd)
    # plot(lsd, lseq) ; abline(tmp,col=2)
    -tmp$coef[2] }
alpha.LS.hist <- function(x) {
    hx <- hist(x, nclass=20, plot=F)
    counts <- hx$counts
    ldens <- log(hx$density[counts>0])
    lmidpts <- log(hx$mids[counts>0])
    tmp1 <- lm(ldens~lmidpts)
    # plot(lmidpts, ldens) ; abline(tmp1, col=2)
    alpha.LS.hist <- -1 - as.numeric(tmp1$coef[2])
    return(alpha.LS.hist) }
alpha.LS.hist.wt <- function(x) {
    hx <- hist(x, nclass=20, plot=F)
    counts <- hx$counts
    ldens <- log(hx$density[counts>0])
    lmidpts <- log(hx$mids[counts>0])
    tmp2 <- lm(ldens~lmidpts, weights=counts[counts>0])
    alpha.LS.hist.wt <- -1 - as.numeric(tmp2$coef[2])
    return(alpha.LS.hist.wt) }
six_alphas <- function(x) {
    out <- c(alpha.MLE(x), alpha.MVUE(x), alpha.mom(x),
             alpha.LS.EDF(x), alpha.LS.hist(x), alpha.LS.hist.wt(x))
    return(out) }

# Turn off device driver
#dev.off()


dieroll <- function(n){
  ceiling(runif(1,0,n))
}
# alternative:  sample(1,1:6,replacement=TRUE)

kdieroll<-function(k,n){
  replicate(k,dieroll(n))
}

# counts the number of 6s that appear when four 6-sided dice are rolled
demere<-function(){
  sum(kdieroll(4,6)=="6")
}

# repeats the demere experiment n times and returns the proportion of times
# that a six appears in an experiment as well as the list of experiment results
# USE:  use unlist() to strip the list structure from components
demere1 <- function(n){
  x<-replicate(n,demere())
  N<-sum(x>0)/n
  list(N,x)
}


mergesort <- function(m)
{
   merge_ <- function(left, right)
   {
      result <- c()
      while(length(left) > 0 && length(right) > 0)
      {
         if(left[1] <= right[1])
         {
            result <- c(result, left[1])
            left <- left[-1]
         } else
         {
            result <- c(result, right[1])
            right <- right[-1]
         }
      }
      if(length(left) > 0) result <- c(result, left)
      if(length(right) > 0) result <- c(result, right)
      result
   }

   len <- length(m)
   if(len <= 1) m else
   {
      middle <- length(m) / 2
      left <- m[1:floor(middle)]
      right <- m[floor(middle+1):len]
      left <- mergesort(left)
      right <- mergesort(right)
      if(left[length(left)] <= right[1])
      {
         c(left, right)
      } else
      {
         merge_(left, right)
      }
   }
}
mergesort(c(4, 65, 2, -31, 0, 99, 83, 782, 1)) # -31   0   1   2   4  65  83  99 782


=begin
  # sample-lagrange-multiplier01.rb

  require 'algebra'
  P = MPolynomial(Rational)
  t, x, y, z = P.vars('txyz')
  f = x**3+2*x*y*z - z**2
  g = x**2 + y**2 + z**2 - 1

  fx = f.derivate(x)
  fy = f.derivate(y)
  fz = f.derivate(z)

  gx = g.derivate(x)
  gy = g.derivate(y)
  gz = g.derivate(z)

  F = [fx - t * gx, fy - t * gy, fz - t * gz, g]

  Groebner.basis(F).each do |h|
    p h.factorize
  end

  #(1/7670)(7670t - 11505x - 11505yz - 335232z^6 + 477321z^4 - 134419z^2)
  #x^2 + y^2 + z^2 - 1
  #(1/3835)(3835xy - 19584z^5 + 25987z^3 - 6403z)
  #(1/3835)(3835x + 3835yz - 1152z^4 - 1404z^2 + 2556)(z)
  #(1/3835)(3835y^3 + 3835yz^2 - 3835y - 9216z^5 + 11778z^3 - 2562z)
  #(1/3835)(3835y^2 - 6912z^4 + 10751z^2 - 3839)(z)
  #(1/118)(118y - 1152z^3 + 453z)(z)(z - 1)(z + 1)
  #(1/1152)(z)(z - 1)(3z - 2)(3z + 2)(z + 1)(128z^2 - 11)

((<_|CONTENTS>))
=end


# Cyclical mean
# 'Cyclical mean'

#' Cyclical mean
#'
#' Calculate the mean of a set of cyclical values, e.g. calendar months, day of year, angles. The code transform the cycle to cartesian vectors, calculates summed vector, and get the cycle of the sum vector.
#'
#' @param x vector of cyclical values
#' @param steps number of steps in the cycle
#'
#' @return collapsed string
#' @export
cyclicalMean = function(x, steps=360){
  radial_frac = 2*pi/steps
  x_angle = radial_frac * x
  vec_x = cos(x_angle)
  vec_y = sin(x_angle)
  vec_x_mean = mean(vec_x)
  vec_y_mean = mean(vec_y)
  a_mean = atan2(vec_y_mean, vec_x_mean)
  x_mean = steps * a_mean / (2 * pi)
  x_mean = ifelse(x_mean < 0, steps+x_mean, x_mean)
  x_mean
}


###################################
### Part 3: Plotting Data ###
###################################
##
#

# We are going to work with one of R's built-in data sets called 'iris'.
# First, let's find out more about the data:

#######################
# Complete Exercise 4 #
#######################

# Let's analyze just the petal widths of the versicolor species in 'iris'.

# We can create a new data frame by extracting a subet of all versicolor records,...
versicolor <- iris[iris$Species == 'versicolor',]
versicolor

# ...then create a numeric vector of versicolor petal widths, or...
versicolor_pw <- versicolor$Petal.Width
versicolor_pw

# ...do the same thing all in one line
versicolor_pw <- iris[iris$Species == 'versicolor', 'Petal.Width']
versicolor_pw

# As with most programming languages, there is usually more than one way to do things in R.
# Keep this in mind as you are learning the language.

### Calculating simple statistics ###

# Before we create any plots, let's get some simple statistics on the pedal widths of versicolor:

mean(versicolor_pw)
median(versicolor_pw)
var(versicolor_pw)
sd(versicolor_pw)

# We can also look at the correlation between versicolor's petal width and it's petal length.
# First let's create a vector for versicolor's petal lengths.
versicolor_pl <- iris[iris$Species == 'versicolor', 'Petal.Length']
versicolor_pl

# By default, cor() uses the Pearson method. Values range from -1 to 1. Does petal width have
# a correlation with petal length?
cor(versicolor_pw,versicolor_pl)

### Plotting Data ###

## Scatterplot ##

# Let's plot the versicolor petal lengths and widths
  plot(versicolor_pw,versicolor_pl)

  # Add a regression line
  abline(lm(versicolor_pl~versicolor_pw))

  # Change the title
  title("Versicolor Petal Width vs Length")

# What happens if we plot the whole 'iris' data set?
plot(iris)

# Calling plot() on the whole data set makes a scatterplot matrix that plots every variable
# against every other variable. What if we just want to look at one of these scatterplots?
plot(iris$Petal.Length, iris$Petal.Width)

## Boxplot ##

# Boxplot of petal length by species
boxplot(Petal.Length~Species, data = iris, main="Petal Length by Iris Species",
        ylab="Length (cm)")

## Dot Plot ##

# Take a random sample of size 40 from the iris dataset, sampling without replacement
iris_ran_subset <- iris[sample(1:nrow(iris), 40, replace=FALSE),]

# Sort the rows so that all of the same species are together
iris_ran_subset_sorted <- iris_ran_subset[order(iris_ran_subset$Species),]

# Create a new column, 'Color'
iris_ran_subset_sorted$Color="black"

# Set Color values by Species
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "virginica"] = "red"
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "versicolor"] = "blue"
iris_ran_subset_sorted$Color[iris_ran_subset_sorted$Species == "setosa"] = "black"

# Plot the data
dotchart(iris_ran_subset_sorted$Sepal.Width,labels=iris_ran_subset_sorted$Species,cex=.9,
         main="Comparison of Sepal Width by Iris Species",
         xlab="Sepal Width (cm)", col=iris_ran_subset_sorted$Color)

## Histogram ##

# We can also make a histogram that describes the distribution of sepal length values:
hist(iris$Sepal.Length)

# Let's give the histogram more detail by increasing the number of bins. This is done with
# the 'breaks' argument:

hist(iris$Sepal.Length, breaks = 15)

# Hmm...the x axis is a little off. Let's adjust it with the 'xlim' argument:

hist(iris$Sepal.Length, breaks = 25, xlim = c(4, 8))

#######################
# Complete Exercise 5 #
#######################

# On a side note...remember when we introduced lists earlier? A common use of lists is to
# gather different types of R objects in one container. Many functions, including hist(),
# return a list of different values. Each attribute of the returned histogram correlates
# to a specific component of the list. For example, if we assign the output of
# hist(iris$Sepal.Length) to a variable, we can capture the returned list:

sepal_hist <- hist(iris$Sepal.Length)
sepal_hist

# There are many other built-in data sets in R. To see a list...

data()


#number of trials
n<-5
#  the probability of success when one person is selected from the population is
z<-0.9
#  probability that all five heads of the households are employed
y<-5
probability_forall5employed<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
print(probability_forall5employed)


#Copyright (c) 2016 Riccardo Francescato
a <- c(16.85,16.40,17.21,16.35,16.52,17.04,16.96,17.15,16.59,16.57)
b <- c(16.62,16.75,17.37,17.12,16.98,16.87,17.34,17.02,17.08,17.27)
#confidency level
alpha = .05
#type of test: 0 left tail 1 double tail 2 right tail
type = 2
#calculations....
n0 = length(a)		# number of reps for sample 0
n1 = length(b)		# number of reps for sample 1
xbar0 = mean(a)		# sample 0 mean
xbar1 = mean(b)		# sample 1 mean
s0 = sd(a)			# sample 0 standard deviation
s1 = sd(b)			# sample 1 standard deviation
f = (s0^2)/(s1^2)
if(type == 0){
	fc = qf(alpha,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of lower tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf: ",f))
	cat(paste("\nfalpha: ",fc))
	if(f>fc) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	fct = qf(alpha/2,df1=n0-1,df2=n1-1,lower.tail=F)
	fcb = qf(1-alpha/2,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of 2-tail tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf0: ",f))
	cat(paste("\nfalpha +: ",fct))
	cat(paste("\nfalpha -: ",fcb))
	if(f<fcb || f>fct) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	fc = qf(alpha,df1=n0-1,df2=n1-1,lower.tail=F)
	cat("Results of lower tail\n")
	cat("First sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat("\nSecond sample\n")
	cat(paste("# of elements: ", n1, " Mean: ", xbar1, " St Dev: ",s1))
	cat(paste("\nf: ",f))
	cat(paste("\nfalpha: ",fc))
	if(f>fc) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


## パッケージの読み込み
require(MASS)

## データの読み込み
files <- list.files(path="data")
mydat <- list()
for(fn in files){ # data 内にある全ファイルを読み込む
    mydat[[fn]] <-
        read.csv(file=paste("data",fn,sep="/"),
                 na.string="-")
}
## データは以下のサイトのものを利用した．(2016/12/19)
##   http://artv.info
## 以下から data.zip を download して展開して下さい．
##

## データの集計のための関数
myfun <- function(df){ # 1行ごとに処理
    tmp <- data.frame(t(apply(df,1,mysubfun)))
    rownames(tmp) <- df[,3]
    return(tmp)
}
mysubfun <- function(x){
    tmpa <- which(names(x)=="平均")
    tmpb <- min(which(is.na(x)),tmpa)
    tmpc <- as.numeric(x[c(4:8,tmpb-(1:5))])
    return(c(tmpc,mean(tmpc)))
}
## 長さを揃えるため，初回から5回までと，最終回から5回前までを取得
## 番組によっては重複している回があるが，
## ここでは初回からの変動と，最終回前の変動を比較して
## 距離を定義することとする

## 全データを整理
tmp <- lapply(mydat,myfun)
names(tmp) <- NULL
dat <- do.call(rbind,tmp)

## 距離の計算，平均からの変動をマンハッタン距離で比較
dst <- dist((dat[,-11]-dat[,11]),method="manhattan")

## 別の距離の例
## 前の回との差分(増減)に着目する場合
## dst <- dist(t(apply(dat[,-11],1,diff)),method="manhattan")

## 平均視聴率が高い番組のみ使う場合
## dst <- dist((dat[,-11]-dat[,11])[dat[,11]>8,],method="manhattan")

## 非計量的MDSを利用
mds <- isoMDS(dst)

## 全体図の表示
par(family="HiraMaruProN-W4")
plot(mds$points,
     xlab="axis 1", ylab="axis 2", type="n",
     main="全体図")
text(mds$points,labels=rownames(dat),
     col=ifelse(dat[,11]>8,"red","blue"))

## 中心部分のみ表示
plot(mds$points, xlim=c(-5,5),ylim=c(-5,5),
     xlab="axis 1", ylab="axis 2", type="n",
     main="中心部")
text(mds$points,labels=rownames(dat),
     col=ifelse(dat[,11]>8,"red","blue"))


## Set up and plot hypothetical paths of GDP per capita

## Set up scenarios
# Each scenario has ID, alpha, sI, gL, gA, delta, KY0, A0
scenario <- c('A','B','C','D','E')
alpha <- c(.3,.3,.3,.3,.3)
sI <- c(.2,.2,.2,.1,.4)
gL <- c(.01,.01,.01,.01,.01)
gA <- c(.02,.02,.02,.02,.02)
delta <- c(.05,.05,.05,.05,.05)
KY0 <- c(2.5,1.5,4,2.5,2.5)
A0 <- c(10,10,10,10,10)
label <- c('C','B','D','E','A') # allows different label for test purposes

# Year vector gives total periods to run over
year <- c(0:40)
s <- 0 # initializes Solow vector

# Merge year and scenario data to create scenario/year dataframe
all_scenario <- data.frame(scenario,alpha,sI,gL,gA,delta,KY0,A0) # combine scenario parameters
year_scenario <- expand.grid(year,scenario) # create year/scenario combinations
names(year_scenario) <- c("year","scenario")
s <- merge(year_scenario,all_scenario,by="scenario") # add parameters to year/scenario combos

# Make calculations of various values using theory
s$conv <- 1 - (1-s$alpha)*(s$delta + s$gA + s$gL) # convergence factor
s$kystar <- s$sI/(s$gL+s$gA+s$delta) # steady state capital/output ratio
s$ky <- s$KY0*(s$conv^s$year) + (s$kystar)*(1-(s$conv)^s$year) # actual KY ratio
s$kylag <- s$KY0*(s$conv^(s$year-1)) + (s$kystar)*(1-(s$conv)^(s$year-1)) # actual KY ratio
s$lny <- (s$alpha/(1-s$alpha))*log(s$ky) + log(s$A0) + s$gA*s$year # actual log GDP p.c.
s$lnystar <-(s$alpha/(1-s$alpha))*log(s$kystar) + log(s$A0) + s$gA*s$year # BGP log GDP p.c.
s$gky <- log(s$ky) - log(s$kylag)
s$gy <- (s$alpha/(1-s$alpha))*s$gky + s$gA

# Plot figure of scenarios and their BGP's
fig <- plot_ly(s, x = ~year, y = ~lny, linetype = ~scenario, type = 'scatter', mode = 'lines')
#fig <- add_trace(fig, x = ~year, y = ~lnystar, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-lny")

fig <- plot_ly(s, x = ~year, y = ~gy, linetype = ~label, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Growth rates', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Growth rate of GDP per capita'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-gy")

fig <- plot_ly(s, x = ~year, y = ~ky, linetype = ~scenario, type = 'scatter', mode = 'lines')
fig <- layout(fig, title = list(text = 'Capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Capital/output ratio'),
              hovermode="x unified")
api_create(fig, filename = "sim-solow-ky")


nthroot <- function(A, n, tol=sqrt(.Machine$double.eps))
{
   ifelse(A < 1, x0 <- A * n, x0 <- A / n)
   repeat
   {
      x1 <- ((n-1)*x0 + A / x0^(n-1))/n
      if(abs(x1 - x0) > tol) x0 <- x1 else break
   }
   x1
}
nthroot(7131.5^10, 10)   # 7131.5
nthroot(7, 0.5)          # 49


library(rstan) # For STAN from R.
library(rethinking) # For ULAM from R.
set.seed(1)

# Simmulation (hidden).
prob <- 0.2
D <- rbinom(18, 1, prob = prob)

# Modeling ULAM.
model <- ulam(alist(
  D ~ dbinom(1, prob),
  prob ~ dunif(0, 1)
), data = list(D = D))

samples <- extract.samples(model)
hist(samples$prob)

# Modeling STAN.
model <- stan(model_code = "
data{
    int <lower=0> N;
    int D[N];
}
parameters{
    real<lower=0,upper=1> prob;
}
model{
    prob ~ uniform( 0 , 1 );
    D ~ binomial( 1 , prob );
}
", data = list(D = D, N = length(D)), chains = 1)

samples <- extract(model)
hist(samples$prob)


library(ISLR)
Hitters=na.omit(Hitters)

library(leaps)
regfit.full=regsubsets (Salary~.,Hitters)
regfit.full=regsubsets (Salary~.,data=Hitters ,nvmax=19)
reg.summary=summary(regfit.full)
par(mfrow=c(2,2))
plot(reg.summary$rss ,xlab="Number of Variables ",ylab="RSS",       type="l")
plot(reg.summary$adjr2 ,xlab="Number of Variables ",       ylab="Adjusted RSq",type="l")
points(11,reg.summary$adjr2[11], col="red",cex=2,pch=20)

#foward and backward stepwise selection
regfit.fwd=regsubsets (Salary~.,data=Hitters ,nvmax=19, method="forward")
summary(regfit.fwd)
regfit.bwd=regsubsets (Salary~.,data=Hitters ,nvmax=19, method="backward")
summary(regfit.bwd)

predict.regsubsets =function (object ,newdata ,id,...){
  form=as.formula(object$call [[2]])
  mat=model.matrix(form,newdata)
  coefi=coef(object ,id=id)
  xvars=names(coefi)
  mat[,xvars]%*%coefi
}
k=10
set.seed(1)
folds=sample(1:k,nrow(Hitters),replace=TRUE)
cv.errors=matrix(NA,k,19, dimnames =list(NULL , paste(1:19)))
for(j in 1:k){
  best.fit=regsubsets (Salary~.,data=Hitters[folds!=j,],nvmax=19)
  for(i in 1:19){
    pred=predict(best.fit ,Hitters[folds==j,],id=i)
    cv.errors[j,i]=mean( (Hitters$Salary[folds==j]-pred)^2)
  }
}

mean.cv.errors=apply(cv.errors ,2,mean)
mean.cv.errors
par(mfrow=c(1,1))
plot(mean.cv.errors ,type="b")

#Why use the full dataset after the CV?
#https://stats.stackexchange.com/questions/11602/training-with-the-full-dataset-after-cross-validation
reg.best=regsubsets (Salary~.,data=Hitters , nvmax=19)
coef(reg.best ,11)

#RIDGE AND LASSO REGRESSION

x=model.matrix(Salary~.,Hitters)[,-1]
y=Hitters$Salary

library(glmnet)

#ridge
grid=10^seq(10,-2, length =100)
ridge.mod=glmnet(x,y,alpha=0,lambda=grid)
set.seed(1)
train=sample(1:nrow(x), nrow(x)/2)
test=(-train)
y.test=y[test]
set.seed(1)
cv.out=cv.glmnet(x[train ,],y[train],alpha=0)
plot(cv.out)
bestlam=cv.out$lambda.min
bestlam

#after findingnthe best RIDGE lanbda, we refit the model using
#the whole dataset

out=glmnet(x,y,alpha=0)
predict(out,type="coefficients",s=bestlam)[1:20,]

#LASSO
lasso.mod=glmnet(x[train ,],y[train],alpha=1,lambda=grid)
plot(lasso.mod)

set.seed(1)
cv.out=cv.glmnet(x[train ,],y[train],alpha=1)
plot(cv.out)
bestlam=cv.out$lambda.min
lasso.pred=predict(lasso.mod,s=bestlam ,newx=x[test ,])
mean((lasso.pred-y.test)^2)
out=glmnet(x,y,alpha=1,lambda=grid)
lasso.coef=predict(out,type="coefficients",s=bestlam)[1:20,]
lasso.coef

library(pls)
set.seed(2)
pcr.fit=pcr(Salary~., data=Hitters ,scale=TRUE, validation ="CV")
summary(pcr.fit)
validationplot(pcr.fit,val.type="MSEP")

set.seed(1)
pcr.fit=pcr(Salary~., data=Hitters ,subset=train ,scale=TRUE,validation ="CV")
validationplot(pcr.fit,val.type="MSEP")

pcr.pred=predict(pcr.fit ,x[test ,],ncomp=7)
mean((pcr.pred-y.test)^2)

#Finally, we fit PCR on the full data set,
#using M = 7, the number of
#components identified by cross-validation.
pcr.fit=pcr(y~x,scale=TRUE,ncomp=7)
summary(pcr.fit)

#PLS
set.seed(1)
pls.fit=plsr(Salary~., data=Hitters ,subset=train ,scale=TRUE ,validation ="CV")
summary(pls.fit)
pls.pred=predict(pls.fit ,x[test ,],ncomp=2)
mean((pls.pred-y.test)^2)

#Finally, we perform PLS using the full data set, using M = 2, the number
#of components identified by cross-validation.
pls.fit=plsr(Salary~., data=Hitters ,scale=TRUE,ncomp=2)
summary(pls.fit)


#'@title Get the seasonality score for a given monthly time series
#'
#'@description The seasonality score of a monthly time series is computed as its departure from a uniform distribution.
#'
#'@usage  tsData.ss <- getSeasonalityScore(tsData)
#'
#'@details
#' The degree of seasonality of a monthly time series is based on its departure from a uniform distribution.
#' If the number of cases for a given concept is uniformly distributed across all time periods (in this case, all months),
#' then its monthly prevalence (as well as proportion) would be constant.  In this case, the time series would be
#' considered "absolutely non-seasonal" and its "seasonality score" would be zero.
#' Similarly, if all the cases occur at a single point in time (that is, in a single month), such a time series would be considered
#' "absolutely seasonal" and its seasonality score would be 1.  All other time series would have
#' a seasonality score between 0 and 1.  Currently, only monthly time series are supported.
#' NB: To be able to compute a seasonality score, a time series must have a minimum of three complete years of data.
#'
#'@param tsData  A time series object.
#'
#'@return A numeric value between 0 and 1 (inclusive) representing the seasonality of a time series.
#'
#'@import dplyr
#'@export

getSeasonalityScore <- function(tsData)
{
	tsObj <- tsData
	maxDist   <- 1.83
	unifDist  <- 1/12
	minMonths <- 36

	if (frequency(tsObj) != 12)
		stop("ERROR: Only monthly time series are supported")

	tsObj <- Castor::tsCompleteYears(tsObj)

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

	tsObj.yrProp <- Castor::sumAcrossYears(tsObj)$PROP

	tsObj.ss <- round(sum(abs(tsObj.yrProp-unifDist))/maxDist,2)

	return (tsObj.ss)
}


# FUNCTIONS

is_prime_6k1 <- function(n) {
    if (n <= 3) {
        return(n > 1)
    } else if (n %% 2 == 0 || n %% 3 == 0) {
        return(FALSE)
    }

    i <- 5
    while (i * i <= n) {
        if (n %% i == 0 || n %% (i + 2) == 0) {
            return(FALSE)
        }
        i <- i + 6
    }

    return(TRUE)
}

# SCRIPT

i <- 1
n <- 1
while (i != 10001) {
    n <- n + 2
    i <- i + is_prime_6k1(n)
}

message(n)


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

price.tree <- function(numsteps, under.tree, opt.payoffs,
                       rf, delta.t, ups=0, downs=0) {
    if (numsteps > 0) {
        up.value <- price.tree(numsteps-1, under.tree, opt.payoffs,
                               rf, delta.t, ups+1, downs)
        down.value <- price.tree(numsteps-1, under.tree, opt.payoffs,
                                 rf, delta.t, ups, downs+1)
    } else {
        # We have reached a leaf; return the option payoff
        return(opt.payoffs[downs+1])
    }
    under.up.value <- under.tree[downs+1,ups+1+1]
    under.down.value <- under.tree[downs+1+1,ups+1]
    H <- (up.value-down.value)/(under.up.value-under.down.value)
    B <- (under.up.value*down.value - under.down.value*up.value)/
        (under.up.value - under.down.value)*exp(-rf*delta.t)
    H*under.tree[downs+1,ups+1] + B
}

rf <- 0.03  # 3% risk-free rates
sigma <- 0.45  # 45% volatility
T <- 1.25  # 15-month option
n.steps <- 16  # number of steps total
delta.t <- T/n.steps  # interpolated time step size
u <- exp(sigma*sqrt(delta.t))  # up move
d <- exp(-sigma*sqrt(delta.t))  # down move
s0 <- 100  # initial stock price
K <- 80  # strike price

## This creates a full matrix with the tree -- and steps beyond the tree
## in the lower-right triangle of the matrix.  Since this is an easy way
## to create the tree, we will just ignore the lower-right triangle.
underlier.tree <- s0*d^(0:n.steps)%*%t(u^(0:n.steps))
option.payoffs <- pmax(s0*u^(n.steps:0)*d^(0:n.steps) - K, 0)
price.tree(numsteps=n.steps, underlier.tree, option.payoffs, rf, delta.t)


url <- "https://ww2.amstat.org/publications/jse/datasets/fruitfly.dat.txt"
data <- read.table(url)
data <- data[, c(-1, -6)]

names(data) <- c("partners", "type", "longevity", "thorax")
par(mfrow = c(3, 2))
plot(data$thorax, data$longevity, col = data$partners, pch = data$type)

data0 <- data[data$partners == 0, ]
plot(data0$thorax, data0$longevity, col = data$partners, pch = data$type)

data1 <- data[data$partners == 1, ]
plot(data1$thorax, data1$longevity, col = data$partners, pch = data$type)

data8 <- data[data$partners == 8, ]
plot(data8$thorax, data8$longevity, col = data$partners, pch = data$type)

p0 <- as.integer(data$partners == 0)
p1t0 <- as.integer(data$partners == 1 & data$type == 0)
p1t1 <- as.integer(data$partners == 1 & data$type == 1)
p8t0 <- as.integer(data$partners == 8 & data$type == 0)
p8t1 <- as.integer(data$partners == 8 & data$type == 1)

data_dummy <- cbind(data, p0, p1t0, p1t1, p8t0, p8t1)
boxplot(cbind(data_dummy[data_dummy$p0 == 1, ]$longevity,
            data_dummy[data_dummy$p1t0 == 1, ]$longevity,
            data_dummy[data_dummy$p1t1 == 1, ]$longevity,
            data_dummy[data_dummy$p8t0 == 1, ]$longevity,
            data_dummy[data_dummy$p8t1 == 1, ]$longevity)
)

# use p0 as control group
fitfull <- lm(thorax ~ p1t0 + p1t1 + p8t0 + p8t1, data_dummy)
fitintercept <- lm(thorax ~ 1, data_dummy)
# not significant, so null hypothesis: model is the same should be acc.ed
print(anova(fitintercept, firfull))

reg_wo <- lm(longevity ~ type, data1)
print(summary(reg_wo))

reg_w <- lm(longevity ~ type + thorax, data1)
print(summary(reg_w))

reg_full_fail <- lm(longevity ~ thorax
                + as.factor(partners) * as.factor(type), data)

print(summary(reg_full_fail)) # some NA here, and most var are not significant

reg_full <- lm(longevity ~ thorax + p1t0 + p1t1 + p8t0 + p8t1, data_dummy)
print(summary(reg_full))

reg_reduce <- lm(longevity ~
                thorax +
                I(p1t0 - p8t1) +
                I(p1t1 + p8t1) +
                I(p8t0 + p8t1), data_dummy)
print(summary(reg_reduce))

print(anova(reg_reduce, reg_full))


#implemente uma das duas funções abaixo
#em ambas as funções, o parâmetro s contém ou só as abscissas dos pontos ou só as ordenadas
# por exemplo, se os pontos são (0, 2), (3, 4) e (7, 5)
# bezier será chamada com as abscissas, ou seja, com o vetor 0, 3, 7
# e também será chamada com as ordenadas, ou seja, com o vetor 2, 4, 5

#essa implementacao deve ser recursiva, sem uso de memoization
#retorna o ponto da curva bezier em t considerando os pontos Pa, ..., Pb
bezier1 <- function(s, a, b, t) {
	return(0)
}

#essa implementacao deve ser nao recursiva
#retorna o ponto da curva bezier em t considerando os pontos P1, ..., Plength(s)
bezier2 <- function(s, t) {
	return(0)
}

#abscissas dos pontos
xs <- c(1, 3, 5, 7, 8)
#ordenadas dos pontos
ys <- c(1, 4, 3, 0, 4)

ptsx = c()
ptsy = c()

#altere para bezier2 caso queira usar a segunda função bézier
for(t in seq(0,1,0.05)) {
	x = bezier1(xs, 1, length(xs), t)
	y = bezier1(ys, 1, length(ys), t)
	ptsx = c(ptsx, x)
	ptsy = c(ptsy, y)
	#escreve na tela t, x e y do ponto
	print(c(t, x, y))
}

plot(xs, ys, type='b', col='gray')
lines(ptsx, ptsy, type='l', col='blue')


spectralClustering <- function(affinity, K, type=3) {

  ###This function implements the famous spectral clustering algorithms. There are three variants. The default one is the third type.
  ###THe inputs are as follows:

      #affinity: the similarity matrix;
      #K: the number of clusters
      # type: indicators of variants of spectral clustering

  d = rowSums(affinity)
  d[d == 0] = .Machine$double.eps
  D = diag(d)
  L = D - affinity
  if (type == 1) {
    NL = L
  } else if (type == 2) {
    Di = diag(1 / d)
    NL = Di %*% L
  } else if(type == 3) {
    Di = diag(1 / sqrt(d))
    NL = Di %*% L %*% Di
  }
  eig = eigen(NL)
  res = sort(abs(eig$values),index.return = TRUE)
  U = eig$vectors[,res$ix[1:K]]
  normalize <- function(x) x / sqrt(sum(x^2))
  if (type == 3) {
    U = t(apply(U,1,normalize))
  }
  eigDiscrete = .discretisation(U)
  eigDiscrete = eigDiscrete$discrete
  labels = apply(eigDiscrete,1,which.max)

  return(labels)
}


# ---- installing the packages required for this assignment.
install.packages("ggplot2")
# ---- Enabling Libraries
library("ggplot2")

# --------------- Part 1 -------------------------------------------------------
# --------------- Import data into data frame
# ---- Data is downloaded from the link mentioned below
# ---- https://www.cso.ie/en/media/csoie/census/documents/saps2011files/AllThemesTablesCTY.csv

dataset <- read.csv("AllThemesTablesCTY.csv",
                    header = TRUE)

# --------------- EDA - Exploring data

dataset
nrow(dataset)
ncol(dataset)
head(dataset, n=10)
tail(dataset, n= 6)
str(dataset)

# I have taken out male populatin data from the entire dataset.
# 1:34 are rows and 1:37 are columns
subset <- dataset[c(1:34),c(4:37)]

# sum of all the counties to get the total figure
totalPopulation <- colSums (subset,
                            na.rm = FALSE,
                            dims = 1)

# --------------- Histogram - R
hist(subset$T1_1AGE0M,
     main="Distribution of Population for AGE = 0 Gender = Male",
     xlab="Population",
     col = 'skyblue3',
     breaks = 20,
     ylim = c(0,10),
     xlim = c(0,4000),
     las=1)

# --------------- Histogram GGPlot2

ggplot(subset, aes(T1_1AGE0M)) +
  geom_histogram( binwidth = 100,
                  colour = "black",
                  fill = "skyblue3") +
  ggtitle("Distribution of Population for AGE = 0 Gender = Male")+
  labs(x = "Population",
       y = "Frequency")

# ---------------- Scatter Plot - R
plot(subset$T1_1AGE0M,
     subset$T1_1AGE1M,
     xlab = "Age: 0 Gender: Male",
     ylab = "Age: 1 Gender: Male",
     main = "Correlation between 0 and 1 year old Male poplation distribution by county",
     col = "red")

# ---------------- Scatter Plot GGPLOT2
ggplot(subset,
       aes(T1_1AGE0M,T1_1AGE1M)) +
  geom_point(colour = "skyblue3",size = 4, alpha = 0.5)+
  geom_smooth(method="lm",color="darkred", size = 0.5, alpha = 0.2)+
  ggtitle("Correlation between 0 and 1 year old Male poplation distribution by county")+
  labs(x = "Age: 0 Gender: Male",
       y = "Age: 1 Gender: Male")

# ----------------- Part 2 -----------------------------------------------------
# ------------ Import data into data frame

customerSpend <- read.csv("Customer Spend.csv",
                          header = TRUE,
                          sep = ",")

# ------------ Promote First row as headers
# ----- Replace 'NA' with 'Year'
customerSpend[1,1] <- 'Year'
# ----- assign first row as names
names(customerSpend) <- customerSpend[1, ]
# ----- delete first row
customerSpend <- customerSpend[-c(1),]

# ------------ EDA - Exploring data

# ----- Objects can now be accessed by names.
# attach(customerSpend)
# ----- Print the data frame, number of rows & columns, first & last four rows,
# ----- and finally structure.
customerSpend
nrow(customerSpend)
ncol(customerSpend)
head(customerSpend, n = 4)
tail(customerSpend, n = 4)
str(customerSpend)

# ----- replacing ',' with an empty string and typecasting from data type -
# ----- character to numeric .
# ----- first column is not disturbed.
for ( colIndex in 1:8 ) {
  customerSpend[,colIndex] <- gsub("[[:punct:]]",
                                   '',
                                   customerSpend[,colIndex])
  customerSpend[,colIndex] <- as.numeric(customerSpend[,colIndex])
}
# ---- Years is declared as factor (earlier character)
customerSpend[,1] <- factor(customerSpend[,1])

# ------------ The R base graphics time series
customerSpendsts <- ts(customerSpend[,2:8],
                       start = 2009,
                       end = 2020,
                       frequency = 1)
class(customerSpendsts)
# ---- Plot the time series
ts.plot(customerSpendsts,main="Time series analysis of Customer spends",
        gpars = list(xlab="year",
                     ylab="sales value",
                     lty=c(1:7)))

# ------------ GGPlot2

# ---- setting high penalty for scientific display
options("scipen"=99)

# ---- time series using geom_line()
ggplot(data = customerSpend, aes(x = Year, group = 1)) +
  geom_line(aes(y = Cisco, color = "Cisco")) +
  geom_line(aes(y = Dell, color = "Dell"),linetype="twodash") +
  geom_line(aes(y = BSI, color = "BSI"),linetype="longdash") +
  geom_line(aes(y = Medtronic, color = "Medtronic"),linetype="dotted") +
  geom_line(aes(y = IBM, color = "IBM"),linetype="dotdash") +
  geom_line(aes(y = Microsoft, color = "Microsoft"),linetype="dashed") +
  geom_line(aes(y = Amazon, color = "Amazon"),linetype="F1") +
  scale_color_discrete(name = "Companies") +
  ggtitle("Time series analysis of Customer spends")+
  labs(y = "Companies Sales Value", x = "Year")

# ----------------- Part 3 -----------------------------------------------------
# ------------ working with map using basic R, ggplot2 AND leaflet library.

# ---- installing the packages required for this part and Enabling them.

install.packages("readxl")
library(readxl)

# ---- load the data
Cork_Towns <- read_excel("Cork Townlands.xlsx")
head(Cork_Towns)
str(Cork_Towns)

# ---- Filtering the data
Cork_Towns$LATITUDE <- round(Cork_Towns$LATITUDE, digits = 2)

Unique_Lats <- unique( Cork_Towns[ , 4 ] )

# ---- Create data frame Selected_Towns and initializing it with a single row.

# ---- Looping to get unique rows based on Latitude column
# ---- Create empty data frame
# ---- Based on the length of Unique_Lats nrow of data frame is selected
Selected_Towns <- data.frame(matrix(NA,
                                    nrow = 97,
                                    ncol = 5))

index <- 1

names(Selected_Towns) <- c("NAME_TAG","CO_NAME", "AREA", "LATITUDE","LONGITUDE")
str(Unique_Lats$LATITUDE)

for (value in c(1:length(Cork_Towns$NAME_TAG))) {
  if(Cork_Towns$LATITUDE[value] %in% Unique_Lats$LATITUDE)
  {
    Selected_Towns[index,1:5] <- Cork_Towns[value,1:5]
    for (lat_Index in c(1:length(Unique_Lats$LATITUDE))) {
      if(Selected_Towns$LATITUDE[index] == Unique_Lats$LATITUDE[lat_Index])
      {
        Unique_Lats$LATITUDE[lat_Index] <- 0
      }
    }
    index <- index + 1
  }
}

# ---- Longitude.

Selected_Towns$LONGITUDE <- round(Selected_Towns$LONGITUDE, digits = 2)

Unique_Longs <- unique( Selected_Towns[ , 5 ] )

# ---- Create data frame Selected_Towns and initializing it with a single row.

# ---- Looping to get unique rows based on Latitude column
# ---- Create empty data frame
# ---- Based on the length of Unique_Longs nrow of data frame is selected
Selected_Towns_Final <- data.frame(matrix(NA,
                                          nrow = 64,
                                          ncol = 5))

index <- 1

names(Selected_Towns_Final) <- c("NAME_TAG","CO_NAME", "AREA", "LATITUDE","LONGITUDE")
str(Unique_Longs)

for (value in c(1:length(Selected_Towns$NAME_TAG))) {
  if(Selected_Towns$LONGITUDE[value] %in% Unique_Longs)
  {
    Selected_Towns_Final[index,1:5] <- Selected_Towns[value,1:5]
    for (lat_Index in c(1:length(Unique_Longs))) {
      if(Selected_Towns_Final$LONGITUDE[index] == Unique_Longs[lat_Index])
      {
        Unique_Longs[lat_Index] <- 0
      }
    }
    index <- index + 1
  }
}

# ---- Long = East, Lat = North
range(Selected_Towns_Final$LATITUDE)
range(Selected_Towns_Final$LONGITUDE)
plot(y = c(51.2,52.5),
     x = c(-8.2,-9.88),
     type="n",
     xlab="Easting",
     ylab="Northing")

# ---- Towns name is displayed based on Eastings and northings
for (index in 1:length(Cork_Towns$NAME_TAG)) {
  text(Selected_Towns_Final$LONGITUDE[index],
       Selected_Towns_Final$LATITUDE[index],
       Selected_Towns_Final$NAME_TAG[index],cex=0.6)
}

# ---- Towns in qplot

qplot(LONGITUDE,
      LATITUDE,
      data=Selected_Towns_Final,
      geom="text",
      label=NAME_TAG,size=1,
      main = "Townlands of County Cork") +
      coord_equal() +
      labs(legend.position = "none")

# ---- Towns in ggplot

# ---- Town names is colored and sized based on respective Area

ggplot(Selected_Towns_Final,
       aes(x=LONGITUDE, y=LATITUDE)) +
       geom_text(aes(size=AREA,color=AREA, label=NAME_TAG)) +
       theme(legend.title = element_text("none")) +
       ggtitle("Townlands in Cork")

# ---- Town names is colored

ggplot(Selected_Towns_Final,
       aes(x=LONGITUDE, y=LATITUDE)) +
       geom_text(aes(color=NAME_TAG, label=NAME_TAG)) +
       theme(legend.position = "none") +
       ggtitle("Townlands in Cork")

# ------------ working with map using leaflet library.

# ---- installing the packages required for this part and Enabling them.

install.packages("leaflet")
library(leaflet)

# Show first 20 rows from `Cork_Towns` dataset

leaflet(data = Selected_Towns_Final) %>% addTiles() %>%
  addMarkers(~LONGITUDE,
             ~LATITUDE,
             popup = ~as.character(NAME_TAG),
             label = ~as.character(NAME_TAG))


ex1 = function()
{
	data = read.table("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\data\\alcool.dat", header=T, sep="", dec=".")

	#1
	x = data[,2]
	y = data[,3]
	plot(x, y, pch=20, main='Scatter plot alcohol',
		xlab='Median alcohol consumption',
		ylab='Hearth disease related deaths')

	#2
	#raw formula
	x_mean = mean(x)
	y_mean = mean(y)
	r = sum( (x-x_mean) * (y-y_mean) ) /
	    (sqrt(sum( (x-x_mean)^2 )) * sqrt(sum( (y-y_mean)^2 )))
	message("My formula's result: ", r)

	#r function
	message("R formula's result: ", cor(x,y))
}

ex2 = function()
{
	data = read.table("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\data\\iq.dat", header=T, sep="", dec=".")

	#1
	x = data[,2]
	y = data[,3]

	plot(x, y, pch=20, main='Scatter plot IQ',
		xlab='IQ',
		ylab='Grade')

	#2
	x_mean = mean(x)
	y_mean = mean(y)
	b1 = sum( (x-x_mean) * (y-y_mean) )/sum( (x-x_mean)^2 )
	b0 = y_mean - b1*x_mean
	abline(b0, b1, lwd=3, col='red')

	message("Grade estimate for 115 IQ: ", b0 + b1*115)
	message("Grade estimate for 130 IQ: ", b0 + b1*130)
}

ex3 = function(m, a, b, xmin, xmax, sigma)
{
	x = runif(m, min=xmin, max=xmax)
	e = rnorm(m, 0, sigma)
	y = a + b*x + e
	cbind(x, y)
}

ex4 = function(obs)
{
	x = obs[,1]
	y = obs[,2]

	x_mean = mean(x)
	y_mean = mean(y)
	b = sum( (x-x_mean) * (y-y_mean) )/sum( (x-x_mean)^2 )
	a = y_mean - b*x_mean

	y_estimate = a + b*x
	sse = sum( (y - y_estimate)^2 )
	s = sqrt(sse / (length(y) - 2))
	sb = s / sqrt(sum( (x-x_mean)^2 ))
	t = qt(0.975, df=(length(x) - 2))

	blow = b - t*sb
	bhigh = b + t*sb

	sa = sb*sqrt( sum(x^2) / length(x) )
	alow = a - t*sa
	ahigh = a + t*sa

	cbind(c(a,b), c(blow, bhigh), c(alow, ahigh))
}

plot_and_save = function(m, a, b, xmin, xmax, sigma, id)
{
	pdf(file=paste("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework3\\graphs\\graph_", id, ".pdf", sep=""),
		width=8, height=8
	)

	obs = ex3(m, a, b, xmin, xmax, sigma)
	res = ex4(obs)

	plot(obs[,1], obs[,2], pch=20,
		main=paste('a: ', res[1,1], ', b: ', res[2,1], '\n',
			'CI b: [', res[1,2], ' , ', res[2,2], ']\n',
			'CI a: [', res[1,3], ' , ', res[2,3], ']', sep=""),
		xlab='x',
		ylab='y')

	abline(a, b, lwd=3, col='red')
	abline(res[1,1], res[2,1], lwd=2, col='green')

	dev.off()
}

ex5 = function()
{
	#a
	plot_and_save(100, 10, 0.8, -200, 200, 1.5, 'a')

	#b
	plot_and_save(10, 10, 0.8, -5, 5, 1, 'b')

	#c
	plot_and_save(10000, 10, 0.8, -5, 5, 1, 'c')

	#d
	plot_and_save(10, 10, 0.8, 5, 5.2, 1, 'd')

	#e
	plot_and_save(10000, 10, 0.8, 5, 5.2, 1, 'e')

	#f
	plot_and_save(10, 10, 0.8, 5, 5.2, 0.01, 'f')

	'done'
}


# Predicting with trees by continuously sublitting the outcome to different groups until the group is homogenous, each time using a variable. E.g. Obama vs Clinton.

# 4. Algorithm:
#    1. Start with all variables in one group
#    2. Find best variable that splits the outcome
#    3. Divide the data into groups 'leaves' on that split 'node'
#    4. Within each split, find the best variable/split that separates outcome
#    5. Continue until groups are too small or sufficiently pure

# 5. Measure of impurity: with metrics like Gini index and Deviance/information gain

# 6. An example of good split with 15 to 1 against a bad one of 8 to o

# 7. Example: Iris Data
install.packages("iris")
library(iris)
library(ggplot2)

names(iris)

table(iris$Species)

# 9. Create training and test sets
inTrain <- createDataPartition(y=iris$Species, p=0.7, list=FALSE)
training <- spam[inTrain, ]
testing <- spam[-inTrain, ]

dim(training); dim(testing)

# 10. Iris petal widths/sepal width
# Plot the variables against each other
# Notice for the color we provide 'Species' a discrete variable, you will notice it is a clustering problem rather than linear models
qqplot(Petal.Width, Sepal.Width, colour=Species, data=training)

# 11. Iris petal widths/sepal width
library(caret)
# use caret for building the model, with method 'rpart' which is R package for doing classification and regression trees
modFit <- train(Species ~ ., method="rpart", data=training)
# it outputs the nodes and different model splits to understand what the tree is doing
print(modFit$finalModel)

# 12. Plot tree: we can also visualize the tree in a dandergram
plot(modFit$finalModel, uniform=TRUE, main="Classification Tree")
text(modFit$finalModel, use.n=TRUE, all=TRUE, cex=.8)

# 13. Prettier plots: display a colored and more readable dandergram
library(rattle)
fancyRpartPlot(modFit$finalModel)

# 14. Predicting new values: here predicting a class/category for a given input
predict(modFit, newdata=testing)

# 15. Notes and Futher resources:
# Transaformations (e.g. normalizing) may not be useful unless you modify the order of the variables. Trees can also be used for regression problems (continuous outcome).
# Books
#  - Introduction to statistial learning http://www-bcf.usc.edu/~gareth/ISL
#  - Elements of Statistical learning http://statweb.stanford.edu/~tibs/ElemStatLearn/
#  - Classification and Regression Trees - Leo Breiman (Amazon)


# Source: Mollet and Cailliet 2002. Mar Freshwater Res. Comparative population
# demography of elasmobranch using life history tables, Leslie matrices and
# stage-based matrix models

rm(list=ls(all=TRUE)) # removes all previous material from R's memory

# Define a function to compute basic demographic parameters
basic_demographic_parameters <- function(M) {

  # finite growth rate (max eigenvalue)
  vM     <- eigen(M);
  lambda <- Re(vM$values[1]);       # Real part of the first eigenvector

  # population structure, i.e., the normalized right eigenvector
  # associated to the maximum eigenvalue
  ps  <-  Re(vM$vectors[,1]);
  ps  <-  ps / sum(ps);             # normalize

  # reproductive value, i.e, the left eigenvector associated to the
  # maximum eigenvalue (it is computed as the right eigenvector of the
  # transposed matrix)
  rv  <-  Re(eigen(t(M))$vectors[,1]);
  rv  <-  rv / rv[1];               # standardize relative to 1st class

  #Sensitivity and elasticity
  sens <- outer(rv,ps) / sum(rv*ps) # sensitivity
  elas <- (sens*M) / lambda         # elasticity [%]

  return(list(lambda=lambda, ps=ps, rv=rv, elast=elas))

}

#############################################################################
# let's look first at the full matrix

# create a 10x10 matrix and assign 0 to all the elements
transM <- matrix(nrow=10, ncol=10, byrow=TRUE, data=0)

# set reproductive rate
# Only age 3 and older reproduce
for (j in 3:10) transM[1,j] <- 1.8929

# set survivals
# Fill in the sub-diagonal for ages 1-9
for (j in 1:9) transM[j+1,j] <- 0.631

#check the transition matrix
transM

#plot the transition matrix
image(1:nrow(transM), 1:ncol(transM), t(transM), ylim =c(ncol(transM)+0.5, 0.5) )

# Call our function
bdp_transM_L <- basic_demographic_parameters(transM); bdp_transM_L

sum(bdp_transM_L$ps[3:10])

image(1:nrow(bdp_transM_L$elas), 1:ncol(bdp_transM_L$elas), t(Mod(bdp_transM_L$elas)), ylim =c(ncol(transM)+0.5, 0.5))

#############################################################################
# let's now look  at the reduced matrices

reducedM <- matrix(nrow=3, ncol=3, byrow=TRUE,
  data<-c(    0,     0, 1.8929,
         0.631,     0,     0,
	         0,  0.631, 0.6272))

basic_demographic_parameters(reducedM)

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

reduced2M <- matrix(nrow=2, ncol=2, byrow=TRUE,
  data<-c(    0.4104,     1.8929,
             0.2206,     0.6272))

basic_demographic_parameters(reduced2M)

age_size/3_Mollet and Cailliet 2002. Mar Freshwater Res. Comparative.r