# Working with data summarizing and grouping

# 1. Summarize - basics
library(gapminder)
library(dplyr)

# Summarize to find the median life expectancy
gapminder %>%
    summarize(medianLifeExp = median(lifeExp))

# Filter for 1957 then summarize the median life expectancy
gapminder %>%
    filter(year == 1957) %>%
    summarize(medianLifeExp = median(lifeExp))

# Filter for 1957 then summarize the median life expectancy and the maximum GDP per capita
gapminder %>%
    filter(year == 1957) %>%
    summarize(medianLifeExp = median(lifeExp),
            maxGdpPercap = max(gdpPercap))

# 2. Group by
# Find median life expectancy and maximum GDP per capita in each year
gapminder %>%
    group_by(year) %>%
    summarize(medianLifeExp = median(lifeExp),
            maxGdpPercap = max(gdpPercap))

# Find median life expectancy and maximum GDP per capita in each continent in 1957
gapminder %>%
    filter(year == 1957) %>%
    group_by(continent) %>%
    summarize(medianLifeExp = median(lifeExp),
            maxGdpPercap = max(gdpPercap))

# Find median life expectancy and maximum GDP per capita in each continent/year combination
gapminder %>%
    group_by(continent, year) %>%
    summarize(medianLifeExp = median(lifeExp),
            maxGdpPercap = max(gdpPercap))

# 3. Visualize the summary tables
library(gapminder)
library(dplyr)
library(ggplot2)

# Summarize the data
by_year <- gapminder %>%
  group_by(year) %>%
  summarize(medianLifeExp = median(lifeExp),
            maxGdpPercap = max(gdpPercap))

# Create a scatter plot showing the change in medianLifeExp over time. expand_limits: provides capability to set origin
ggplot(by_year, aes(x = year, y = medianLifeExp)) +
  geom_point() +
  expand_limits(y = 0)

# Summarize medianGdpPercap within each continent within each year: by_year_continent
by_year_continent <- gapminder %>%
                        group_by(continent, year) %>%
                        summarize(medianGdpPercap = median(gdpPercap))

# Plot the change in medianGdpPercap in each continent over time
ggplot(by_year_continent, aes(x = year, y = medianGdpPercap, color = continent)) +
    geom_point() +
    expand_limits(y = 0)

# Summarize the median GDP and median life expectancy per continent in 2007
by_continent_2007 <- gapminder %>%
                        filter(year == 2007) %>%
                        group_by(continent) %>%
                        summarize(medianGdpPercap = median(gdpPercap),
                            medianLifeExp = median(lifeExp))

# Use a scatter plot to compare the median GDP and median life expectancy
ggplot(by_continent_2007, aes(x = medianGdpPercap, y = medianLifeExp, color = continent)) +
    geom_point()


# matrice

elementi <- c(2,4,3,1,5,7)
prva <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = TRUE)
prva

druga <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = FALSE)
druga

treca <- matrix( elementi,
                 nrow = 2,
                 ncol =3)
treca

# indeksiranje
na.poziciji.2.2 <- druga[2,2]
na.poziciji.2.2

prva
prva.vrsta.od.prva <- prva[1,]
prva.vrsta.od.prva
druga.kolona.od.prva <- prva[,2]
druga.kolona.od.prva

matrica.A <- matrix(
  c(1,2,3,4,5),
  nrow = 4,
  ncol = 3)
matrica.A

podmatrica.A <- matrica.A[c(2,4), c(1,3)]
podmatrica.A

zamenili.prvu.i.trecu.kolonu <- matrica.A[,c(3,2,1)]
zamenili.prvu.i.trecu.kolonu

matrica.A[2,2] <- 22
matrica.A

matrica.A[2,] <- c(7,8,9)
matrica.A

matrica.A[,2] <- c(0.5,1.5)
matrica.A

matrica.A <- matrix(
  c(1,2,3,4,5,6),
  nrow = 4,
  ncol = 3)
matrica.A
dimnames(matrica.A) <- list(
  c("najvisa","skoro najvisa", "skoro najniza", "najniza"),
  c("prva", "druga", "treca")
  )
matrica.A

treca.vrsta.matrice.A <- matrica.A["skoro najniza",]
treca.vrsta.matrice.A

# operacije nad matricama
elementi <- c(2,4,3,1,5,7)
prva <- matrix( elementi,
                nrow = 2,
                ncol =3,
                byrow = TRUE)
prva
druga <- matrix( elementi,
                 nrow = 2,
                 ncol =3,
                 byrow = FALSE)
druga
zbir <- prva + druga

prva
transponovana.prva <- t(prva)
transponovana.prva

prva
druga
spojene.po.koloni <- cbind (prva, druga)
spojene.po.koloni

prva
druga
spojene.po.vrsti <- rbind (prva, druga)
spojene.po.vrsti


#' Scaling data
#'
#' @description Rescale data
#'
#' @param x numeric vector
#' @param lim_inf numeric value of the inferior limit (0 by default)
#' @param lim_sup numeric value of the superior limit (1 by default)
#'
#' @return numeric vector
#'
#' @export
#'
#' @examples
#'
#' x <- seq(-3,3,l = 100)
#'
#' range(x)
#'
#' y <- scale01(x)
#'
#' range(y)
#'
#' plot(x,y)
#'

scale01 <- function(x, lim_inf = 0, lim_sup = 1){

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(length(x) == 1){
    stop("length of x must be > 1")
  }

  if(is.numeric(lim_sup) == F){
    stop("lim_sup must be numeric")
  }

  if(is.numeric(lim_inf) == F){
    stop("lim_inf must be numeric")
  }

  if(length(lim_sup) != 1){
    stop("lim_sup must be just one numeric value")
  }

  if(length(lim_inf) != 1){
    stop("lim_inf must be just one numeric value")
  }

  if(lim_sup <= lim_inf){
    stop("lim_sup must be > lim_inf")
  }

  max_x <- max(x, na.rm = T)

  min_x <- min(x, na.rm = T)

  out <- (lim_sup-lim_inf) * ((x - min_x)/(max_x - min_x)) + lim_inf

  return(out)
}


# Vectors for budget and intl. box office for Avengers films (in millions)
avengers <- c(225, 1515)
ultron <- c(365, 1395)
infinity_war <- c(300, 2044)
endgame <- c(400, 2797)

# Column and row names
mat_titles <- c("Budget", "Box Office")
film_titles <- c("The Avengers", "Age of Ultron", "Infinity War", "Endgame")

# Matrix including film titles, budget and intl. box office
films <- matrix(c(avengers, ultron, infinity_war, endgame), byrow = TRUE, nrow = 4, dimnames = list(film_titles, mat_titles))

# Films matrix now including total budget and intl. box office amounts
Totals <- colSums(films)
final_films <- rbind(films, Totals)

# Calculating mean values for budget and intl. box office
budget <- films[, 1]
boxoffice <- films[, 2]
mean_budget <- mean(budget)
mean_boxoffice <- mean(boxoffice)


library(gbm)
library(e1071)
library(randomForest)
library(tree)
library(glmnet)

set.seed(10000)

## generate training data
n = 100
p = 500
xa = matrix(rnorm(n*5),ncol=5)
xb = matrix(rnorm(n*5,1.5,1),ncol=5)
x1 = rbind(xa,xb)
x2 = matrix(rnorm(2*n*(p-5)),ncol=(p-5))
x  = cbind(x1,x2)
y = c(rep(0,n),rep(1,n))
x.tr = x
y.tr = y
data.tr = as.data.frame(cbind(y.tr,x.tr)) ## gbm requires the data to be input as a dataframe

## only first 5 variables are important for classification
## check the importance using t.test
t.test(x.tr[1:n,1], x.tr[-(1:n),1])
t.test(x.tr[1:n,10], x.tr[-(1:n),10])

## generate test data
n = 1000
p = 500
xa = matrix(rnorm(n*5),ncol=5)
xb = matrix(rnorm(n*5,1.5,1),ncol=5)
x1 = rbind(xa,xb)
x2 = matrix(rnorm(2*n*(p-5)),ncol=(p-5))
x  = cbind(x1,x2)
y = c(rep(0,n),rep(1,n))
x.te = x
y.te = y
data.te = as.data.frame(cbind(y.te,x.te))

## Fit boosting

## Use adaboost loss (exponential loss) with additive model. Conduct 10-fold CV
fit1 = gbm(y.tr~., n.trees=10000, distribution='adaboost', interaction.depth = 1, cv.folds=10, data=data.tr)

## Output the cv-errors.  This is NOT misclassificaiton error
fit1$cv.error

## Find the best iteration number
best.iter <- gbm.perf(fit1, method="cv")

## Prediction on test set
pred1 = (predict(fit1, data.te, n.trees=best.iter)>0)*TRUE

## Calculate misclassification error on test data
mean(pred1!=y.te)

## report the importance score of variables
summary(fit1)

## Use logistic loss
fit1a = gbm(y.tr~., n.trees=10000, distribution='bernoulli', interaction.depth = 1, cv.folds=10, data=data.tr)
best.iter <- gbm.perf(fit1a, method="cv")
pred1a = (predict(fit1a, data.te, n.trees=best.iter)>0)*TRUE
mean(pred1a!=y.te)

## Use two-way interaction model
fit2 = gbm(y.tr~., n.trees=10000, distribution='adaboost', interaction.depth = 2, cv.folds=10, data=data.tr)
fit2$cv.error
best.iter <- gbm.perf(fit2, method="cv")
pred2 = (predict(fit2, data.te, n.trees=best.iter)>0)*TRUE
mean(pred2!=y.te)
summary(fit2)

## Fit SVM

## Select the best cost parameter with linear kernel
tune1 = tune(svm, train.x=as.matrix(x.tr), train.y=as.factor(y.tr), kernel='linear', range=list(cost=2^seq(-5,5,length=100)),
	control=tune.control(sampling='cross', cross=10))

## Fit the "optimal" SVM
fit1.svm = svm(x.tr, as.factor(y.tr), kernel='linear', cost=0.03125)

## Prediction on test data
pred1.svm = predict(fit1.svm, x.te)
mean(pred1.svm!=y.te)

## Select the best cost parameter with radial kernel (Gaussian kernel)
## The tuning can take a long time, because there are two parameters to tune.
tune2 = tune(svm, train.x=as.matrix(x.tr), train.y=as.factor(y.tr), kernel='radial', range=list(cost=2^seq(-5:5), gamma=2^(-5:5)), control=tune.control(sampling='cross', cross=10))
fit2.svm =  svm(x.tr, as.factor(y.tr), kernel='radial', cost=2, gamma=0.03125)
pred2.svm = predict(fit2.svm, x.te)
mean(pred2.svm!=y.te)

## Fit randomforest

## Try different mtryStart values manually
tune.rf = tuneRF(x=x.tr, y=as.factor(y.tr), ntree=1000, mtryStart=10, stepFactor=1, nodesize=10)

## Fit the model
fit.rf  = randomForest(x=x.tr, y=as.factor(y.tr), ntree=1000, mtry=10, nodesize=10, importance=T)
pred.rf = predict(object=fit.rf, newdata=x.te, type='prob')
mean((pred.rf[,1]<.5)!=y.te)

## Get the variable importance score
varimp = varImpPlot(fit.rf)

## Fit classification trees
newx.tr = data.frame(cbind(y.tr, x.tr))
newx.te = data.frame(cbind(y.te, x.te))
fit.tree = tree(as.factor(y.tr)~., data=newx.tr)
summary(fit.tree)
plot(fit.tree)
text(fit.tree)
pred1.tree = predict(fit.tree,newx.te,type="class")
mean(pred1.tree!=y.te)

## Prune the fitted tree
cvtree = cv.tree(fit.tree ,FUN=prune.misclass )
cvtree
prunedtree = prune.misclass(fit.tree, best=4)
summary(prunedtree)
plot(prunedtree)
text(prunedtree)
pred2.tree = predict(prunedtree,newx.te,type="class")
mean(pred2.tree!=y.te)

## Fit LASSO-logistic regression

## Select lambda using 10-fold CV
cv.lasso = cv.glmnet(x.tr, y.tr, family='binomial', nfolds=10)
lambda.min = cv.lasso$lambda.min
lambda.1se = cv.lasso$lambda.1se ## Result in a sparser model

## Fit the final model with lambda.min
fit.min = glmnet(x.tr, y.tr, family='binomial', lambda=lambda.min)
fit.min$a0 ## intercept
fit.min$beta ## betahat in logistic regression
pred.min = predict(fit.min, x.te, type='class')
mean(pred.min!=y.te)

## Fit the final model with lambda.1se
fit.1se = glmnet(x.tr, y.tr, family='binomial', lambda=lambda.1se)
fit.1se$a0 ## intercept
fit.1se$beta ## betahat in logistic regression
pred.1se = predict(fit.1se, x.te, type='class')
mean(pred.1se!=y.te)

stat998- Statistical Consulting (001) - 3-18-2015 - 10-06 AM/content/enforced/2756218-stat998_001_sp15/classification.r


data(trees)
str(trees)
summary(trees)

pairs(trees, panel = panel.smooth)

plot(Volume ~ Girth, data = trees, log = "xy",xlab="LogGirth" ,ylab="LogVolume")

coplot(log(Volume) ~ log(Girth) | Height, data = trees,
                                  panel = panel.smooth)

library(earth)

MARSModel <- earth(Volume ~ ., data = trees)

summary(MARSModel)

EvimpMD<-evimp(MARSModel)
EvimpMD

plot(MARSModel,legend.pos=NA)

PredMARSModel <- predict(MARSModel, trees)
# summarize accuracy
mse1 <- mean((trees$Volume - PredMARSModel)^2)
print(mse1)

LMModel <- lm(Volume ~ ., data = trees)
PredLMModel <- predict(LMModel, trees)
mse2 <- mean((trees$Volume - PredLMModel)^2)
print(mse2)


library(glue)
library(gtools)
printf <- defmacro(str, expr = {print(glue(str))})

misclass <- function(x, x_){
  n=length(x)
  return(1-sum(diag(table(x,x_)))/n)
}

cross_entropy_loss <- function(y,y_hat){
  return((-1/length(y))*sum(y*log(y_hat)))
}

# import data and split
data = read.csv("optdigits.csv")
colnames(data) <- c(1:64, "y")

n = dim(data)[1]
set.seed(12345)
id = sample(1:n, floor(n*0.5))
train = data[id,]

id1 = setdiff(1:n, id)
set.seed(12345)
id2 = sample(id1, floor(n*0.25))
valid = data[id2,]

id3 = setdiff(id1,id2)
test = data[id3,]

# Finding the optimal K for the KKNN model over K=1:30
misclass.train = c()
misclass.valid = c()
cross_entropy = c()

for (K in 1:30){

  # train
  kknn.train = kknn::kknn(as.factor(y)~., train, train, k=K, kernel="rectangular")
  fit.train = fitted(kknn.train)
  misclass.train[K] <- misclass(train$y, fit.train)

  #valid
  kknn.valid = kknn::kknn(as.factor(y)~., train, valid, k=K, kernel="rectangular")
  fit.valid = fitted(kknn.valid)
  misclass.valid[K] <- misclass(valid$y, fit.valid)

  logic_matrix <- (col(kknn.valid$prob) == (valid$y+1))
  cross_entropy[K] <- (-1/ length(valid$y))*sum(log(1e-15 + as.numeric(kknn.valid$prob[logic_matrix])))
}

plot.default(1:30, misclass.valid, ylim=c(0,0.07), col="red", xlab = "K")
points.default(1:30, misclass.train, col="blue")
legend("topright", c("valid ", "train "), fill=c("red", "blue"))

printf("best min classifecation of validation set is K={which.min(misclass.valid)}")
plot(1:length(cross_entropy), cross_entropy, type = "b")
printf("Cross entropy: K={which.min(cross_entropy)}")

kknn = kknn::kknn(as.factor(y)~., train, test, k=which.min(cross_entropy), kernel="rectangular")
fit.cross = kknn$fitted.values
misclass.cross = misclass(test$y, fit.cross)

# Using optimal K for KKNN
kknn = kknn::kknn(as.factor(y)~., train, test, k=which.min(misclass.valid), kernel="rectangular")
fit = kknn$fitted.values
print(table(test$y, fit))

error.test <- misclass(test$y, fit)
error.valid <- misclass.valid[which.min(misclass.valid)]
printf("test error for optimal k, error:{error.test}")
printf(" differences from validation and test, error delta:{error.test - error.valid}")

kknn = kknn::kknn(as.factor(y)~., train, train, k=which.min(misclass.valid), kernel="rectangular")

# Grab all cases where the model thinks there is a 8.
all_eights <- which(train$y == 8)
our_guesses = c()
for(i in 1:length(all_eights)){
  our_guesses[i] = kknn$prob[all_eights[i], "8"]
}
hardest_train_cases <- order(our_guesses, decreasing = FALSE)[1:3]
easiest_train_cases <- order(our_guesses , decreasing = TRUE)[1:2]
all_eights[hardest_train_cases]
all_eights[easiest_train_cases]

# create a heatmap for the hardest and easiest case.
for (i in 1:3){
  hard <- t(matrix(unlist(train[all_eights[hardest_train_cases][i], 1:64]), nrow=8, ncol=8))
  heatmap(hard, Colv=NA, Rowv=NA, main="hard")
}
for (i in 1:2){
  easy <- t(matrix(unlist(train[all_eights[easiest_train_cases][i], 1:64]), nrow=8, ncol=8))
  heatmap(easy, Colv=NA, Rowv=NA, main="easy")
}


#  the rank sum test
Methodist=c(62,60,60,25,24,23,20,13,12,6)
Catholic=c( 62,62,24,24,22,20,19,10,8,8)
Pentecostal=c(37,31,15,15,14,14,14,5,3,2 )
n=30
data.value <- c( Methodist,Catholic,Pentecostal)

data.rank <- rank(data.value)
data <- data.frame(data.value, data.rank)
print(data)
 Sumofranks=c(182.5,167.5,115)
 #test statistic
 H=(12/(n*(n+1)))*((Sumofranks[1]^2+Sumofranks[2]^2+Sumofranks[3]^2)/10)-3*(n+1)
 print(H)


# P-valueBasics.r
#
# Using R to create a null distribution for a fair coin
# and calculate a p value for an event
#

# Use a function to generate the coin flips

# 0 = Tails and 1 = Heads

FlipCoin <- function(n) sample(0:1,n,rep=T)

heads <- FlipCoin(20) # to start calculation

# Flip the 20 coins 10000 times

for(i in 1:10000) heads[i] <- sum(FlipCoin(20)==1)

hist(heads, main="Number of heads out of 20 tosses")

histinfo <- hist(heads)

print(histinfo)

# Use the Binomial Distribution to work out the probability of
# getting 16 heads out of 20 flips of a fair coin

binomial <- dbinom(16, size=20, prob=0.5) + dbinom(17, size=20, prob=0.5) + dbinom(18, size=20, prob=0.5) + dbinom(19, size=20, prob=0.5) + dbinom(20, size=20, prob=0.5)

print(binomial)


## 1. Condition vs Intersection ##

p_m <- 515/2000
p_m_given_l <- 32/90
p_m_and_l <- 32/2000

p_l <- 90/2000
p_m_or_l <- p_m + p_l - p_m_and_l

## 2. Conditional Probability & Complements ##

p_b_given_m <- 0.1486
p_c_given_l <- 0.0928
p_non_b_given_c <- 0.7622
p_non_b_given_m <- 1 - p_b_given_m
p_non_c_given_l <- 1 - p_c_given_l
p_b_given_c <- 1 - p_non_b_given_c

## 3. Distinguishing Between Event and Condition ##

p_m_given_non_l <- 483/1910
p_non_l_given_m <- 483/515
p_m_and_non_l <- 483/2000
p_non_l_and_m <- 483/2000

## 4. More On Intersection Probabilities ##

p_ram <- 0.0822
p_gl <- 0.0184
p_ram_given_gl <- 0.0022
p_gl_and_ram <- p_gl * p_ram_given_gl
p_non_ram_given_gl <- 1 - p_ram_given_gl
p_gl_and_non_ram <- p_gl * p_non_ram_given_gl
p_gl_or_ram <- p_gl + p_ram - p_gl_and_ram

## 5. Conditional Probability and Independence ##

k_and_l <- 'independent'
l_and_m <- 'independent'
k_and_m <- 'dependent'

## 6. Dependent Events ##

# Exercise 1 & 2
l_and_m <- 'dependent'
l_and_non_m <- 'dependent'

# Exercise 3
p_l <- 90/2000
p_m_given_l <- 32/90
p_l_and_m <- p_l * p_m_given_l

# Exercise 4
p_not_m_given_l <- 58/90
p_l_and_non_m <- p_l * p_not_m_given_l

## 7. Independence for Three Events ##

p_et <- 0.0432
p_ac <- 0.0172
p_ps <- 0.0236
p_et_and_ps <- p_et * p_ps
p_et_and_ac <- p_et * p_ac
p_ac_and_ps <- p_ac * p_ps
p_et_and_ac_and_ps <- p_et * p_ac * p_ps

Data Analyst in R/Step 5 - Probability and Statistics/4. Conditional Probability in R/2. Conditional Probability Intermediate.r


ex1 = function(a, b)
{
	plot(log2, a, b, col="red", lwd=2, main = "f(x)= log2 x, x in [a,b]")
}

ex2 = function()
{
	for(pr in c(0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9))
	{
		pdf(file=
			paste("D:\\Facultate\\Capitole Speciale de Inteligenta Artificiala\\homework2\\plots\\binom_", pr, ".pdf", sep=""),
			width=4, height=4
		   )

		x = 0:20
		plot(x, dbinom(x, size=20, prob=pr),
     		     	type="h",
     			main=paste("Binomial Distribution (n=20, p=", pr, ")", sep=""),
     			ylab="Probability",
     			xlab ="# Successes",
     			lwd=3)
		dev.off()
	}
}

ex3 = function()
{
	x = seq(-7, 7, .1)
	y = dnorm(x, mean=0, sd=.5)
	plot(x, y, type="l", col="red", lwd=2)
	par(new=T)
	y = dnorm(x, mean=0, sd=1)
	plot(x, y, type="l", col="green", lwd=2, yaxt='n', xaxt='n')
	par(new=T)
	y = dnorm(x, mean=0, sd=2)
	plot(x, y, type="l", col="blue", lwd=2, yaxt='n', xaxt='n')
}

CLT = function(n)
{
	vret = vector("double", 1000)
	for(i in 1:1000)
	{
		v = runif(n, 0, 20)
		vret[i] = mean(v)
	}
	vret
}

ex3b = function()
{
	par(mfrow=c(2,2))

	for(n in c(1, 5, 10, 100))
	{
		y = CLT(n)
		hist(y, nclass=50, col="red", main=paste("Histogram uniform of", n))
	}

}

CLT2 = function(n)
{
	vret = vector("double", 1000)
	for(i in 1:1000)
	{
		v = rbinom(n, 20, 0.1)
		vret[i] = mean(v)
	}
	vret
}

ex3c = function()
{
	par(mfrow=c(2,2))

	for(n in c(1, 5, 10, 100))
	{
		y = CLT2(n)
		hist(y, nclass=50, col="blue", main=paste("Histogram binomial of", n))
	}
}


# -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
# Compuationally verifying that the t distribution with n df is generated from
# the sampling distribution of the mean of (n+1) samples from a normal distribution.
# (specifically, it is the distribution of sqrt(n+1)*(xbar - mu)/S)
# -+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+

# To derive the t distribution from here, we need to multiply numerator and denominator
# by sigma and rearrange to get ((xbar - mu)/((sigma^2)/sqrt(n))) / sqrt((S^2)/(sigma^2))
# Then for this fraction, the top is ~ Z, the bottom is ~ sqrt(chisq(n-1)/n-1).

# Please be aware that due to some quirk in the calculation of the kernel density, one finds
# that the area under the curve can increase as the number of points -> Inf. Clearly this
# contravenes the laws of probability. It can be largely rectified by specifying the number of
# points to estimate at (argument n). HOWEVER, I'm finding an intermittent bug whereby the
# density function is still plotting too large an area under the curve / not accepting the
# n argument. The code is as-is, and if it happens, I suggest simply re-plotting.

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function definitions

# Function to plot the theoretical distribution - to compare against
plot.analytic <- function(pdf, xlim = c(-3,3), ylim = c(0,0.5), res = 100, line.only = F, ...) {
    if(!is.vector(xlim) | !is.numeric(xlim) | !(length(xlim)==2)) stop("xlim must be limits of x axis")
    if(!is.vector(ylim) | !is.numeric(ylim) | !(length(ylim)==2)) stop("ylim must be limits of y axis")
    if(!is.function(pdf)) stop("pdf must be given as the density function of the distribution")
    sx <- seq(xlim[1], xlim[2], length.out = res)
    px <- pdf(sx, ...)
    if(!line.only) plot(sx, px, type="l", ylim=ylim, xlab = "X", ylab = "Density") else {
        lines(sx, px)
    }
}

# Function that simulates the sampling distribution for x_bar.
xbar_smp <- function(rng=rnorm, n = 1000, size = 10, xlim = NULL, ylim = c(0,0.5), line.only = T, ...) {

    #Generate n samples of size 'size' (rng = random number generator specified)
    smp <- matrix(rng(n*size, ...), n, size)
    #Sample mean
    xbar <- rowSums(smp)/size
    #Sample sd (avoiding apply for efficiency reasons)
    S <- sqrt(rowSums(smp^2)/(size-1) - (xbar^2)*(size/(size-1)))

    #Standardise
    xbar <- (xbar - mean(xbar))/(S/sqrt(size))

    #Plot
    if(!line.only & is.null(xlim)) {
        plot(density(xbar, n=n), ylim=ylim, col = 2, xlab = "X", ylab = "Density")
    } else if(!line.only & !is.null(xlim)) {
        plot(density(xbar, n=n), xlim = xlim, ylim=ylim, col = 2, xlab = "X", ylab = "Density")
    } else {
        lines(density(xbar, n=n), col = 2)
    }
    invisible(xbar)
}

# Function that simulates the distribution of (S2.x/var.x)/(S2.y/var.y)
# Note that (n-1)S2x/varx ~ Chisq(n-1), so the above is the ratio of two
# Chisq distributions with (possibly) different dfs.

S2_ratio_smp <- function(n = 1000, size = 10, var.x = 1, var.y = 1, mean.x = 0, mean.y = 0,
                         rng=rnorm, xlim = NULL, ylim = c(0,0.8), line.only = T) {

    #Generate n samples of size 'size' (rng = random number generator specified)
    smp.x <- matrix(rng(n*size, mean.x, sqrt(var.x)), n, size)
    smp.y <- matrix(rng(n*size, mean.y, sqrt(var.y)), n, size)

    #Sample mean
    x.bar <- rowSums(smp.x)/size
    y.bar <- rowSums(smp.y)/size
    #Sample sd (avoiding apply for efficiency reasons)
    S2.x <- rowSums(smp.x^2)/(size-1) - (x.bar^2)*(size/(size-1))
    S2.y <- rowSums(smp.y^2)/(size-1) - (y.bar^2)*(size/(size-1))

    #Test statistic
    results <- (S2.x/S2.y)/(var.x/var.y)

    #Plot
    if(!line.only & is.null(xlim)) {
        plot(density(results, n=n), ylim=ylim, col = 3, xlab = "X", ylab = "Density")
    } else if(!line.only & !is.null(xlim)) {
        plot(density(results, n=n), xlim = xlim, ylim=ylim, col = 3, xlab = "X", ylab = "Density")
    } else {
        lines(density(results, n=n), col = 3)
    }
    invisible(results)
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# t - distribution:
# -----------------
# Plot theoretical cauchy distribution / t distribution with 1 df.
# It is immediate from the definition that the two distributions are the same.
plot.analytic(dt, df = 1, xlim = c(-10,10))

# Plot density generated from 5,000 samples of size 2 from a standard normal dist.
# Should be distributed close to the theoretical distn plotted in black
xbar_smp(size = 2, n = 10000)
# Increase sample sizes (df) for the sampling distn of xbar
xbar_smp(size = 10, n = 10000)
xbar_smp(size = 20, n = 10000)

# Plot theoretical standard normal distribution
plot.analytic(dnorm, line.only = T)

# F - distribution:
# -----------------

# Simulate F distribution with sample size of 10
smp_size <- 10
S2_ratio_smp(n = 100000, size = smp_size, xlim = c(0,10), line.only = F)
# Verifying that changing the mean/variance makes 0 difference
S2_ratio_smp(n = 100000, size = smp_size, mean.x = 1000, xlim = c(0,10), line.only = F)
S2_ratio_smp(n = 100000, size = smp_size, mean.x = 1000, var.x = 10, xlim = c(0,10), line.only = F)

# Compare to theoretical (black line)
plot.analytic(df, df1 = smp_size-1, df2 = smp_size-1, line.only = T)

# Compare distribution of different sample sizes
S2_ratio_smp(n = 100000, size = 4, xlim = c(0,10), ylim = c(0,1), line.only = F)
S2_ratio_smp(n = 100000, size = 7, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 10, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 20, xlim = c(0,10), line.only = T)
S2_ratio_smp(n = 100000, size = 40, xlim = c(0,10), line.only = T)
plot.analytic(df, df1 = 39, df2 = 39, line.only = T)

# Compare summary of different distributions
smp_size <- c(4,7,10,20,40)
results <- sapply(1:length(smp_size), function(x) S2_ratio_smp(n = 100000, size = smp_size[x], line.only = T))
results <- noquote(format(apply(results, 2, function(x) {op <- c(mean(x), var(x))
                        names(op) = c("Mean","Var"); op}), digits = 2))
colnames(results) <- paste("|smp|", smp_size, sep = " = ")
print(results)

# As expected, mean -> 1. Variance of distribution looks to be -> 0 as n -> +Inf

S2_ratio_smp(n = 100000, size = smp_size, var.x = 10, xlim = c(0,10), line.only = F)
debugonce(S2_ratio_smp)
S2_ratio_smp(n = 100000, size = smp_size, var.x = 10, xlim = c(0,10), line.only = F)


# installing required packages
install.packages("ggplot2")
install.packages("GGally")
install.packages("ISLR")
install.packages("openssl")
install.packages("tidyverse", dependencies = TRUE)
install.packages("ggfortify")
install.packages("factoextra")

# importing required packages
library(ggplot2)
library(GGally)
library(ISLR)
library(tidyverse)
library(ggfortify)
library(factoextra)
library(FactoMineR)

# read in the csv file
data <- read_csv("EWCS_2016.csv")

# visualize data
View(data)

# remove anomalies
data[,][data[, ,] == -999] = NA
kk=complete.cases(data)
data=data[kk,]

# visualize the number of males and females
data %>% count(Q2a, sort = TRUE)

scaled.data = scale(data) # scale for PCA

# visualize correlation plot
ggcorr(scaled.data, label = TRUE, label_alpha = TRUE)

# visualize the distribution of age plot
ggplot(data, aes(x=Q2b)) + geom_histogram(stat="count",
                                          fill="green")

# visualize values distributions in columns
options(repr.plot.width=6, repr.plot.height=6)
ggplot(gather(data), aes(value)) +
  geom_histogram(stat="count",
                 fill="green")+
  facet_wrap(~key, scales = 'free_x')

#### Principal Components Analysis ####
pca = prcomp(scaled.data, scale=T)
summary(pca)
fviz_eig(pca) # screen plot with percentage variance

# PCA matrix
pca.mat = function(loading, comp.sdev){
  loading*comp.sdev
}

# define the loading and standard deviation
loading = pca$rotation
comp.sdev = pca$sdev

# Principal components variables
pca.var = t(apply(loading, 1, pca.mat, comp.sdev)) # apply the function with the loading and std dev

pca.var[,1:3] # display the PCA matrix, PC1, PC2 and PC3
# All factor loading values > 0.75 are strong
# Factor loading values ranging between 0.50-0.75 are moderate
# while factor loading values ranging from 0.30 to 0.49 are weak

# In PCA 1 Q87a ,b , c, d and e have the highest factor loading values
# On the other hand, for the second PCA 2, the Q90a, b ,c and f have the highest loadings

# Principal Component Analysis Bi-plot
autoplot(pca,
         colour ='Q90f',
         loadings = TRUE,
         loadings.label = TRUE,
         loadings.label.size = 5)

autoplot(pca,
         colour ='Q87d',
         loadings = TRUE,
         loadings.label = TRUE,
         loadings.label.size = 5)

# The vectors on Q87 explain the observations dispersion in response to Q90f
# responses. Positive responses 1 and 2 are densely packed in comparison to the
# negative responses 5 and 6 which have a wider dispersion.

# If a individual was to respond positively to Q87a, b, c, d, e and f, they are
# more likely to respond positively to Q90a, b, c, f. This is because the vectors
# for Q87 are in the same direction as the dispersion of the responses


# the following is an example of the sort function
# > library(dslabs)
# > data(murders)

# the function 'sort' sorts a vector in increasing order

sort(murders$total)

# > sort(murders$total)

# [1]    2    4    5    5    7    8   11   12   12   16   19   21   22   27   32
# [16]   36   38   53   63   65   67   84   93   93   97   97   99  111  116  118
# [31]  120  135  142  207  219  232  246  250  286  293  310  321  351  364  376
# [46]  413  457  517  669  805 1257

# the function 'orde' produces the indices required to obtain the sorted vector
x <- c(31,4,15,92,65)
# > x will return [1] 31  4 15 92 65

# order(x) will return [1] 31  4 15 92 65

# sort(x) will return x [1] 31  4 15 92 65

# a result of 2 3 1 5 4 indicates that the sorted vector is produced by listing the 2nd 3rd 1st 5th and 4th term of the original vector
index <- order(x)
# x[index] will return x [1] 31  4 15 92 65


bmwr <- scan("http://stat.ethz.ch/Teaching/Datasets/bmw.dat")

p0 <- 40

p <- cumsum(bmwr) + p0

x <- rep(0, length(p))

x[1] <- log(p[1] / 40)

for (i in 2:length(x)) {
    x[i] <- log(p[i] / p[i - 1])
}

y <- x ** 2

x_model <- x[-length(x)]
y_model <- y[-1]

time <- 1:length(x_model)

ox <- order(x_model)

data <- data.frame(x = x_model, y = y_model)

loc_poly <- loess(y ~ x, data)

par(mfrow = c(4, 2))
plot(x_model, y_model)
lines(x_model[ox], fitted(loc_poly)[ox])

plot(time, y_model)
lines(time, fitted(loc_poly))

smo_spi <- smooth.spline(x_model, y_model, df = loc_poly$trace.hat)

plot(x_model, y_model)
lines(x_model[ox], fitted(smo_spi)[ox])

plot(time, y_model)
lines(time, fitted(smo_spi))

ksmo <- ksmooth(x_model, y_model, bandwidth = 0.16, x.points = x_model)

plot(x_model, y_model)
lines(ksmo$x, ksmo$y)
# no actually should plot on evenly placed points in min(x), max(x)

plot(time, y_model)
lines(time, ksmo$y[order(ox)])

# how to check model assumptions

library(lokern)
glo <- glkerns(x_model, y_model, hetero = TRUE)

plot(x_model, y_model)
lines(x_model[ox], fitted(glo)[ox])

loc <- lokerns(x_model, y_model, hetero = TRUE)

plot(x_model, y_model)
lines(x_model[ox], fitted(loc)[ox])
lines(loc$x.out, loc$bandwidth)


# Polynomial
# Library
library(ggplot2)

# Importing dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# Fitting Linear Regression to the dataset
lin_reg = lm(formula = Salary ~ .,
             data = dataset)

# Fitting Polynomial Regression to the dataset
dataset$Level2 = dataset$Level ^ 2
dataset$Level3 = dataset$Level ^ 3
dataset$Level4 = dataset$Level ^ 4
poly_reg = lm(formula = Salary ~ .,
              data = dataset)

# Visualising the Linear Regression Results
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour = 'red') +
  geom_line(aes(x = dataset$Level, y = predict(lin_reg, newdata = dataset)),
            colour = 'blue') +
  ggtitle('Truth or Bluff (Linear Regression)') +
  xlab('Level') +
  ylab('Salary')

# Visualising the Polynomial Regression
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour = 'red') +
  geom_line(aes(x = dataset$Level, y = predict(poly_reg, newdata = dataset)),
            colour = 'blue') +
  ggtitle('Truth or Bluff (Polynomial Regression)') +
  xlab('Level') +
  ylab('Salary')

# Predicting a new result with Linear Regression
y_pred = predict(lin_reg, data.frame(Level = 6.5))

# Predicting a new result with Polynomial Regression
y_pred = predict(poly_reg, data.frame(Level = 6.5,
                                      Level2 = 6.5 ^ 2,
                                      Level3 = 6.5 ^ 3,
                                      Level4 = 6.5 ^ 4))


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

#gerando serie random walk
#tornar reprodutivel
set.seed(4312)
x = cumsum(sample(c(-1,1),100,T))
print(x)
serie = ts(x,start = c(1900),end = c(2000), frequency = 1)
print(serie)
autoplot(serie)

#faz a previsao
prev = naive(serie, h=5)
class(prev)
print(prev)
print(prev$fitted)
print(prev$residuals)
autoplot(prev)
print(prev)

prev2 = naive(serie, h=5, level = c(95, 99))
print(prev2)
autoplot(prev2)

split.screen( figs = c( 2, 1 ) )
screen(1)
plot(prev)
screen(2)
plot(prev2)
close.screen( all = TRUE )

#naive sazonal
autoplot(AirPassengers)
prev3 = snaive(AirPassengers, h=12)
print(prev3)
autoplot(prev3)

#comparando a previsao com o ultimo ano
prev3$mean
window(AirPassengers,start=c(1960))

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/6.3.R Naive.r


# Chapter 7 Lab: Non-linear Modeling

library(ISLR)
attach(Wage)

# Polynomial Regression and Step Functions

fit=lm(wage~poly(age,4),data=Wage)
coef(summary(fit))
fit2=lm(wage~poly(age,4,raw=T),data=Wage)
coef(summary(fit2))
fit2a=lm(wage~age+I(age^2)+I(age^3)+I(age^4),data=Wage)
coef(fit2a)
fit2b=lm(wage~cbind(age,age^2,age^3,age^4),data=Wage)
agelims=range(age)
age.grid=seq(from=agelims[1],to=agelims[2])
preds=predict(fit,newdata=list(age=age.grid),se=TRUE)
se.bands=cbind(preds$fit+2*preds$se.fit,preds$fit-2*preds$se.fit)
par(mfrow=c(1,2),mar=c(4.5,4.5,1,1),oma=c(0,0,4,0))
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Degree-4 Polynomial",outer=T)
lines(age.grid,preds$fit,lwd=2,col="blue")
matlines(age.grid,se.bands,lwd=1,col="blue",lty=3)
preds2=predict(fit2,newdata=list(age=age.grid),se=TRUE)
max(abs(preds$fit-preds2$fit))
fit.1=lm(wage~age,data=Wage)
fit.2=lm(wage~poly(age,2),data=Wage)
fit.3=lm(wage~poly(age,3),data=Wage)
fit.4=lm(wage~poly(age,4),data=Wage)
fit.5=lm(wage~poly(age,5),data=Wage)
anova(fit.1,fit.2,fit.3,fit.4,fit.5)
coef(summary(fit.5))
(-11.983)^2
fit.1=lm(wage~education+age,data=Wage)
fit.2=lm(wage~education+poly(age,2),data=Wage)
fit.3=lm(wage~education+poly(age,3),data=Wage)
anova(fit.1,fit.2,fit.3)
fit=glm(I(wage>250)~poly(age,4),data=Wage,family=binomial)
preds=predict(fit,newdata=list(age=age.grid),se=T)
pfit=exp(preds$fit)/(1+exp(preds$fit))
se.bands.logit = cbind(preds$fit+2*preds$se.fit, preds$fit-2*preds$se.fit)
se.bands = exp(se.bands.logit)/(1+exp(se.bands.logit))
preds=predict(fit,newdata=list(age=age.grid),type="response",se=T)
plot(age,I(wage>250),xlim=agelims,type="n",ylim=c(0,.2))
points(jitter(age), I((wage>250)/5),cex=.5,pch="|",col="darkgrey")
lines(age.grid,pfit,lwd=2, col="blue")
matlines(age.grid,se.bands,lwd=1,col="blue",lty=3)
table(cut(age,4))
fit=lm(wage~cut(age,4),data=Wage)
coef(summary(fit))

# Splines

library(splines)
fit=lm(wage~bs(age,knots=c(25,40,60)),data=Wage)
pred=predict(fit,newdata=list(age=age.grid),se=T)
plot(age,wage,col="gray")
lines(age.grid,pred$fit,lwd=2)
lines(age.grid,pred$fit+2*pred$se,lty="dashed")
lines(age.grid,pred$fit-2*pred$se,lty="dashed")
dim(bs(age,knots=c(25,40,60)))
dim(bs(age,df=6))
attr(bs(age,df=6),"knots")
fit2=lm(wage~ns(age,df=4),data=Wage)
pred2=predict(fit2,newdata=list(age=age.grid),se=T)
lines(age.grid, pred2$fit,col="red",lwd=2)
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Smoothing Spline")
fit=smooth.spline(age,wage,df=16)
fit2=smooth.spline(age,wage,cv=TRUE)
fit2$df
lines(fit,col="red",lwd=2)
lines(fit2,col="blue",lwd=2)
legend("topright",legend=c("16 DF","6.8 DF"),col=c("red","blue"),lty=1,lwd=2,cex=.8)
plot(age,wage,xlim=agelims,cex=.5,col="darkgrey")
title("Local Regression")
fit=loess(wage~age,span=.2,data=Wage)
fit2=loess(wage~age,span=.5,data=Wage)
lines(age.grid,predict(fit,data.frame(age=age.grid)),col="red",lwd=2)
lines(age.grid,predict(fit2,data.frame(age=age.grid)),col="blue",lwd=2)
legend("topright",legend=c("Span=0.2","Span=0.5"),col=c("red","blue"),lty=1,lwd=2,cex=.8)

# GAMs

gam1=lm(wage~ns(year,4)+ns(age,5)+education,data=Wage)
library(gam)
gam.m3=gam(wage~s(year,4)+s(age,5)+education,data=Wage)
par(mfrow=c(1,3))
plot(gam.m3, se=TRUE,col="blue")
plot.gam(gam1, se=TRUE, col="red")
gam.m1=gam(wage~s(age,5)+education,data=Wage)
gam.m2=gam(wage~year+s(age,5)+education,data=Wage)
anova(gam.m1,gam.m2,gam.m3,test="F")
summary(gam.m3)
preds=predict(gam.m2,newdata=Wage)
gam.lo=gam(wage~s(year,df=4)+lo(age,span=0.7)+education,data=Wage)
plot.gam(gam.lo, se=TRUE, col="green")
gam.lo.i=gam(wage~lo(year,age,span=0.5)+education,data=Wage)
library(akima)
plot(gam.lo.i)
gam.lr=gam(I(wage>250)~year+s(age,df=5)+education,family=binomial,data=Wage)
par(mfrow=c(1,3))
plot(gam.lr,se=T,col="green")
table(education,I(wage>250))
gam.lr.s=gam(I(wage>250)~year+s(age,df=5)+education,family=binomial,data=Wage,subset=(education!="1. < HS Grad"))
plot(gam.lr.s,se=T,col="green")


library(readxl)
pcancerdf <- readxl::read_xlsx("../823data/pcancer.xlsx")

pcancerdf

pcancerdf.r <- pcancerdf[pcancerdf$weight < 400,]
pcancerdf.r <- pcancerdf.r[pcancerdf.r$psa < 100,]

plot(pcancerdf.r$psa ~ pcancerdf.r$weight)

m.p_w <- lm(log(pcancerdf.r$psa) ~ log(pcancerdf.r$weight))
summary(m.p_w)

plot(log(pcancerdf.r$psa) ~ log(pcancerdf.r$weight))
abline(m.p_w)

plot(residuals(m.p_w))


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

autoplot(presidents)

prev = auto.arima(presidents)
print(prev$residuals)

#analisando os residuais
prev$residuals
autoplot(prev$residuals)
hist(prev$residuals)
var(prev$residuals,na.rm = T)
mean(as.vector(prev$residuals),na.rm = T)

#acf e pacf
acf(prev$residuals, na.action = na.pass )

#funcao especial para checar residuais
checkresiduals(prev)

#teste de normalidade
shapiro.test(prev$residuals)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.1.Avaliando residuais.r


#!/usr/bin/env Rscript

# R - https://www.r-project.org/
#
# Usage:
# ./gcd.r 11 22 33 121
# [1] 11
#
# Or:
# Rscript ./gcd.r 11 22 33 121
# [1] 11
#

gcd <- function (a, b) {
  if (b == 0) {
    a
  } else {
    gcd(b, a %% b)
  }
}

gcdn <- function(ns) {
  Reduce(gcd, ns)
}

args <- commandArgs(trailingOnly=TRUE)
ns <- mapply(as.integer, args)
gcdn(ns)


library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(readr)
library(ggthemes)

### Functions that evaluate theoretical fitness according to Sella and Hirsh
predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

w_vs_eps <- function(Ne, L, s, epsstart, epsstop, epssteps = 0.01)
{
  eps <- seq(epsstart, epsstop, epssteps)
  w_ave <- vapply(eps, function(eps){predict_mean_fitness(Ne, L, s, eps)}, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

#########################################################################
### Epistasis vs Fitness: theoretically derived and simulated fitness ###
#########################################################################
# import simulation results
t_N100 <- read_csv("../processed_results/varying_eps_N100_max3.csv")
t_N10 <- read_csv("../processed_results/varying_eps_N10_max3.csv")

t <- rbind(t_N100, t_N10)

# calculate a mean fitness across time when the population reached epistasis
t %>% mutate(q = 1-epistasis_coef) %>%
  group_by(q, sel_coef, mu_prob, Ne, k_start, rep) %>% #one mean per simulation
  summarise(mean_f_over_time = mean(mean_fitness)) -> t_sum

L = 100 #Number of maximum mutations

### Sub-figure N=10, s=0.01
pop_size = 10
s = 0.01

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N10_s0.01 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time, color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size = 0.4) +
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.01", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=10, s=0.001
pop_size = 10
s = 0.001

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N10_s0.001 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.001", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=100, s=0.01
pop_size = 100
s = 0.01

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N100_s0.01 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.01", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

### Sub-figure N=100, s=0.001
pop_size = 100
s = 0.001

t_sum %>% filter(sel_coef == s, Ne == pop_size) -> f
an_f <- w_vs_eps(pop_size, L, s, -1, 1) %>% mutate(q=1-eps)

p_N100_s0.001 <- ggplot()+
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time,color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4)+
  geom_line(data = an_f, aes(x = q, y = w_ave))+
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.001", size = 12, fontface = 'bold')+
  scale_y_continuous(breaks=seq(0,1,0.2))+
  coord_cartesian(ylim=c(0,1),xlim=c(0,2))+
  guides(col = guide_legend(title="Mutation\nrate"))+
  theme(axis.title = element_text(size = 14),
        axis.text = element_text(size = 12),
        legend.text = element_text(size = 11),
        legend.title = element_text(size = 12))+
  xlab('q') +
  ylab('Mean fitness') +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1"), values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F"))

# extract the legend form the first sub-figure
grobs <- ggplotGrob(p_N100_s0.001)$grobs
legend <- grobs[[which(sapply(grobs, function(x) x$name) == "guide-box")]]

# arrange subfigures
prow <- plot_grid(p_N10_s0.001 + theme(legend.position="none"),
                  p_N10_s0.01 + theme(legend.position="none", axis.title.y = element_blank()),
                  p_N100_s0.001 + theme(legend.position="none"),
                  p_N100_s0.01 + theme(legend.position="none", axis.title.y = element_blank()),
                  labels=c("A","B","C","D"),
                  align = 'vh',
                  hjust = -1,
                  ncol=2,
                  nrow=2)

p <- plot_grid(prow, legend, rel_widths = c(2, .3))

save_plot("../plots/fitness_vs_epistasis.png", p,
          ncol = 2, # we're saving a grid plot of 2 columns
          nrow = 2, # and 2 rows
          # each individual subplot should have an aspect ratio of 1.3
          base_height=4,
          base_width=4)

#########################################################################
### Two regimes: selection driven and drift driven                    ###
#########################################################################
# a function that calculates Q* (min of Q)
f <- function(L, s, q, k){exp(-s*k**q)}
p_num <- function(L, s, N, q, k){choose(L, k)*f(L, s, q, k)**(2*N-2)}
Z <- function(L, s, N, q){sum(p_num(L, s, N, q, 0:L))}
fave <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num(L, s, N, q, 0:L))/Z(L, s, N, q)}

# assume p(k) independent of f(k) (i.e., no selection)
p_num2 <- function(L, s, N, q, k){choose(L, k)}
Z2 <- function(L, s, N, q){sum(p_num2(L, s, N, q, 0:L))}
fave2 <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num2(L, s, N, q, 0:L))/Z2(L, s, N, q)}

# assume k <= kmax only (limited drift)
Z3 <- function(L, s, N, q, kmax){sum(p_num(L, s, N, q, 0:kmax))}
fave3 <- function(L, s, N, q, kmax){sum(f(L, s, q, 0:kmax)*p_num(L, s, N, q, 0:kmax))/Z3(L, s, N, q, kmax)}

eval_model <- function(L, s, N) {
  q <- seq(0, 2, .01)
  df <- data.frame(
    q = q,
    full_model = vapply(q, function(x) fave(L, s, N, x), numeric(1)),
    no_selection = vapply(q, function(x) fave2(L, s, N, x), numeric(1)),
    limited_drift = vapply(q, function(x) fave3(L, s, N, x, 20), numeric(1))
  ) %>% gather(formula, f_ave, -q)
}

# get a data frame of 3 models evaluated for different Q values
df <- eval_model(L = 100, s = 0.01, N = 10)

df %>% filter(formula == "full_model") -> df1
df %>% filter(formula == "no_selection") -> df2
df %>% filter(formula == "limited_drift") -> df3

name <- data.frame(x = c(1.76, 1.45, 1), y = c(0.34, 0.8, 0.25) , model = c("Full model", "Selection driven", "Drift driven"))

# Make a plot of the 3 models
p_models <- ggplot() +
  geom_line(
    data = df3,
    aes(q, f_ave, color = formula),
    size = 1,
    linetype = "dotted",
    color = "#955804",
    lineend = "butt") +
  geom_line(
    data = df2,
    aes(q, f_ave, color = formula),
    size = 1,
    linetype = "dashed",
    color = "#3f72af",
    lineend = "round") +
  geom_line(
    data = df1,
    aes(q, f_ave, color = formula),
    size = 1.1,
    lineend = "round") +
  geom_text(data = name, aes(x, y, label = model)) +
  xlab('q') +
  ylab('Mean fitness') +
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 10, s = 0.01", size = 12, fontface = 'bold') +
  theme(plot.title = element_text(hjust = 0), legend.position="none") +
  scale_color_manual(values = c("#000000", "#979797", "#979797"))

save_plot("../plots/two_regimes.png",
          p_models,
          # each individual subplot should have an aspect ratio of 1.3
          base_aspect_ratio = 1.2)

#########################################################################
### Theoretical calculations of Q*                                    ###
#########################################################################

# predicted Q minimum (Q*)
qmin <- function(N, L, s){log(L*log(2)/(2*s*N))/log(L/2)}

# function that evalutes min Q (Q*) vs selection coefficient
qmin_vs_s <- function(Ne, L, s_start, s_stop, s_steps = 0.001)
{
  s <- seq(s_start, s_stop, s_steps)
  qmin <- vapply(s, function(s){qmin(Ne, L, s)}, 1)
  data.frame(s, qmin, Ne, L)
}

# make a data frame of Q* vs selection coefficient for N=10
df1 <- qmin_vs_s(10, 100, 0.0001, 0.1)

# make a data frame of Q* vs selection coefficient for N=100
df2 <- qmin_vs_s(100, 100, 0.0001, 0.1)

# make a data frame of Q* vs selection coefficient for N=1000
df3 <- qmin_vs_s(1000, 100, 0.0001, 0.1)

df <- rbind(df1, df2, df3)

# a function that calculates Q* (min of Q)
f <- function(L, s, q, k){exp(-s*k**q)}
p_num <- function(L, s, N, q, k){choose(L, k)*f(L, s, q, k)**(2*N-2)}
Z <- function(L, s, N, q){sum(p_num(L, s, N, q, 0:L))}
fave <- function(L, s, N, q){sum(f(L, s, q, 0:L)*p_num(L, s, N, q, 0:L))/Z(L, s, N, q)}

# numerically find optimal q
fopt_gen <- function(L, s, N) {
  function(q) fave(L, s, N, q)
}

# make a data frame with numerically inferred q minimum
num_min_q <- data.frame()
for (i in 1:25) {
  for (n in c(10, 100, 1000)) {
    s <- 0.0001*1.2^i
    qmin <- optimize(fopt_gen(100, s, n), interval = c(0, 10))$minimum
    row <- data.frame(s, qmin, n)
    num_min_q <- rbind(num_min_q, row)
  }
}

p_qmin <- ggplot(df, aes(x = s, y = qmin, color = factor(Ne))) +
  geom_line(size = 1.1, lineend = "round") +
  geom_point(data = num_min_q, aes(x = s, y = qmin, color = factor(n))) +
  geom_hline(yintercept = 1) +
  scale_y_continuous(breaks=seq(0,2.5,0.5)) +
  scale_x_log10(breaks=c(0.0001, 0.001, 0.01, 0.1), labels = c("0.0001", "0.001", "0.01", "0.1")) +
  coord_cartesian(ylim=c(0,2.6),xlim=c(0.000099999,0.1)) +
  xlab('s') +
  ylab('q*') +
  scale_color_manual(values = c("#9AC9D6", "#6E7FB3", "#6D0079")) +
  guides(col = guide_legend(title="N"))

save_plot("../plots/minimum_q_vs_selection.png",
          p_qmin,
          # each individual subplot should have an aspect ratio of 1.3
          base_aspect_ratio = 1.3)

#########################################################################
### Simulations with high mutation rate and no selection model        ###
#########################################################################
# evaluate fitness vs Q for the formula that's doesn't consider selection.
df <- eval_model(L = 100, s = 0.01, N = 100) %>% filter(formula == "no_selection")
t_N100a <- read_csv("../processed_results/varying_eps_N100_max3.csv")
t_N100b <- read_csv("../processed_results/varying_eps_N100_max4.csv")

t <- rbind(t_N100a, t_N100b)

# calculate a mean fitness across time when the population reached epistasis
t %>% mutate(q = 1-epistasis_coef) %>%
  group_by(q, sel_coef, mu_prob, Ne, k_start, rep) %>% #one mean per simulation
  summarise(mean_f_over_time = mean(mean_fitness)) -> t_sum

t_sum %>% filter(sel_coef == 0.01) -> f

p_mu <- ggplot() +
  geom_line(data = df, aes(q, f_ave), size = 1.1) +
  draw_text(x = 0, y =0, hjust = 0, vjust = 0, text = "N = 100, s = 0.01", size = 12, fontface = 'bold') +
  stat_summary(data = f,
               inherit.aes = FALSE,
               aes(x = q, y = mean_f_over_time, color=factor(mu_prob)),
               fun.y = mean,
               fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
               fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
               geom = "pointrange",
               size=0.4) +
  xlab('q') +
  ylab('Mean fitness') +
  guides(col = guide_legend(title="Mutation\nrate")) +
  scale_color_manual(labels= c("0.0001", "0.001", "0.01", "0.1", "1"),
                     values = c("#F3DB7E", "#F5BE6C", "#E4945E", "#C05E4F", "#8E063B"))

save_plot("../plots/no_selection_model_vs_mu.png", p_mu,
          # each individual subplot should have an aspect ratio of 1.3
          base_height=5,
          base_width=6)


v <- c(18,9,12,25)
w <- c(5,2,4,6)
W <- 10

Tabweights<-c(0,w)
TabValues<-c(0,v)
n<-length(w)
TabMatrix<-matrix(NA,nrow =n+1,ncol = W+1)

TabMatrix[,]<-0

for (j in 2:W+1){
  for (i in 2:n+1){
      if (Tabweights[i] > j) {
        TabMatrix[i,j] = TabMatrix[i-1,j]
      }
      else
      {
        TabMatrix[i,j]<-max(TabMatrix[i-1,j], TabValues[i] + TabMatrix[i-1,j-Tabweights[i]])
      }
  }
}

cat("The best value is",TabMatrix[i,j])

i = n+1
w = W+1
ItemSelected = c()
while(i>1 & w>0)
  {
  if(TabMatrix[i,w]!=TabMatrix[i-1,w])
    {
    ItemSelected<-c(ItemSelected,(i)-1)
    w = w - Tabweights[i]
    i = i - 1
   }
  else
  {
    i = i - 1
  }
}

cat("The items selected are",ItemSelected)


#' BPR link cost function
#'
#' This function calculates the travel costs as a function of link flow using the classic separable BPR cost function. Specifically, c(x) = Alpha*(1+0.15 (x/Beta)^pow) for pow > 0; c(x) = Alpha for pow = 0.
#' @param x Traffic volume on link
#' @param Alpha Free flow travel time parameter
#' @param Beta Link capacity parameter
#' @param pow Polynomial order of cost function. Defaults to 4.
#' @return Vector of link costs
#' @keywords BPR link cost
#' @examples
#' x <- 1:25
#' costs <- LinkCost(x,Alpha=5,Beta=20)
#' plot(x,costs)
#' @export

LinkCost <- function(x,Alpha,Beta,pow=4){
	Beta[pow==0] <- 1
	Alpha*(1+(pow>0)*0.15*(x/Beta)^pow)
}


## Load some packages that will be useful
library(mgcv) # load the MGCV package with Simon Wood's gam() functions
library(readr) # Hadley Wickham's package for reading in data easily
library(ggplot2) # for plotting with ggplot
library(ggfortify) # for autoplot

##################################################################################################
## We'll first examine the bias-variance tradeoff in a simplified form with a small exercise.
## If you remember, this tradeoff is one of the concepts behind finding the optimal amount of smoothing.
## We'll fit linear regressions to parts of the data, increasing the number of parts from 1 to 10.
##################################################################################################

# First, read in the bioluminescence data.
# Sources is the number of bioluminescent plankton seen in each water sample
# SampleDepth is the depth of the water sample, in m
# Station is the ID of the location at which multiple water samples were taken
ISIT <- read_tsv(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/ISIT.txt')) # tsv for tab-separated values

# Subset it to one station. This is what we'll work with for now.
ISITsub <- subset(ISIT, Station == 8)

# Plot the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point()

# Now you can fit a linear regression to the ISITsub dataset, with Sources as the response and SampleDepth as the explanatory variable
# Please call the output "mod1", as I've started to fill in for you
mod1 <- lm(Sources~SampleDepth, data = ISITsub)
summary(mod1)
# Q1: What was your code for fitting a linear regression of Sources vs. SampleDepth?
# A1: mod1 <- lm(Sources~SampleDepth, data = ISITsub)

# We'll predict the mean response and confidence intervals from this model and save the output
ISITsub$mod1 <- predict(mod1)
ISITsub$mod1lwr <- predict(mod1, interval='confidence', level=0.95)[,'lwr']
ISITsub$mod1upr <- predict(mod1, interval='confidence', level=0.95)[,'upr']

# Now plot the linear model fit to the full dataset on top of the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3)

# Q2: Use your skills from earlier in this course and evaluate this linear model (autoplot may be useful here). How does this fit look to you? Does a linear regression look reasonable? Any well-justified answer is appropriate.
autoplot(mod1)
summary(mod1)
# A2: From the summary table, the p-value is good but the R-squared value is small which means it might not be a
# good fit. Looking at the autoplot results, the first graph for Residuals vs Fitted values shows a parabola, which
# indicated here we have non-linear relationship in this model and was not well-explained.

# For comparison, let's fit linear models to two halves of the data. This involves a fair bit of coding in R, so please ask for help understanding the code where things are confusing.
# First, we have to find the halves of the data
quants2 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.5)) # define the ends and the half-way point in the data with the quantile function
ISITsub$split2 <- cut(ISITsub$SampleDepth, breaks=quants2, include.lowest=TRUE, labels=1:2)

# Q3: In your own words, what does the cut() function do? How are we using it here?
# The cut() function can divide the data in assigned intervals and give them specific labels based on the value.
# In our code, we ask R to divide the sample depth into two intervals based on the quants2, and label the first interval
# as 1 and the seconde interval as 2.

# Next, let's fit a linear model to each subset (half) of the data. We do this in a loop to make it easier.
mod2s <- vector('list', length=2) # A list to hold each of our models in a single, convenient object
ISITsub$mod2 <- ISITsub$mod2lwr <- ISITsub$mod2upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod2s)){ # Loop through each model
	mod2s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split2==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
	ISITsub$mod2[ISITsub$split2==i] <- predict(mod2s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
	ISITsub$mod2lwr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
	ISITsub$mod2upr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Plot the data, the 1-model fit, and the 2-model fit
# There will be an odd 3rd line segment connecting the end of the first model fit to the beginning of the second model fit. Just pretend it's not there.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
	geom_line(aes(y=mod2, color='red')) +
	geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')

# Q4: Has the fit between the model and the data improved? What's the downside of continuing the split the data into finer and finer chunks and fitting more models?
autoplot(mod2s)
# A4: By looking at the autoplot results of the two mods we have, we can see a better explained relationship between residuals ans fitted value,
# The NOrmal Q-Q plot looks normally distributed. Overall, they are better fitted model comparing to the mod1.
# If we keep split the data, the downside is to get smaller data set, the reliablity of the model we get will be lower.

# Now, it's your turn. Please fit 10 linear regression models. I'd recommend using the 2-model code above as a guide and tweaking it.
quants10 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.1))
ISITsub$split10 <- cut(ISITsub$SampleDepth, breaks=quants10, include.lowest=TRUE, labels=1:10)

mod10s <- vector('list', length=10)
ISITsub$mod10 <- ISITsub$mod10lwr <- ISITsub$mod10upr <- NA
for(i in 1:length(mod10s)){
    mod10s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split10==i,])
    ISITsub$mod10[ISITsub$split10==i] <- predict(mod10s[[i]])
    ISITsub$mod10lwr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'lwr']
    ISITsub$mod10upr[ISITsub$split10==i] <- predict(mod10s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Now plot the 10 models on top of the data and on top of the 1- and 2-model fits. The plot with the data, 1-model, and 2-model fit is probably a useful guide here.

ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
    geom_point() +
    geom_line(aes(y=mod1)) +
    geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
    geom_line(aes(y=mod2, color="red")) +
    geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill="red")+
    geom_line(aes(y=mod10,color = "green"))+
    geom_ribbon(aes(ymin=mod10lwr, ymax=mod10upr), alpha=0.3, fill="green")

# Q5: Compare your 10-model fit to the 1-model fit. Which model's predictions are furthest from the observed data? Which model has the widest confidence bounds? How does this (or does this not) illustrate the bias-variance tradeoff?
# By looking at the plot, our 10-model fit is nicely fell into the points. The 1-model fit's prediction is furthest from
# the observed data. But the 10-model fit has the widest confidence bounds. It illustrate the bias-variance tradeoff by showing
# us the confidence band that our better-fitted model has smaller amount of data with higher uncertainty in the model.
# Our 1-model fit shows a bad-fit but the data unvertainty is relatively lower.

####################################################
## Now you'll fit some GAMs and evaluate your models
####################################################
#install.packages("maps") # if needed
library(maps) # has map data in it

# load the data
spdata <- readRDS(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/gadusmorhua.rds')) # load the spdata data.frame with abundance and environmental data from cod surveys
spdata$presfit01 <- as.numeric(spdata$presfit) # make a vector that's nice for plotting
spdata <- spdata[order(spdata$presfit01),] # order the data from absent to present for ease of plotting

# examine the data
head(spdata) # look at the dataset
summary(spdata)

# make a map of the data
world <- map_data('world')

ggplot() +
	geom_polygon(data=world, aes(x=long, y=lat, group=group), color='black', fill=NA) + # the map
	xlim(-100, -45) +
	ylim(23, 62) +
	geom_point(data=spdata, aes(x=lon, y=lat, color=presfit, alpha=0.1), size=0.01) # the data points. note that because the dataframe is sorted from absent to present, the presences are plotted on top of the absences

# Q6: Based on the map, do you think cod prefer warmer or cooler waters? Why do you think that?
# The map shows the cod prefer cooler water because we can see more cod presence in the higher latitude region, which
# I expect to see a colder temperature of water comparing to the lower latitude.

# Q7: Plot cod presence/absence (the presfit vector) vs. the bottom temperature (SBT.actual). At what range of temperatures have cod been observed?

ggplot(spdata, aes(x=SBT.actual, group=presfit01)) +
    geom_boxplot()

# Q8: Fit a GAM for presfit against SBT.actual. Check the model. Does it look like the assumptions have been met? Why or why not?

mod <- gam(presfit01 ~ s(SBT.actual),data=spdata)
gam.check(mod)

# We cannot tell if the assumptions have been met by looking at these results. All the plots in the gam.check
# seems to be separated into two parts. This should be the reason of our data is binomial, we only have 0 or 1 for presfit.

# Q9: Fit a new GAM with a more appropriate error structure and save it as "mod2". The gam() function takes the same family= argument as does glm(). Which error structure and link function did you choose?

mod2 <- gam(presfit01 ~ s(SBT.actual),data=spdata,family="binomial")

# I choose binomial error structure and the link function is logit.

# Q10: Check your mod2 GAM. Does it look like the assumptions have been met? Make sure to read the text output as well as look at the graphs. If something doesn't look right, what would you do to fix it?

gam.check(mod2)
# The normal qq plot looks better than before. However, other plots like histogram are still  weird looking and don't show a
# normal distribution.

# Q11: Interpret your mod2 GAM (summary function). How much deviance is explained? Is the SBT.actual term significant at alpha=0.05? How wiggly do you expect the smooth fit to be?

summary(mod2)
# Deviance explained = 26.5%
# SBT.actual term is significant at alpha=0.05 because p-value is <2e-16.
# I expect the curve to be wiggly, the edf is around 9. The higher the edf, the more non-linear the curve will be.

# Now let's make predictions from our last model (mod2) and plot them.
nd <- data.frame(SBT.actual = seq(-5,30, by=0.5)) # make a data.frame of new explanatory variables
nd$mod2 <- predict(mod2, newdata=nd, type='response') # predict on the scale of the response
nd$mod2se <- predict(mod2, newdata=nd, type='response', se.fit=TRUE)$se.fit # get the standard errors of the fit

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
	geom_point() +
	geom_line(data=nd, aes(x=SBT.actual, y=mod2, color='red')) +
	geom_ribbon(data=nd, aes(x=SBT.actual, ymin=mod2-mod2se, ymax=mod2+mod2se), alpha=0.3, fill='red', inherit.aes=FALSE)

# Q12: Does the fit look realistic? Why or why not? Does it look overfit? Why or why not?

# The model fit looks good, but it might be somehow overfit. Based on the orgin data we have, I can only see some small variance between the presence or absence
# of the cod, but the curve really react as a big change of the curve. Some changes in the temperature according to the presence of cod is hard to explain
# by seeing this graph.

# Q13: This dataset is actually a concatenation of seven different surveys which each have slightly different abilities to catch cod. Fit a new GAM that includes a categorical predictor for survey (the region vector). Based on AIC, which model would you choose? How confident would you be?
mod3 <- gam(presfit01 ~ s(SBT.actual)+region,data=spdata,family="binomial")
AIC(mod2,mod3)

# I would be confidence to choose mod3 base on a much lower AIC value it has.


compose <- function(f,g) function(x) { f(g(x)) }
r <- compose(sin, cos)
print(r(.5))


 DTZRZF Example Program Results

 Tolerance used to estimate the rank of A
        1.00E-02
 Estimated rank of A
        4

 Least squares solution(s)
             1          2
 1      0.6344     3.6258
 2      0.9699     1.8284
 3     -1.4402    -1.6416
 4      3.3678     2.4307
 5      3.3992     0.2818

 Square root(s) of the residual sum(s) of squares
        2.54E-02   3.65E-02


require(MASS)

# Standard error for means
stderr = function(x){ sqrt(var(x,na.rm=TRUE)/length(na.omit(x))) }

# Geometric mean
gmean=function(x) { exp(mean(log(x))) }

# Power-law distribution functions
dpareto=function(x, s=1, l=1) s * l^s / x^(s + 1);
ppareto=function(x, s=1, l=1) (x >= l) * (1 - (l / x)^s);
qpareto=function(u, s=1, l=1) l/(1 - u)^(1 / s);
rpareto=function(n, s=1, l=1) qpareto(runif(n), s, l);

# Chi-square goodness of fit, d.f.=(discrete bins) - ((num parameters used in fit)+1)
goodfit.chisq.test=function(x,dfunc,params) {
    n=length(x)
    p=length(params)+1
    xvals=floor(min(x)):(max(x))
    ofset=min(x)-1
    counts=rep(0,length(xvals))
    for(i in 1:n) { counts[x[i]-ofset]=counts[x[i]-ofset]+1 }
    ob=counts[counts>5]
    df=length(ob)-p
    cl=call(dfunc, xvals[counts>5], params)
    if(is.call(cl)) {
        ex=eval(cl)
        ex=round(ex*sum(ob),0)
        ctmat=as.matrix(cbind(ob,ex))
        statistic=chisq.test(ctmat, correct=F)$statistic
        p.value=1-pchisq(statistic,df)
        list(statistic=statistic, df=df, p.value=p.value)
    } else {
        warning("unrecognized function")
    }
}

# List of distributions fit to empirical data x, overlaid on plot
normhist=function(x,col=8,normcol=4,meancol=4,sdcol=5,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=seq(lim1,lim2,length=1000)
    ny=dnorm(nx,mean=nm,sd=nsd)
    if(!is.na(normcol)){ lines(nx,ny,col=normcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dnorm(nm,mean=nm,sd=nsd)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dnorm(nm+nsd,mean=nm,sd=nsd)),col=sdcol) }
    if(!is.na(sdcol)){ lines(c(nm-nsd,nm-nsd),c(0,dnorm(nm-nsd,mean=nm,sd=nsd)),col=sdcol) }
    p=ks.test(x,"pnorm",nm,nsd)$p
    legend("topright",inset=0.05,legend=c(paste("Normal( ",round(nm,5),", ",round(nsd,5)," )"), "KS-test", paste("p =",signif(p,5))),bty="n")
}

lognormhist=function(x,col=8,lnormcol=4,meancol=4,sdcol=5,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=gmean(x)
    nsd=sd(x)
    lnm=mean(log(x))
    lnsd=sd(log(x))
    nx=seq(lim1,lim2,length=1000)
    ny=dlnorm(nx,meanlog=lnm,sdlog=lnsd)
    if(!is.na(lnormcol)){ lines(nx,ny,col=lnormcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dlnorm(nm,meanlog=lnm,sdlog=lnsd)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dlnorm(nm+nsd,meanlog=lnm,sdlog=lnsd)),col=sdcol) }
    p=ks.test(x,"plnorm",lnm,lnsd)$p
    legend("topright",inset=0.05,legend=c(paste("Lognormal( ",round(lnm,5),", ",round(lnsd,5)," )"), "KS-test", paste("p =",signif(p,5))),bty="n")
}

gammahist=function(x,shape,legtxt="",col=8,gamcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=0
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=seq(lim1,lim2,length=1000)
    ny=dgamma(nx,shape=shape,rate=1/nm)
    if(!is.na(gamcol)){ lines(nx,ny,col=gamcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dgamma(nm,shape=shape,rate=1/nm)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dgamma(nm+nsd,shape=shape,rate=1/nm)),col=sdcol) }
    p=ks.test(x,"pgamma",shape,1/nm)$p
    leg=c("KS-test",paste("p =",signif(p,5)))
    if(nchar(legtxt)>0) {
        leg=c(legtxt, leg)
    } else {
        leg=c(paste("Gamma( ",round(shape,5),", 1/",round(nm,5)," )",sep=""), leg)
    }
    legend("topright",inset=0.05,legend=leg,bty="n")
}

exphist=function(x,col=8,expcol=4,meancol=4,sdcol=NA,border=F,xlab="",...) {
    gammahist(x,shape=1,paste("Exponential( 1, 1/",round(mean(x),5)," )",sep=""), col=col,gamcol=expcol,meancol=meancol,sdcol=sdcol,border=border,xlab=xlab,...)
}

discretehist=function(x,dfunc,param,legtxt="",col=8,denscol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,h=1,col=col,border=border,xlab=xlab,...)
    lim1=0
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    nx=(lim1):(lim2)
    cl=call(dfunc, nx, param)
    cl2=call(dfunc, floor(nm), param)
    cl3=call(dfunc, floor(nm+nsd), param)
    if(is.call(cl)) {
        ny=eval(cl)
        if(!is.na(denscol)){ lines(nx,ny,col=denscol,type="s") }
        if(!is.na(meancol)){ lines(c(nm,nm),c(0,eval(cl2)),col=meancol) }
        if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,eval(cl3)),col=sdcol) }
        p=goodfit.chisq.test(x,dfunc,param)$p.value
        leg=c(expression(paste("Pearson ",chi^2,"-test")),paste("p =",signif(p,5)))
        if(nchar(legtxt)>0){ leg=c(legtxt,leg) }
        legend("topright",inset=0.05,legend=leg,bty="n")
    } else {
        warning("not a recognized function")
    }
}

geomhist=function(x,col=8,geomcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    param=1/mean(x)
    discretehist(x,"dgeom",param,paste("Geometric( 1/",round(mean(x),5)," )",sep=""),col,geomcol,meancol,sdcol,border,xlab,...)
}

poishist=function(x,col=8,poiscol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    param=mean(x)
    discretehist(x,"dpois",param,paste("Poisson( ",round(param,5)," )",sep=""),col,poiscol,meancol,sdcol,border,xlab,...)
}

paretohist=function(x,col=8,pcol=4,meancol=4,sdcol=NA,border=F,xlab=deparse(substitute(x)),...) {
    truehist(x,col=col,border=border,xlab=xlab,...)
    lim1=par("usr")[1]
    lim2=par("usr")[2]
    nm=mean(x)
    nsd=sd(x)
    location=min(x)
    nx=seq(lim1,lim2,length=1000)

    # estimate shape parameter, by linear regression of head of distribution on log-log
    logx=log(x)
    lxbins=seq(min(logx),max(logx),length=50)
    lxcounts=rep(0,10)
    for(i in 1:10) { lxcounts[i]=length(logx[logx>=lxbins[i] & logx<lxbins[i+1]])}
    lxmids=(lxbins[2:11]+lxbins[1:10])/2
    shape=-lm(log(lxcounts)~lxmids)$coefficients[2]

    ny=dpareto(nx,shape,location)
    if(!is.na(pcol)){ lines(nx,ny,col=pcol) }
    if(!is.na(meancol)){ lines(c(nm,nm),c(0,dpareto(nm,shape,location)),col=meancol) }
    if(!is.na(sdcol)){ lines(c(nm+nsd,nm+nsd),c(0,dpareto(nm+nsd,shape,location)),col=sdcol) }
    p=ks.test(x,"ppareto",shape,location)$p
    legend("topright",inset=0.05,legend=c(paste("Pareto( ",round(shape,5),", ",round(location,5)," )",sep=""),"KS-test",paste("p =",signif(p,5))),bty="n")
}

powerlawhist=paretohist

# Plot 6 distributions for comparison of fit
allhist=function(x,...) {
    par(mfrow=c(2,3))
    options(warn=-1)
    try(normhist(x,nbins=50,...),T)
    try(lognormhist(x,nbins=50,...),T)
    try(exphist(x,nbins=50,...),T)
    try(geomhist(x,nbins=50,...),T)
    try(poishist(x,nbins=50,...),T)
    try(paretohist(x,nbins=50,...),T)
    options(warn=1)
}


#concat concatenates the new values to the existing vector of values, then discards any values that are too old.
lastvalues <- local(
{
   values <- c();
   function(x, len)
   {
      values <<- c(values, x);
      lenv <- length(values);
      if(lenv > len) values <<- values[(len-lenv):-1]
      values
   }
})

#moving.average accepts a numeric scalars input (and optionally a length, i.e. the number of values to retain) and calculates the stateful moving average.
moving.average <- function(latestvalue, len=3)
{
   #Check that all inputs are numeric scalars
   is.numeric.scalar <- function(x) is.numeric(x) && length(x)==1L
   if(!is.numeric.scalar(latestvalue) || !is.numeric.scalar(len))
   {
      stop("all arguments must be numeric scalars")
   }

   #Calculate mean of variables so far
   mean(lastvalues(latestvalue, len))
}
moving.average(5)  # 5
moving.average(1)  # 3
moving.average(-3) # 1
moving.average(8)  # 2
moving.average(7)  # 4


gcd = function(num1,num2)
{
  if(num1>num2)
  {
    s = num2
  }else{
    s = num1
  }
  for (i in 1:s)
  {
    if((num1%%i == 0) && (num2 %% i == 0))
    {
      y = i
    }
  }
  return(y)
}
x=gcd(24,54)
print(x)


#' @export
leverage_values <- function(X){
    `inv(X'X)` <- solve(t(X) %*% X)
    leverage_values <- apply(X, MARGIN = 1, FUN = function(xi){
                             t(xi) %*% `inv(X'X)` %*% xi
                    })
    return(leverage_values)
}


##########################################################################
#
# Author: Dariya K. Sydykova
##########################################################################

# load packages necessary to run the following script
library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(here)

# set up input file. Output plot files are generated automatically and are stored in /evolving_q_sim/test_plots
root_dir <- here() # get the directory of the root of the project

# this function calculates population fitness according to Sella and Hirsh's theory
# the function takes in as an argument size of the population (`Ne`), maximum number of mutations (`L`), selection coefficient (`s`), and epistasis coefficient (`eps`)
predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

# this function calculates population fitness for different values of epistasis coefficient.
w_vs_eps <- function(Ne, L, s, epsstart, epsstop, epssteps = 0.01)
{
  eps <- seq(epsstart, epsstop, epssteps)
  w_ave <- vapply(eps, function(eps){predict_mean_fitness(Ne, L, s, eps)}, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

# this function calculates population fitness for different sizes of population.
w_vs_Ne <- function(eps, L, s, Nestart, Nestop, Nesteps = 0.1) {
  Ne <- seq(Nestart, Nestop, Nesteps)
  w_ave <- vapply(Ne, function(Ne) {
    predict_mean_fitness(Ne, L, s, eps)
  }, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

# set parameters to be used in numerical derivations
q <- 1
eps <- 1 - q
s <- 0.01
an_f1 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

q <- 1.5
eps <- 1 - q
s <- 0.01
an_f2 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

q <- 0.5
eps <- 1 - q
s <- 0.01
an_f3 <- w_vs_Ne(eps, 100, s, 0, 1000) %>% mutate(q = q)

# combine all output
rbind(an_f1, an_f2, an_f3) -> an_f

# plot numerically calculated fitness for different N and q
p1 <- ggplot(an_f, aes(x = Ne, y = w_ave, color = factor(q))) +
  geom_line(size = 1, lineend = "round", linejoin = "round") +
  scale_color_manual(name = "q", values = c("#d3d4d8", "#3fbac2", "#4d606e")) +
  xlab("N") +
  ylab("Mean fitness") +
  scale_x_log10(limits = c(1, 1000), breaks = c(1, 10, 100, 1000), labels = c("1", "10", "100", "1000")) +
  coord_cartesian(ylim = c(0, 1)) +
  theme(
    axis.title = element_text(size = 14),
    axis.text = element_text(size = 12),
    legend.text = element_text(size = 11),
    legend.title = element_text(size = 12)
  )

# set parameters to be used in numerical derivations
N <- 10
s <- 0.01
an_f1 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

N <- 50
s <- 0.01
an_f2 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

N <- 100
s <- 0.01
an_f3 <- w_vs_eps(N, 100, s, -1, 1) %>% mutate(q = 1 - eps)

# combine all output
rbind(an_f1, an_f2, an_f3) -> an_f

# plot numerically calculated fitness for different N and q
p2 <- ggplot(an_f, aes(x = q,y = w_ave)) +
  geom_line(
    aes(color = factor(Ne)),
    size = 1.2,
    lineend = "round",
    linejoin = "round"
  ) +
  scale_color_manual(values = c("#f67280", "#c06c84", "#6c5b7c")) +
  scale_y_continuous(breaks = seq(0, 1, 0.2)) +
  coord_cartesian(ylim = c(0, 1)) +
  xlab('q') +
  ylab('Mean fitness') +
  guides(col = guide_legend(title = "N",reverse = TRUE))

p <- plot_grid(p1, p2, labels = c("A", "B"))

# save the plot
save_plot(
  paste0(root_dir, "/evolving_q_sim/plots/theoretical_fitness_s", s, ".png"),
  p,
  base_height = 4,
  base_width = 9
)


### Examen Parcial 2 - Inferencia Estadistica 2
### Sergio García Prado

rm(list = ls())

### Ejercicio 1
###############################################################################

### Ejercicio 1 - Apartado A

observed1 <- c(0.87, 0.20, 0.99, 0.40, 0.39, 0.72, 0.33, 0.88, 0.22, 0.45,
               0.01, 0.37, 0.59, 0.80, 0.93, 0.54, 0.66, 0.49, 0.73, 0.68)

(n1 <- length(observed1))
#20

## Función de distribución bajo hipótesis nula.
CummulativeH0 <- function(x) {
  ifelse(x < 0, 0,
  ifelse(1 < x, 1,
  (1 / 3) * x ^ 4 * (5 - 2 * x)))
}

## Por ser una hipótesis simple, podemos utilizar el test de kolgomorov-smirnov
test1 <- ks.test(observed1, CummulativeH0)

(D1 <- test1$statistic)
# 0.4149008

(pvalue1 <- test1$p.value)
# 0.001244618

## Nos vemos obligados a rechazar la hipótesis de que los datos observados
## pertenezcan a la distribución definida en la hipótesis nula.

### Ejercicio 1 - Apartado B

alpha <- 0.05

## Para simular la potencia calculamos el promedio sobre la variable indicador
## que toma el valor 1 cuando rechazamos la hipótesis nula, y 0 en cuando la
## aceptamos.

(power1 <- mean(replicate(1000, ks.test(runif(n1), CummulativeH0)$p.value < alpha)))
# 0.985

### Ejercicio 2
###############################################################################

# Fijamos el número de simulaciones bootstrap.
nsims2 <- 1000

observed2 <- c(2.27,2.28,0.05,0.56,0.59,1.21,0.46,1.74,1.66,0.66,1.94,0.33,
               0.33,0.22,2.16,1.69,0.45,1.13,1.00,1.85,1.28,7.61,0.03,0.86,
               0.66,3.84,1.42,0.80,0.25,5.03,2.23,0.83,4.33,1.35,0.91,0.87,
               0.06,6.80,1.62,0.02,0.05,3.40,0.72,1.58,0.53,0.90,0.35,0.95,
               0.95,0.46)

(n2 <- length(observed2))
# 50

(observed2.mean <- mean(observed2))
# 1.4654

(observed2.sd <- sd(observed2))
# 1.609788

## Generamos una muestra bootstrap paramétrica asumiendo una distribución
## normal en los datos.
bootstrap.sample <- matrix(rnorm(n = n2 * nsims2, mean = observed2.mean, sd = observed2.sd),
                           nsims2, n2)

bootstrap.mean <- rowMeans(bootstrap.sample)

## Utilizamos el mismo alpha que en el ejercicio anterior (alpha = 0.05)

quantile(bootstrap.mean, c(alpha / 2, 1 - alpha / 2))
# 2.5%     97.5%
# 1.054534 1.886941

### Ejercicio 3
###############################################################################

observed3 <- c(20, 18, 8, 14)

(k3 <- length(observed3))
# 4

(n3 <- sum(observed3))
# 60

### Ejercicio 3 - Apartado A

PoissonExpected <- function(n, k, lambda) {
  ## Método 1

  # n * c(dpois(0:(k - 2), lambda = lambda),
  #       ppois(k - 2, lambda = lambda, lower.tail = FALSE))

  ## Método 2:

  Probability <- function(x) {
    lambda ^ x * exp(- lambda) / factorial(x)
  }

  n * c(Probability(0:(k - 2)), 1 - sum(Probability(0:(k - 2))))
}

NegativeBinomialExpected <- function(n, k, size, prob) {
  ## Método 1

  # n * c(dnbinom(0:(k - 2), size = size, prob = prob),
  #       pnbinom(k - 2, size = size, prob = prob, lower.tail = FALSE))

  ## Método 2:

  Probability <- function(x) {
    (x + 1) * prob ^ 2 * (1 - prob) ^ x
  }

  n * c(Probability(0:(k - 2)), 1 - sum(Probability(0:(k - 2))))
}

(expected3 <- PoissonExpected(n3, k3, 1.2))
# 18.071653 21.685983 13.011590  7.230774

(Q3 <- sum((observed3 - expected3) ^ 2 / expected3))
# 9.099696

(pvalue3 <- 1 - pchisq(Q3, k3 - 1))
# 0.02799433

## Nos vemos obligados a rechazar la hipótesis nula (los datos siguen una
## distribución de Poisson(1.2)) en favor de la alternativa (no pertenecen
## a dicha distribución).

### Ejercicio 3 - Apartado B

(null3 <- PoissonExpected(n3, k3, 1.2))
# 18.071653 21.685983 13.011590  7.230774

(alternative3 <- NegativeBinomialExpected(n3, k3, 2, 2 / 3))
# 26.666667 17.777778  8.888889  6.666667

(Q3b <- sum((alternative3 - null3) ^ 2 / null3))
# 6.142462

(power3b <- 1 - pchisq(qchisq(1 - alpha, df = k3 - 1), df = k3 - 1, ncp = Q3b))
# 0.5286654

### Ejercicio 3 - Apartado C

fn <- function(n) {
  null <- PoissonExpected(n, k3, 1.2)
  alternative <- NegativeBinomialExpected(n, k3, 2, 2 / 3)
  Q <- sum((alternative - null) ^ 2 / null)
  power <- 1 - pchisq(qchisq(1 - alpha, df = k3 - 1), df = k3 - 1, ncp = Q)
  return(power)
}

(n.exact3 <- uniroot(function(n) {fn(n) - 0.9}, c(1, 1000))$root)
# 138.4281

ceiling(n.exact3)
# 139

## Necesitamos un tamaño muestral de 139 observaciones para poder obtener una
## potencia == 0.9 en el contraste acerca de si los datos siguen una
## distribución de Poisson(1.2) cuando realmente pertenecen a una distribución
## BinomialNegativa(2, 2/3)


install.packages('mvtnorm')
set.seed(123)

beta_rng <- rbeta(n=5, shape1=2.0, shape2=2.0)
#=> [1] 0.3449 0.4353 0.8756 0.5199 0.5364

dirichlet_rng <- gtools::rdirichlet(n=5, alpha=c(0.3, 1.0, 1.0))
#=>
#            [,1]    [,2]   [,3]
# [1,] 0.21866785 0.31802 0.4633
# [2,] 0.20875883 0.02787 0.7634
# [3,] 0.00001059 0.38163 0.6184
# [4,] 0.00161258 0.07058 0.9278
# [5,] 0.05304718 0.18960 0.7574

gamma_rng <- rgamma(n=5, shape=3.0, rate=1.0)
#=> [1] 4.081 3.968 3.707 3.453 2.403

bivariate_normal_rng <- mvtnorm::rmvnorm(n=5, mean=c(0, 1), sigma=matrix(c(2, 1, 1, 3), ncol=2))
#=>
#           [,1]    [,2]
# [1,] -0.002168 -0.9834
# [2,]  0.858101  2.5025
# [3,]  0.178217  3.0613
# [4,] -1.158147  1.3662
# [5,]  0.267530 -0.3769

cauchy_rng <- rcauchy(n=5, location=1, scale=2.5)
#=> [1]   1.757  24.867 -68.135  -6.695   5.314


### Code skeleton for Series 6, Exercise 1
### Please replace all triple questionmarks by some
### code.

set.seed(3)
(true.par <- mean(rgamma(100000000, shape = 2, rate = 2), trim = 0.1))

set.seed(1)
sample40 <- rgamma(n = 40, shape = 2, rate = 2)
mean(sample40, trim = 0.1)

###################################################
### TASK a)
###################################################
require("boot")
tm <- function(x, ind) {mean(x[ind], trim = 0.1)}

# nominal levels at which we want to evaluate coverage
levels <- c(round(seq(0.7, 0.99, 0.01), 2), round(seq(0.992, 0.996, 0.002), 3))
nl <- length(levels)
# desired coverage
conf <- 0.9

# outer layer
M <- 50
# inner layer and final estimate
B <- 500

# function called by the outer bootstrap
# estimates confidence intervals on second layer of bootstrap
boot.outer.fnn <- function(data, ind, B){
  res.boot.inner <- boot(data = data[ind], statistic = tm, R = B,
                         sim = "ordinary")
  bci <- boot.ci(res.boot.inner, conf = levels,
                 type = c("basic"))
  ci <- bci[["basic"]][,4:5]
  # returns theta_hat*, all lower bound and all upper bounds
  out <- c(res.boot.inner$t0, ci[,1], ci[,2])
  names(out) <- c("tm", paste("lower", levels, sep="_"), paste("upper", levels, sep="_"))
  out
}

# get the confidence interval on the nominal levels 1-alpha and 1-alpha' based on B samples
# this can be pulled from $t0
get.ci <- function(res.boot.outer, conf, level.prime) {
  if(!is.na(level.prime)) {
    level.indices <- c(which(levels == conf), which(levels == level.prime))
  } else {
    # if we don't find any applicable level, we cheat and use the highest available
    level.indices <- c(which(levels == conf), nl)
  }

  lower0 <- res.boot.outer$t0[2:(nl + 1)]
  upper0 <- res.boot.outer$t0[(nl + 2):(2*nl + 1)]

  matrix(cbind(lower0[level.indices], upper0[level.indices]), nrow = 2,
         dimnames =  list(c("basic", "double"), c("lower", "upper")))
}

res.boot.outer <-  boot(sample40, statistic = boot.outer.fnn, R = M, B = B)

# function to find 1 - alpha'
get.level.prime <- function(res.boot.outer, conf){
  thh <- res.boot.outer$t0[1]
  # 1 + 33 + 33
  lower <- res.boot.outer$t[, 2:34] # lower from 2 to 34
  upper <- res.boot.outer$t[, 35:67] # upper from 35 to 67
  included <- lower <= thh & thh <= upper
  colnames(included) <- levels
  cover <- apply(included, 2, mean)
  if(max(cover) >= conf){
    level.prime <- min(levels[cover >= conf])
  } else {
    # if we are unable to to receive the desired coverage
    level.prime <- NA
  }
  level.prime
}

(level.prime <- get.level.prime(res.boot.outer, conf))
get.ci(res.boot.outer, conf, level.prime)

###################################################
### TASK b, c)
###################################################

##' Checks if a confidence interval contains the true parameter (separately
##' for the lower and the upper end)
##'
##' @param ci: Output of the function boot.ci which contains CIs
##' @param ty: Type of confidence interval
##' @param true.par: True parameter
##'
##' @return Vector with two elements where first one corresponds to the lower
##'         end and the second to the upper end of the confidence interval.
##'         If the CI is [CI_l, CI_u], the first element is 1 if theta < CI_l
##'         and 0 otherwise. The second element is 1 if theta > CI_u and 0
##'         otherwise.
check_ci <- function(ci, ty, true.par) {
  # Get confidence interval of type ty from object ci
  lower.upper <- ci[ty,]

  res <- if (true.par < lower.upper[1]) {
    c(1, 0)
  } else if (true.par > lower.upper[2]) {
    c(0, 1)
  } else {
    c(0, 0)
  }
  names(res) <- c("lower", "upper")

  return(res)
}

##' Runs one simulation run, i.e. creates new data set, calculates bootstrap
##' CIs, and checks if true parameter is contained.
##'
##' @param n: Size of sample
##' @param true.par: True parameter
##' @param B: Number of bootstrap replicates in inner bootstrap
##' @param M: Number of bootstrap replicates in outer bootstrap
##' @param conf: desired coverage
##' @param type: Type of bootstrap CIs, only "basic" or "double"
##'
##' @return A vector containing the result of the function check_ci for each
##'         of the confidence intervals and the estimated 1-alpha'
do_sim <- function(n, true.par, B = 500, M = 50, conf = 0.9,
                   type = c("basic", "double")) {
  # Generate the data
  x <- rgamma(n = n, shape = 2, rate = 2)
  # Evaluate the double bootstrap
  res.boot.outer <-  boot(x, statistic = boot.outer.fnn, R = M, B = B)
  # find 1 - alpha'
  level.prime <- get.level.prime(res.boot.outer, conf)
  # find CIs at level 1-alpha and 1-alpha'
  res.ci <- get.ci(res.boot.outer, conf, level.prime)

  # Check if CIs contain true.par
  res <- vector(mode = "integer", length = 0)
  for (ty in type) {
    res <- c(res, check_ci(ci = res.ci, ty = ty, true.par = true.par))
    names(res)[(length(res) - 1):length(res)] <-
      paste(c(ty, ty), c("lower", "upper"), sep = "_") #add names in the format
    #'type_lower' and 'type_upper'
  }
  # store 1 - alpha' as well
  res <- c(res, level.prime)
  names(res)[length(res)] <- "level.prime"

  return(res)
}

##########################
### Run simulation     ###
##########################
set.seed(22)
require("boot")
sample.size <- c(10, 40, 160, 640)
n.sim <- 200
type <- c("basic", "double")

# The object RES stores the results, i.e. each row corresponds
# to the non-coverage rate for the lower and upper ends of the
# confidence intervals, i.e. the percentage of times that theta < CI_l
# and the percentage of times that theta > CI_u, if the CI is
# denoted by (CI_l, CI_u). Further we add one column for the median of the estimated 1 - alpha',
# one for the fraction of times we could not find 1 - alpha' and one for n.
RES <- matrix(NA, nrow = length(sample.size), ncol = 7)
colnames(RES) <- c(paste(rep(type, each = 2),
                         rep(c("lower", "upper"), times = length(type)),
                         sep = "_"), "median_level_prime", "NA_fraction", "n")

for (j in 1:length(sample.size)) {
  n <- sample.size[j]
  cat("n =",  n ,"\n")
  # The object res.sim stores the results, i.e. each row corresponds
  # to the output of the function do_sim. This means that each row contains 0
  # and 1 encoding whether the true parameter was inside the CI or outside
  # as well as 1 - alpha'.
  res.sim <- matrix(NA, nrow = n.sim, ncol = length(type) * 2 + 1)
  for (i in 1:n.sim) {
    cat("."); if(i %% 20 == 0) cat(i ,"\n")
    # Simulate one data-set
    res.sim[i, ] <- do_sim(n = n, true.par = true.par, type = type)
  }
  # Compute the upper and lower non-coverage rate, the median of 1 - alpha'
  # and the fraction of simulation runs, where we did not find 1 - alpha'
  RES[j, ] <- c(apply(res.sim[,1:(length(type) * 2)], 2, mean),
                median(res.sim[,(length(type) * 2) + 1 ], na.rm = TRUE),
                mean(is.na(res.sim[,(length(type) * 2) + 1 ])), n)
}

y.lim <- max(RES[, 1:(length(type) * 2)])

# Plot of lower non-coverage
plot(basic_lower ~ n, data = RES, col = 1, pch = 1, ylim = c(0, y.lim),
     log = "x", ylab = "One-sided non-coverage",
     main = "Non-coverage of the lower end of the CIs.")
points(double_lower ~ n, data = RES, col = 2, pch = 2, xlog = TRUE)
lines(basic_lower ~ n, data = RES, col = 1, lty = 1, xlog = TRUE)
lines(double_lower ~ n, data = RES, col = 2, lty = 2, xlog = TRUE)
abline(h = 0.05, lty = 5)
legend("topright", legend = c("reversed", "double bootstrap"),
       pch = 1:2, lty = 1:2, col = 1:2)

# do it analogously for the upper non-coverage


# quick examples ==============================================
x <- matrix(rnorm(100), ncol = 10)

quantile(x[, 1], probs = c(.2, .4, .6))

apply(x, MARGIN = 1, FUN = quantile, probs = c(.2, .4, .6), na.rm = TRUE)

tapply(X = salmon$weight,
       INDEX = list(salmon$river, salmon$year),
       FUN = mean, na.rm = TRUE)

# 6.1.1 ===========================================================

#Subset salmon data for columns year, weight, length & julian.day and store as salmon.num
salmon.num <- salmon[ , c('year', 'julian.day', 'length', "weight")]
head(salmon.num)

#Use apply() to calculate the mean of the columns
apply(salmon.num, MARGIN = 2, FUN = mean, na.rm = TRUE)

#Use apply() to compute quantiles 0.2, 0.4, 0.6, 0.8
apply(salmon.num, MARGIN = 2, FUN = quantile,
      probs = seq(0.2, 0.8, .2), na.rm = TRUE)

#Calculate mean size of fish by (use tapply())
#year
#year and sea age
tapply(salmon$weight,
       INDEX = list(salmon$year, salmon$sea.age),
       #INDEX = list(salmon$year, salmon$sea.age, salmon$river.age),
       FUN = mean, na.rm = TRUE)

seq(0.1, 0.8, .2)

# for loops ==========================================================

x <- rep(NA, 9)
for(a in 2:9){
  #print(a + 3)
  #x[a] <- a + 3
  #print(paste('result =', a + 3, sep = ' '))
  print(paste('plot', a + 3, '.tiff', sep = '@'))
}
x

#==================================================================

list.rivers <- levels(salmon$river)

for(river in list.rivers){
  #salmon.subset <- salmon[salmon$river == river, ]
  #file.name <- paste('salmon', river, 'txt', sep = '.')
  #write.table(salmon.subset, file = file.name, row.names = FALSE, sep = ',')
  write.table(salmon[salmon$river == river, ],
              file = paste('salmon', river, 'txt', sep = '.'),
              row.names = FALSE, sep = ',')
}

list.years <- unique(salmon$year)
#list.years <- list.years[1:(length(list.years) - 1)]
list.years <- list.years[! is.na(list.years)]
#list.years <- head(list.years, n = - 1)

for(year in list.years){
  #salmon.subset <- salmon[salmon$year == year, ]
  #file.name <- paste('salmon', year, 'txt', sep = '.')
  #write.table(salmon.subset, file = file.name, row.names = FALSE, sep = ',')
  write.table(salmon[salmon$year == year, ],
              file = paste('salmon', year, 'txt', sep = '.'),
              row.names = FALSE, sep = ',')
}


### Code skeleton for Series 5, Exercise 2
### Please replace all triple questionmarks by some
### code.

###################################################
### TASK a)
###################################################
set.seed(3)
(true.par <- mean(rgamma(100000000, shape = 2, rate = 2), trim = 0.1))

print(true.par)

###################################################
### TASK b)
###################################################
set.seed(1)
sample40 <- rgamma(n = 40, shape = 2, rate = 2)

print(mean(sample40, trim = 0.1))

###################################################
### TASK c)
###################################################
require("boot")
tm <- function(x, ind) {mean(x[ind], trim = 0.1)}

res.boot <- boot(data = sample40, statistic = tm, R = 10000,
                 sim = "ordinary")
print(boot.ci(res.boot, conf = 0.95, type = c("basic", "norm", "perc")))

###################################################
### TASK d)
###################################################

##' Checks if a confidence interval contains the true parameter (separately
##' for the lower and the upper end)
##'
##' @param ci: Output of the function boot.ci which contains CIs
##' @param ty: Type of confidence interval
##' @param true.par: True parameter
##'
##' @return Vector with two elements where first one corresponds to the lower
##'         end and the second to the upper end of the confidence interval.
##'         If the CI is [CI_l, CI_u], the first element is 1 if theta < CI_l
##'         and 0 otherwise. The second element is 1 if theta > CI_u and 0
##'         otherwise.
check_ci <- function(ci, ty, true.par) {
  # Get confidence interval of type ty from object ci
  lower.upper <- switch (ty,
                         "norm" = ci[["normal"]][2:3],
                         "perc" = ci[["percent"]][4:5],
                         "basic" = ci[["basic"]][4:5]
  )

  res <- if (true.par < lower.upper[1]) {
    c(1, 0)
  } else if (true.par > lower.upper[2]) {
    c(0, 1)
  } else {
    c(0, 0)
  }
  names(res) <- c("lower", "upper")

  return(res)
}

##' Runs one simulation run, i.e. creates new data set, calculates bootstrap
##' CIs, and checks if true parameter is contained.
##'
##' @param n: Size of sample
##' @param true.par: True parameter
##' @param R: Number of bootstrap replicates
##' @param type: Type of bootstrap CIs, see function boot.ci
##'
##' @return A vector containing the result of the function check_ci for each
##'         of the confidence intervals
do_sim <- function(n, true.par, R = 500,
                   type = c("basic", "norm", "perc")) {
  # Generate the data
  x <- rgamma(n = 40, shape = 2, rate = 2)
  # Construct the CIs for the trimmed mean
  res.boot <- boot(data = x, statistic = tm, R = R, sim = "ordinary")
  res.ci <- boot.ci(res.boot, conf = 0.95, type = type)

  # Check if CIs contain true.par
  res <- vector(mode = "integer", length = 0)
  for (ty in type) {
    res <- c(res, check_ci(ci = res.ci, ty = ty, true.par = true.par))
    names(res)[(length(res) - 1):length(res)] <-
      paste(c(ty, ty), c("lower", "upper"), sep = "_") #add names in the format
                                                       #'type_lower' and 'type_upper'
  }

  return(res)
}

##########################
### Run simulation     ###
##########################
set.seed(22)
require("boot")
sample.size <- c(10, 40, 160, 640)
n.sim <- 200
type <- c("basic", "norm", "perc")

# The object RES stores the results, i.e. each row corresponds
# to the non-coverage rate for the lower and upper ends of the
# confidence intervals, i.e. the percentage of times that theta < CI_l
# and the percentage of times that theta > CI_u, if the CI is
# denoted by (CI_l, CI_u). The last column of RES corresponds to
# the number of observations.
RES <- matrix(NA, nrow = length(sample.size), ncol = length(type) * 2 + 1)
colnames(RES) <- c(paste(rep(type, each = 2),
                         rep(c("lower", "upper"), times = length(type)),
                         sep = "_"), "n")

for (j in 1:length(sample.size)) {
  n <- sample.size[j]
  # The object res.sim stores the results, i.e. each row corresponds
  # to the output of the function do_sim. This means that each row contains 0
  # and 1 encoding whether the true parameter was inside the CI or outside.
  # Also see the function check_ci.
  res.sim <- matrix(NA, nrow = n.sim, ncol = length(type) * 2)
  for (i in 1:n.sim) {
    # Compute CIs and check if true.par is contained in them
    res.sim[i, ] <- do_sim(n = n, true.par = true.par, type = type)
  }
  # Compute the upper and lower non-coverage rate
  RES[j, ] <- c(apply(res.sim, 2, mean), n)
}

print(RES)

###################################################
### TASK e)
###################################################
y.lim <- max(RES[, -ncol(RES)])

# Plot of lower non-coverage
plot(basic_lower ~ n, data = RES, col = 1, pch = 1, ylim = c(0, y.lim),
     log = "x", ylab = "One-sided non-coverage",
     main = "Non-coverage of the lower end of the CIs.")
points(norm_lower ~ n, data = RES, col = 2, pch = 2, xlog = TRUE)
points(perc_lower ~ n, data = RES, col = 3, pch = 3, xlog = TRUE)
lines(basic_lower ~ n, data = RES, col = 1, lty = 1, xlog = TRUE)
lines(norm_lower ~ n, data = RES, col = 2, lty = 2, xlog = TRUE)
lines(perc_lower ~ n, data = RES, col = 3, lty = 3, xlog = TRUE)
abline(h = 0.025, lty = 5)
legend("topright", legend = c("quantile", "normal", "reverse"),
       pch = 1:3, lty = 1:3, col = 1:3)

# do it analogously for the upper non-coverage


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 2   Chapter : 3.6     Page No: 188
# Dimensions and rank of matrix
library(pracma)
solution<-function(A){
  print(paste("Number of rows , m=",nrow(A)))
  print(paste("Number of columns,n=",ncol(A)))
  print(paste("Rank of the given matrix",Rank(A)))
}
A<-matrix(c(1,2,2,4,3,6),nrow=2)
solution(A)


luhnTest <- function(cc){
  # Reverse the digits, convert to numeric vector
  cc2 <- as.numeric(unlist(strsplit(as.character(cc), "")))[nchar(cc):1]

  s1 <- 0
  s2 <- 0

  for (index in 1:length(cc2)){
    if (index %% 2 == 1){
      s1 <- sum(s1, cc2[index])
    } else if (cc2[index] >= 5){
      s2 <- sum(s2, (cc2[index]*2 - 9))
    } else {
      s2 <- sum(s2, (cc2[index]*2))
    }
  }

  return ((s1 + s2) %% 10 == 0)
}