library(data.table)
library(ggplot2)
library(here)
library(boot) # alternate to verify long-hand calcs

data.dir <- paste0(here::here(), "/datasets/")

# gamma example

my.sample <- rgamma(16, 1, 1/2)
N <- 10e5

my.boot <- numeric(N)

for(i in 1:N)
{
  x <- sample(x = my.sample, size = length(my.sample), replace = T)
  my.boot[i] <- mean(x)
}

ggplot(data.table(value = my.sample), aes(value, fill = ..count..)) +
  geom_histogram(bins = 8)

ggplot(data.table(value = my.boot), aes(value, fill = ..count..)) +
  geom_histogram(bins = 30)

mean(my.boot)
sd(my.boot)

### Bangladesh

Bangladesh <- data.table(read.csv(paste0(data.dir, "Bangladesh.csv"),
                                  header = T))

Arsenic <- Bangladesh$Arsenic

mean(Arsenic) #  sample mean

ggplot(data.table(value = Arsenic)) +
  geom_histogram(aes(value, fill = ..count..), bins = 30) +
  scale_x_continuous(labels = comma) +
  labs(title = "Arsenic")

ggplot(data.table(value = Arsenic), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Arsenic")

n <- length(Arsenic)
N <- 10e3

arsenic.mean <- numeric(N)

for(i in 1:N)
{
  x <- sample(Arsenic, n, replace = T)
  arsenic.mean[i] <- mean(x)
}

ggplot(data.table(value = arsenic.mean)) +
  geom_histogram(aes(value, fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(arsenic.mean), col = "darkorange", alpha = .6, lwd = 2) +
  scale_y_continuous(labels = comma) +
  labs(title = "Arsenic Bootstrap Distribution of Means")

ggplot(data.table(value = arsenic.mean), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Arsenic")

mean(arsenic.mean) # Bootstrap mean
mean(arsenic.mean) - mean(Arsenic) # bias
sd(arsenic.mean) # bootstrap SE

# this is not accurate: CLT cannot be used here
lq <- mean(arsenic.mean) - 1.96 * sd(arsenic.mean)
uq <- mean(arsenic.mean) + 1.96 * sd(arsenic.mean)

sum(arsenic.mean < lq) / N
sum(arsenic.mean > uq) / N

alpha <- .05
quantile(arsenic.mean, c(alpha/2, 1 - alpha/2)) # confidence intervals

boot.fn <- function(data, index) {
  mean(data[index])
}

arsenic.boot <- boot(Arsenic, boot.fn, R = N)

### NC birth weights

NCBirths <- data.table(read.csv(paste0(data.dir, "NCBirths2004.csv"),
                                header = T))

weights <- NCBirths$Weight

boot.fn <- function(data, index) {
  mean(data[index])
}

bw.boot <- boot(weights, boot.fn, R = 1000)

# long-hand

N <- 1e5
bw.mean <- numeric(N)

for(i in 1:N)
{
  x <- sample(weights, size = length(weights), replace = T)
  bw.mean[i] <- mean(x)
}

alpha <- 0.05
conf <- quantile(bw.mean, c(Lower = alpha/2, Upper = 1 - alpha/2))

# NC Birth weights, bootstrapped

ggplot(data.table(values = bw.mean), aes(values)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(weights), col = "darkorange", alpha = .4, lwd = 1) +
  geom_vline(xintercept = conf[1], col = "cornflowerblue") +
  geom_vline(xintercept = conf[2], col = "cornflowerblue") +
  geom_rug(col = "darkred") +
  scale_x_continuous(labels = scales::comma) +
  scale_y_continuous(labels = scales::comma)

### testosterone study

Skateboard <- data.table(read.csv(paste0(data.dir, "Skateboard.csv"),
                                  header = T))

testF <- Skateboard[Experimenter == "Female"]$Testosterone
testM <- Skateboard[Experimenter == "Male"]$Testosterone

nf <- length(testF)
nm <- length(testM)

N <- 10e4
TestMean <- numeric(N)

for(i in 1:N)
{
  sampleF <- sample(testF, nf, replace = T)
  sampleM <- sample(testM, nm, replace = T)

  TestMean[i] <- mean(sampleF) - mean(sampleM)
}

ggplot(data.table(result = TestMean), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(testF) - mean(testM), col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Bootstrap distribution of difference in means")

ggplot(data.table(value = TestMean), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Testosterone")

# bootstrap statistics

mean(testF) - mean(testM)
mean(TestMean)

sd(TestMean)

quantile(TestMean, c(0.025, .975)) # confidence intervals

mean(TestMean) - ( mean(testF - mean(testM)) ) # bias

observed <- mean(testF) - mean(testM)

result <- numeric(N)

for(i in 1:N)
{
  index <- sample(nf + nm, nf, replace = F)
  result[i] <- mean(Skateboard[index]$Testosterone) - mean(Skateboard[-index]$Testosterone)
}

p <- (sum(result >= observed) + 1) / (N + 1)

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Permutation Test: Difference in means")

ggplot(data.table(value = result), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Testosterone Permutation Test")

### Verizon data

# Is the average repair time lower for ILEC lower than CLEC customers?

Verizon <- data.table(read.csv(paste0(data.dir, "Verizon.csv"),
                               header = T))

Time.ILEC <- Verizon[Group == "ILEC"]$Time
Time.CLEC <- Verizon[Group == "CLEC"]$Time

observed <- mean(Time.ILEC) - mean(Time.CLEC)

ggplot(data.table(values = Time.ILEC), aes(values)) +
  geom_histogram(aes(y = ..density.., fill = ..count..), bins = 30) +
  geom_density(aes(y = ..density..), col = "darkorange")

ggplot(data.table(values = Time.CLEC), aes(values)) +
  geom_histogram(aes(y = ..density.., fill = ..count..), bins = 30) +
  geom_density(aes(y = ..density..), col = "darkorange")

# bootstrap difference in means

set.seed(123)

N <- 10e4
results <- numeric(N)

N.ILEC <- length(Time.ILEC)
N.CLEC <- length(Time.CLEC)

for(i in 1:N)
{
  ilec <- sample(Time.ILEC, N.ILEC, replace = T)
  clec <- sample(Time.CLEC, N.CLEC, replace = T)

  results[i] <- mean(ilec) - mean(clec)
}

alpha <- 0.05
observed - mean(results) # Bias

sd(results)

quantile(results, c(Lower = alpha/2, Upper = 1 - alpha/2))

aov(Time ~ Group, data = Verizon)

# ratio of means test

observed <- mean(Time.ILEC) / mean(Time.CLEC)

N <- 10e3
time.ratio.mean <- numeric(N)
for(i in 1:N)
{
  ILEC.sample <- sample(Time.ILEC, length(Time.ILEC), replace = T)
  CLEC.sample <- sample(Time.CLEC, length(Time.CLEC), replace = T)

  time.ratio.mean[i] <- mean(ILEC.sample) / mean(CLEC.sample)
}

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Permutation Test: Difference in means")

result <- numeric(N)

for(i in 1:N)
{
  index <- sample(nrow(Verizon), length(Time.CLEC), replace = F)
  result[i] <- mean(Verizon[index]$Time) / mean(Verizon[-index]$Time)
}

observed - mean(time.ratio.mean) # bias
sd(time.ratio.mean) # standard error

quantile(time.ratio.mean, c(0.025, .975))

time.ratio.bias <- mean(time.ratio.mean) - mean(Time.ILEC)/mean(Time.CLEC) # Bias

time.ratio.bias / sd(time.ratio.mean)

# Significance
p <- (sum(result >= observed) + 1) / ( N + 1)

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  scale_y_continuous(labels = comma) +
  labs(title = "Permutation Test: Difference in means")


# K Means Clustering
library(cluster)
data(iris)

iris$Species <- as.numeric(iris$Species)
kmeans <- kmeans(x = iris, centers = 5)
clusplot(
    iris,
    kmeans$cluster,
    color = TRUE,
    shade = TRUE,
    labels = 13,
    lines = 0
)

# Elbow Method
library(cluster)
library(ggplot2)
data(iris)

iris$Species <- as.numeric(iris$Species)
cost_df <- data.frame()
for (i in 1:100) {
    kmeans <- kmeans(x = iris, centers = i, iter.max = 50)
    cost_df <- rbind(cost_df, cbind(i, kmeans$tot.withinss))
}
names(cost_df) <- c("cluster", "cost")
cost_df

ggplot(data = cost_df, aes(x = cluster, y = cost, group = 1)) +
    theme_bw(base_family = "D2Coding") +
    geom_line(colour = "darkgreen") +
    theme(text = element_text(size = 10)) +
    ggtitle("Reduction in cost for values of 'k'\n") +
    xlab("Clusters") +
    ylab("Within-Cluster Sum of Sqarea\n")


load.packages('quantmod')
load.packages('PerformanceAnalytics')
load.packages('ggplot2')
load.packages('forecast')
load.packages('tseries')
load.packages('FitAR')

data <- new.env()

getSymbols('JPM', src = 'yahoo', env = data, auto.assign = T)

JPM = JPM["2018-02-01/2018-12-30"]
JPM = JPM[, "JPM.Adjusted"]

plot(JPM)

# Calculating the average stock price of JPM
jpm_avg <- sum(JPM)/length(JPM)
jpm_avg

# Calculating the standard deviation of the JPM stock price
jpm_std <- StdDev(JPM)
jpm_std

# Calculating the daily JPM stock return
jpm_log_ret <- diff(log(JPM))
jpm_log_ret

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

getSymbols("^GSPC", src = 'yahoo', env = data, auto.assign = T)

GSPC <- GSPC["2018-02-01/2018-12-30"]
GSPC <- GSPC[, "GSPC.Adjusted"]

two_reg_data <- cbind(JPM, GSPC)

scatter.smooth(x=two_reg_data$JPM.Adjusted, y=two_reg_data$GSPC.Adjusted, main="JPM ~ GSPC", xlab= "JPM Closing Price", ylab= "S&P500 Closing Price")  # scatterplot

# Producing a linear model with S&P500 close prices as the explanatory variable.
linearModel <- lm(JPM.Adjusted ~ GSPC.Adjusted, data = two_reg_data)
summary(linearModel)

# Reading in the CSUSHPINSA monthly data
csushpinsa <- read.csv("https://fred.stlouisfed.org/graph/fredgraph.csv?bgcolor=%23e1e9f0&chart_type=line&drp=0&fo=open%20sans&graph_bgcolor=%23ffffff&height=450&mode=fred&recession_bars=on&txtcolor=%23444444&ts=12&tts=12&width=1168&nt=0&thu=0&trc=0&show_legend=yes&show_axis_titles=yes&show_tooltip=yes&id=CSUSHPINSA&scale=left&cosd=1987-01-01&coed=2019-03-01&line_color=%234572a7&link_values=false&line_style=solid&mark_type=none&mw=3&lw=2&ost=-99999&oet=99999&mma=0&fml=a&fq=Monthly&fam=avg&fgst=lin&fgsnd=2009-06-01&line_index=1&transformation=lin&vintage_date=2019-06-17&revision_date=2019-06-17&nd=1987-01-01")
csushpinsa = csushpinsa$CSUSHPINSA

# Confirm that we now have a simple list of doubles for values
typeof(csushpinsa)

csushpinsa = ts(csushpinsa, start = c(1987,1), frequency = 12)

csushpinsa

# Augmented Dickey-Fuller Test
df <- adf.test(csushpinsa)
df # The p-value of 0.4609 here means that we accept the null hypothesis of non-stationarity

# Using Box-Jenkins to explore the parameters for an ARIMA model
T = length(csushpinsa)

csush0 = csushpinsa[-1]
csush1 = csushpinsa[-T]

lag_csush = cbind(csush0, csush1)

plot(lag_csush, main = "T[x] vs T[x-1] for Case Shiller Index Values")

cor(csush0, csush1)

acf(csushpinsa, lag.max = 20, plot = TRUE) # Linear decay => non-stationary

pacf(csushpinsa, lag.max = 20, plot = TRUE)

d_csush = diff(csushpinsa)
d_csush

plot(d_csush) # More stationary than the original data

acf(d_csush, lag.max = 20, plot = TRUE) # Far quicker decay than the original data
pacf_dcsush <- pacf(d_csush, lag.max = 20, plot = TRUE) # Cuts off after lag 1.

# Using auto-fit to detect best model to use via AIC and MLE minimisation
auto.arima(csushpinsa, trace = TRUE)

# The above suggests ARIMA(3,1,2) with drift. No lower AIC can be found.
model <- arima(csushpinsa, order = c(3, 1, 2))
model

# Determine the confidence intervals for the parameters of the ARIMA(3,1,2) model.
confint(model, level = 0.995)

# Calculate the residuals from the model - checking for goodness-of-fit.
model_resid = resid(model)
model_resid

# Residuals seem relatively stationary.
plot(csushpinsa, model_resid, ylab="Residuals", xlab="Observations")
abline(0,0)

# Residual differentials look a lot like white noise, gaining intensity later on.
resid_diff = diff(model_resid)
plot(resid_diff)

# Residual differentials appear to mostly fall along a normal distribution.
qqnorm(resid_diff)

plot(acf(model_resid), main = "Autocorrelation of ARIMA(3,1,2) Residuals")
plot(pacf(model_resid), main = "Partial autocorrelation of ARIMA(3,1,2) Residuals")

boxresult = LjungBoxTest(model_resid,k=2,lag.max =5,StartLag=1)
plot(boxresult[,3],main= "Ljung-Box Q Test", ylab= "P-values", xlab= "Lag") # All well above 0.05, indicating non-significance.

# Having checked that the residuals appear to be normally distributed, we go on to produce a forecast using the model.
predict(model,n.ahead = 12)
plot(forecast(model,h=12, level=c(99.5)))

# The prediction for April 2019 (one month after the latest data) has:
# Forecast  208.0465, Lo99.5  207.1655, Hi99.5  208.9276.

# Potential exogenous variables to improve forecasting ability: mortgage rate, personal income, delinquency rate on mortgages, home ownership rate.


library("car")
data("Leinhardt")

head(Leinhardt)
str(Leinhardt)
pairs(Leinhardt)

plot(infant ~ income, data=Leinhardt)
hist(Leinhardt$infant)
hist(Leinhardt$income)

Leinhardt$loginfant = log(Leinhardt$infant)
Leinhardt$logincome = log(Leinhardt$income)

plot(loginfant ~ logincome, data=Leinhardt)

###Modeling
lmod = lm(loginfant ~ logincome, data=Leinhardt)
summary(lmod) # estimates of coefficents very large in comparison to their standard error, showing statistical significance
              #r-squared tells us how much of the variability is explained by model

dat = na.omit(Leinhardt)
#Leinhardt

library("rjags")

# likelyhood is a normal distribution  p(y|mu)
# use a linearn model to draw mu
# prior on the leniar model coeficents is a normal distribution with 2 coefecients, mean =0 and a variance = 1m
# sig^2: inverse gamma for the variance == gamma prior on precision
# lower the sample size of prior if we are not so confident in guess
mod1_string =" model {
    for (i in 1:n){
        y[i] ~ dnorm(mu[i], prec)
        mu[i] = b[1] + b[2]*log_income[i]
    }

    for (j in 1:2){
        b[j] ~ dnorm(0.0, 1.0/1.0e6)
    }

    prec ~ dgamma(5.0/2.0, 5.0*10.0/2.0)
    sig2 = 1.0 / prec
    sig = sqrt(sig2)

} "

set.seed(72)
data1_jags = list(y=dat$loginfant, n=nrow(dat), log_income=dat$logincome)

# choose to monitor standard dev
params1 = c("b", "sig")

inits1 = function() {
    inits = list("b"=rnorm(2, 0.0, 100.0), "prec"=rgamma(1,1.0,1.0))
}

# run the model with 3 chains each starting with inits1 params
mod1 = jags.model(textConnection(mod1_string), data=data1_jags, inits=inits1, n.chains=3)

#posterior mean diviance -2*log(likelyhood)
#penalty ~= number of params in model
#lower dic = better fit of model
dic.samples(mod1, n.iter=1e3)

# burn in period
update(mod1, 1000)

mod1_sim = coda.samples(model=mod1, variable.names=params1, n.iter=5e3)

# stack matrices vertically
mod1_csim = do.call(rbind, mod1_sim)

### Convergence
plot(mod1_sim)
gelman.diag(mod1_sim)
autocorr.diag(mod1_sim)
effectiveSize(mod1_sim)
summary(mod1_sim)
summary(lmod)

### Residuals differece between response the actual obsevation and the models prediction for each value
# very important as they revieal violations with our assumptions to specify mode
# looking for signs of non liniarity, not normally distributed, obsevation are not independent from one another
lmod0 = lm(infant ~ income, data=Leinhardt)
plot(resid(lmod0)) # assume independence if no patterns seen
plot(predict(lomd0), resid(lmod0)) # want to see randomness
qqnorm(resid(lmod0)) # check for normality, if nomal posint follow straight line, curves shows squew

X = cbind(rep(1.0, dat1_jags$n), data1_jags$log_income)

pm_params1 = colMeans(mod1_csim)

yhat = drop(X %*% pm_params1[1:2]) #vector of predicated values from model
resid1 = data1jags$y - yhat1
plot(resid1)
plot(yhat, resid1)
qqnorm(resid1)

head(rownames(dat)[order(resid1, decreasing=TRUE)])


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

#tendencia linear hold
autoplot(austres)
mdl1 = holt(austres, h=16)
autoplot(mdl1)
mdl1$model

mdl2 = holt(austres,alpha = 0.2,   h=16)
autoplot(mdl2)

#compara as duas previs?es
plot(mdl1)
lines(mdl2$mean, col="red")

#tendencia amortecida
mdl3 = holt(austres,damped = T, phi = 0.9,  h=16)
autoplot(mdl3)

#mudamos phi
mdl4 = holt(austres,damped = T, phi = 0.8,  h=16)
autoplot(mdl4)

#comparar os modelos
plot(mdl3)
lines(mdl4$mean, col="red")

#compara as duas previsoes
print(mdl3$mean)
print(mdl4$mean)

#holt winter - sazonal
#aditivo
mdl5 = hw(JohnsonJohnson,seasonal = "additive", h=16)
autoplot(mdl5)

#multiplicativo
mdl6 = hw(JohnsonJohnson,seasonal = "multiplicative", h=16)
autoplot(mdl6)

#comparar os modelos
plot(mdl5)
lines(mdl6$mean, col="red")

#comparando textual
print(mdl5$mean)
print(mdl6$mean)

#multiplicativo amortecido
mdl7 = hw(JohnsonJohnson,seasonal = "multiplicative", damped = T, phi = 0.9,h=16)
autoplot(mdl7)

#ets
mdl8 = ets(JohnsonJohnson)
print(mdl8)

autoplot(mdl8$residuals)
autoplot(mdl8$fitted)

prev = forecast(mdl8, h=16,levels=c(85,90))
print(prev$mean)
autoplot(prev)

autoplot(decompose(JohnsonJohnson))

mdl9 = ets(JohnsonJohnson, model = "ZAA", damped = T)
print(mdl9)

mdl10 = ets(JohnsonJohnson, model = "ZZZ", damped = T)
print(mdl10)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/7.2.R Suavizacao Exponencial.r


# Source: https://www.kaggle.com/juejuewang/handle-missing-values-in-time-series-for-beginners
# Author: Nishant Singh - https://www.datacamp.com/profile/NishantKumarSingh

library(imputeTS)

View(tsAirgap)

plot(tsAirgap, main="AirPassenger data with missing values")

statsNA(tsAirgap)

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

# General imputation methods

par(mfrow=c(2,2))
# Mean Imputation
plot(na_mean(tsAirgap, option = "mean") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Mean")
mean((na_mean(tsAirgap, option = "mean") - AirPassengers)^2)

# Median Imputation
plot(na_mean(tsAirgap, option = "median") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Median")
mean((na_mean(tsAirgap, option = "median") - AirPassengers)^2)

# Mode Imputation
plot(na_mean(tsAirgap, option = "mode") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Mode")
mean((na_mean(tsAirgap, option = "mode") - AirPassengers)^2)

# Random Imputation
plot(na_random(tsAirgap) - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Random")
mean((na_random(tsAirgap) - AirPassengers)^2)

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

#TS specific imputation methods

par(mfrow=c(2,2))
# Last Observartion Carried Forward
plot(na_locf(tsAirgap, option = "locf") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "LOCF")
m1 <- mean((na_locf(tsAirgap, option = "locf") - AirPassengers)^2)

# Next Observartion Carried Backward
plot(na_locf(tsAirgap, option = "nocb") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "NOCB")
m2 <- mean((na_locf(tsAirgap, option = "nocb") - AirPassengers)^2)

# Linear Interpolation
plot(na_interpolation(tsAirgap, option = "linear") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Linear")
m3 <- mean((na_interpolation(tsAirgap, option = "linear") - AirPassengers)^2)

# Spline Interpolation
plot(na_interpolation(tsAirgap, option = "spline") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Spline")

m4 <- mean((na_interpolation(tsAirgap, option = "spline") - AirPassengers)^2)

data.frame(methods=c('LOCF', 'NACB', 'Linear', 'Spline'), MSE=c(m1, m2, m3, m4))

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

#Combined imputation approach

par(mfrow=c(2,2))
# Seasonal Adjustment then Random
plot(na_seadec(tsAirgap, algorithm = "random") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Random")
ma1 <- mean((na_seadec(tsAirgap, algorithm = "random") - AirPassengers)^2)

# Seasonal Adjustment then Mean
plot(na_seadec(tsAirgap, algorithm = "mean") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Mean")
ma2 <- mean((na_seadec(tsAirgap, algorithm = "mean") - AirPassengers)^2)

# Seasonal Adjustment then LOCF
plot(na_seadec(tsAirgap, algorithm = "locf") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> LOCF")
ma3 <- mean((na_seadec(tsAirgap, algorithm = "locf") - AirPassengers)^2)

# Seasonal Adjustment then Linear Interpolation
plot(na_seadec(tsAirgap, algorithm = "interpolation") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Linear")

ma4 <- mean((na_seadec(tsAirgap, algorithm = "interpolation") - AirPassengers)^2)

data.frame(methods=c("Seas-Adj+Random", "Seas-Adj+Mean", "Seas-Adj+LOCF","Seas-Adj+Linear"),
           MSE=c(ma1, ma2, ma3, ma4))


library(lattice)

print("This is a Getting Started")
x <- 1
print(x)

x1 <- 'a'
print(x)

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

x3 <- c(x2, x2)
print(x3)

x4 <- 1:4
print(x4)

seq(1,4)
seq(1,4, by=2)

x <- 5:10
print(x)
print(x > 7)

x[2] <- 40
sort(x)
print(x)

matrix(c(1,2,3,4,5,6), nrow=2)
matrix(c(1,2,3,4,5,6), nrow=1)
matrix(c(1,2,3,4,5,6), nrow=6)
matrix(c(1,2,3,4,5,6), nrow=6, byrow = T)
matrix(c(1,2,3,4,5,6), nrow=2, byrow = T)

A <- matrix(c(1,2,3,4,5,6), nrow=2, byrow = T)
dimnames(A)

factor(c("alto", "bajo", "medio"))
x <- data.frame(matrix(1:12, ncol=4))
print(x)

list(c(1,2,3), x)
x <- data.frame(matrix(1:12, ncol=4))
print(x)

A <- matrix(c(1,2,3,4,5,6), nrow=2)
print(A)

A <- data.frame(matrix(1:12, ncol=4))
print(A)
apply(A, 1, mean)
print(A)

f <- factor(c(rep("A",2), rep("B",3)))
print(f)

sapply(x,mean)

x <- 1:10
y <- c(rep("A",5), rep("B",5))

split(x,y)

print(x)
print(y)

cut(x,3)

print(A)
print(x)

x <- matrix(c(1:12), nrow=4 )
print(x)

print(A * x)

A <- matrix(c(1:12), nrow=3 )
B <- matrix(c(1:12), nrow=4 )

print(A)
print(B)

S <- t(A) * B
print(S)
S <- A %*% B
print(S)

x <- runif(50,0,4)
y <- runif(50,0,4)

plot(x,y)

y <- runif(50,0,40)
plot(x,y)

y <- runif(50,0,40)
y <- runif(50,0,40)
plot(x,y)

y <- runif(50,0,4)
plot(x,y)
plot(x,y, asp=1)

y <- runif(50,0,40)
plot(x,y, asp=1)

library(MASS)

data("cars")
data("Cars93")
attach(Cars93)
View(Cars93)

plot(MPG.city, Price)
plot(MPG.city, Price, xlab="milles pero gallon", ylab="Price", xlim=c(15,30))
plot(MPG.city, Price, xlab="milles pero gallon", ylab="Price", xlim=c(15,30), pch=20)
plot(MPG.city, Price, xlab="milles pero gallon", ylab="Price", xlim=c(15,30), pch=20, col="blue")

legend("topright", "city", col = "blue", pch=20, cex=0.75)

abline(h=50)
points(20,30)
curve(sin(x), 0,8,add=F)
hist(x)

x <- rnorm(200)
hist(x)
stripchart(x)
pchisq(15,10)
pchisq(15,10) - pchisq(10,10)
rbeta(100,2,3)
curve(pbeta(x,2,3))
curve(pbeta(x,2,3), col="red", 0,1)
qchisq(c(0.25,0.5,0.75),10)
curve(dbeta(x,2,3))

x <- rnorm(10)
y <- rnorm(10)

datosXY <- data.frame(x,y)
dump("datosXY", file="datosXY.R")
rm(datosXY)

source(file = "datosXY.R")
View(datosXY)

x <- 3
if (x < 10 ) {
  print(paste(x, " es menor que 10"))
} else {
  print(paste(x, "es mayor o igual que 10"))
}

i <- 1
while(i < 6 ) {
  print(paste(i, "veces"), i <- i + 1)
}

for( j in 1:5 ) {
  print( paste( j, " veces"))
}

evaluar <- function(z) {
  if(z < 10 )  {
    print(paste(z, " es menor que 10"))
  } else {
    print(paste(z, "es mayor o igual que 10"))
  }
}
evaluar(3)
evaluar(10)
sumar <- function(a, b) {
  return(a + b)
}
sumar(2,3)

x <- 2.5:25
y <- 2*x+3+rnorm(length(x),0,0.2)
plot(x,y)
regressionxy <- lm (y ~ x)
summary(regressionxy)
abline(regressionxy)
plot(regressionxy)


library(igraph)
library(ggplot2)
g = graph.data.frame(d = Cit.HepPh.WithDates[,c(1,3)], directed = T)
#total
dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="total"))
myplot<-ggplot(dg_DATA,aes(x=c(0:(length(percent)-1)),y=percent))
myplot+geom_point()+labs(x='total degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="total"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=percent))
myplot+geom_point()+labs(x='total degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="total"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=log10(percent)))
myplot+geom_point()+labs(x='total degree (log10)', y='percentage of total nodes (log10)')

#in
dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="in"))
myplot<-ggplot(dg_DATA,aes(x=c(0:(length(percent)-1)),y=percent))
myplot+geom_point()+labs(x='in degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="in"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=percent))
myplot+geom_point()+labs(x='in degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="in"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=log10(percent)))
myplot+geom_point()+labs(x='in degree (log10)', y='percentage of total nodes (log10)')

#out
dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="out"))
myplot<-ggplot(dg_DATA,aes(x=c(0:(length(percent)-1)),y=percent))
myplot+geom_point()+labs(x='out degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="out"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=percent))
myplot+geom_point()+labs(x='out degree', y='percentage of total nodes')

dg_DATA<-data.frame(percent=degree.distribution(graph=g,mode="out"))
myplot<-ggplot(dg_DATA,aes(x=log10(c(0:(length(percent)-1))),y=log10(percent)))
myplot+geom_point()+labs(x='out degree (log10)', y='percentage of total nodes (log10)')

dg_in = degree(g,mode="in")
percent_in=degree.distribution(graph=g,mode="in")
degree<-function(per_in){
  length(percent_in[percent_in > per_in])
}
degree(0.005)


##MLE of Poission#####
pois.mle=function(x){
  n=length(x)
  S.x= sum(x)
  lambda=S.x/n
  lambda
}
#x=rpois(1000,5) # To check
#pois.mle(x)
#########MLE of Negative Binomial, Initial parameters is required###
nb.mle=function(x,z){
  N=length(x)
  r<- z[1]
  p<- z[2]
  xsum=sum(x)
  neg.log.lik=function(y) {
    r=y[1];
    p=y[2];
    if((p<=0)||(p>1)||(r<0)) ans=-Inf else {
    ans= N*r*log(1-p)- N*lgamma(r) +xsum*log(p) + sum(lgamma(x+r))-sum(lgamma(x+1));
    }
    -ans;
  }
  gp<- function(g) {
    r=g[1];
    p=g[2];
    dr<- N*log(1-p)-N*digamma(r)+sum(digamma(x+r));
    dp<- (xsum/p)-(N*r/(1-p));
    -c(dr,dp)
  }

  estimate=optim(par=c(r,p),fn=neg.log.lik, gr=gp, method = "L-BFGS-B", lower = c(1, 1e-8), upper = c(1e9,1-1e-8))
  ans=estimate$par
  list(r=ans[1], p=1-ans[2])
}
#x=rnbinom(1000, 7, 0.3)
#nb.mle(x,c(5, 0.5))

######## MLE of Beta Binomial####
bb.mle=function(x, b0){
  n=b0[1]; a=b0[2]; b=b0[3]
  N=length(x)
  neg.log.lik=function(y) {
    n=y[1];
    a=y[2];
    b=y[3];
    if((n<max(x))||(a<=0)||(b<=0)) ans=-Inf else {
      ans= N*lgamma(n+1)+N*lgamma(a+b)-N*lgamma(a)-N*lgamma(b)-N*lgamma(a+n+b)+sum(lgamma(x+a))+sum(lgamma(n-x+b))-sum(lgamma(x+1))-sum(lgamma(n-x+1));
    };
    -ans;
  }
  gp<- function(z) {
    n=z[1];
    a=z[2];
    b=z[3];
    dn<- N*digamma(n+1)-N*digamma(a+n+b)+sum(digamma(n-x+b))-sum(digamma(n-x+1));
    da<- N*digamma(a+b)-N*digamma(a)-N*digamma(a+n+b)+sum(digamma(x+a));
    db= N*digamma(a+b)-N*digamma(b)-N*digamma(a+n+b)+sum(digamma(n-x+b));
    -c(dn,da,db)
  }
  estimate=optim(par=c(n,a,b),fn=neg.log.lik, gr=gp, method = "BFGS")
  ans=estimate$par
  list(n=ans[1], a=ans[2], b=ans[3])
}
#x=rbbinom(100,10,1,2)
#bb.mle(x,c(max(x)+1, 2,5))

######## MLE of Beta Negative Binomial####
bnb.mle=function(x, b0){  #initial value is required
  r=b0[1]; a=b0[2]; b=b0[3]
  N=length(x)
  neg.log.lik=function(y) {
    r=y[1];
    a=y[2];
    b=y[3];
    if((r<=0)||(a<=0)||(b<=0)) ans=-Inf else {
      ans= N*lgamma(a+r)+N*lgamma(a+b)-N*lgamma(r)-N*lgamma(a)-N*lgamma(b)+sum(lgamma(x+r))+sum(lgamma(x+b))-sum(lgamma(x+1))-sum(lgamma(a+r+b+x));
    };
    -ans;
  }
  gp<- function(z) {
    r=z[1];
    a=z[2];
    b=z[3];
    dr<- N*digamma(a+r)-N*digamma(r)+sum(digamma(r+x))-sum(digamma(a+r+b+x));
    da<- N*digamma(a+r)+N*digamma(a+b)-N*digamma(a)-sum(digamma(a+r+b+x));
    db= N*digamma(a+b)-N*digamma(b)+sum(digamma(b+x))-sum(digamma(a+r+b+x));
    -c(dr,da,db)
  }
  estimate=optim(par=c(r,a,b),fn=neg.log.lik, gr=gp, method = "BFGS")
  ans=estimate$par
  list(r=ans[1], a=ans[2], b=ans[3])
}
## Remark: This code require large sample size. i.e, N.100000
#x=rbnbinom(1000, 2,1,5)
#bnb.mle(x,c(4,2,5))

# x=rbnbinom(100000, 2,1,5)
# bnb.mle(x,c(4,2,5))


## Author: Sergio García Prado

rm(list = ls())

y <- c(160, 140, 40,
        40,  60, 60)
r <- 2
c <- 3

n <- sum(y)
k <- length(y)

LogLikelihood <- function(p, y, k) {
  sum(y[1:(k - 1)] * log(p)) + y[k] * log(1 - sum(p))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(rep(1 / k, k - 1), NegativeLogLikelihood, y = y, k = k, hessian = TRUE)

(p.hat <- opt$par)
# 0.319974922618424 0.28001526572757 0.0800107004045124 0.0800170070336192 0.120016550720802

(p.hat.var <- solve(opt$hessian))
# 4.351396e-04	-1.792007e-04	-5.119362e-05	-5.120170e-05	-7.680441e-05
# -1.792007e-04	4.032054e-04	-4.480606e-05	-4.481313e-05	-6.722132e-05
# -5.119362e-05	-4.480606e-05	1.471927e-04	-1.280210e-05	-1.920362e-05
# -5.120170e-05	-4.481313e-05	-1.280210e-05	1.472139e-04	-1.920665e-05
# -7.680441e-05	-6.722132e-05	-1.920362e-05	-1.920665e-05	2.112222e-04

LogLikelihoodH0 <- function(theta, ...) {
  r1 <- theta[1]
  c1 <- theta[2]
  c2 <- theta[3]

  LogLikelihood(c(r1 * c1, (1 - r1) * c1, r1 * c2, (1 - r1) * c2, r1 * (1 - c1 - c2)), ...)
}

NegativeLogLikelihoodH0 <- function(...) {
  - LogLikelihoodH0(...)
}
opt.hzero <- optim(rep(1 / (r + c - 2), (r + c - 2)), NegativeLogLikelihoodH0, y = y, k = k)

(LRT <- 2 * (LogLikelihood(p.hat, y, k) - LogLikelihoodH0(opt.hzero$par, y, k)))
# 0.534117133722475

(LRT.pvalue <- 1 - pchisq(LRT, df = (k - 1) - 3))
# 0.765628229709977


# Load dataset
dataset1 <- read.csv("dataset1.csv", row.names=1, quote="")
# Print summary of dataset
summary(dataset1)

# Perform ANOVA analysis
anova_results <- aov(time ~ menu, data=dataset1)
print("Summary of Anova Analysis:")
# Print summary of ANOVA
summary(anova_results)
# Get the p_value of the test
p_value <- summary(anova_results)[[1]]$Pr[[1]]
print(p_value)

if (p_value < 0.05) {  # If p_value < 0.05: reject the null hypothesis
  print("p_value is less than 0.05. Hence the results are not by chance variation and the null hypothesis is rejected. There is significant effect of independent variable menu type on dependent variable access time.")
} else {  # Else accept the null hypothesis
  print("p_value is greater than or equal to 0.05. Hence the results could be by chance variation and we cannot reject the null hypothesis. There is no significant effect of independent variable menu type on dependent variable access time.")
}

# Perform pairwise t-test
pairwise.t.test(dataset1$time, dataset1$menu, p.adjust.method = 'bonferroni')
print("As per the results of the pairwise-t-test, only controlmenu-toolpalette pair has a p_value (0.034) < 0.05. All other pairs have a p_value >= 0.05. This means that there is statistically significant difference in access times between controlmenu and toolpalette but no significant difference in access times between other pairs of menus. To find out which is better between controlmenu and toolpalette, we can have a look at their means:")

# Calculate means within groups
aggregate(dataset1[, "time"], list(dataset1$menu), mean)
print("The mean access time for controlmenu (2.388) is significantly less than the mean access time of toolpalette (2.775). Thus, controlmenu is better than toolpalette in terms of access time.")

# One tailed t-test between controlmenu and toolpalette
controlmenu <- subset(dataset1, menu == "controlmenu")
toolpalette <- subset(dataset1, menu == "toolpalette")
t_test_result <- t.test(controlmenu$time, toolpalette$time, alternative = "less")
p_value <- t_test_result$p.value
print(paste("p_value controlmenu-toolpalette: ", p_value))
if (p_value < 0.05) {
  print("Since p_value < 0.05 we can reject the null hypothesis of the one tailed t-test and conclude that controlmenu has better access times than toolpalette.")
} else {
  print("Since p_value < 0.05 we can reject the null hypothesis of the one tailed t-test and conclude that controlmenu has better access times than toolpalette.")
}

# Visualizations
boxplot(time~menu,
        data=dataset1,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Time",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

# between-within plot
B <- anova(lm(time ~ menu, data = dataset1))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Time)", col = c("#DDEDAA", "#F4AC45"))

# f distribution plots
n <- sum(dataset1[, "menu"] == "controlmenu")[[1]]
means <- aggregate(dataset1[, "time"], list(dataset1$menu), mean)[, 2]
cntr <- means - mean(means)
lambda <- n*sum(cntr^2)
f <- function(x) df(x, df1 = 2, df2 = 4*(n - 1))
g <- function(x) df(x, df1 = 2, df2 = 4*(n - 1), ncp = lambda)
uplim <- qf(0.975, df1 = 2, df2 = 4*(n - 1), ncp = lambda)
curve(f, from = 0, to = uplim, lwd = 3, main = "F distributions plot",
      xlab = "F-ratio", ylab = "density")
curve(g, from = 0, to = uplim, lwd = 3, col = "red", add = TRUE)
fstat <- summary(lm(time ~ menu, data = dataset1))$fstatistic[1]
abline(v = fstat, lty = 2, col = "green", lwd = 3)
fcrit <- 2.866
abline(v = fcrit, lty = 2, col = "red", lwd = 3)
par(mfrow = c(1,1))


# needed modules/libs
library(leaps)

# Defining seed for reproducibility
set.seed(42)

# Size of data
N = 150

x1 = rnorm(N,0,4)
x2 = -1.5*x1+rnorm(N, 0, 3)
y = 10+2*x1+1.5*x2+rnorm(N,0,3)
par(mfrow=c(1,3))
plot(x1,y); plot(x2,y); plot(x1,x2)

cor(x1, y)
cor(x2, y)
cor(x1, x2)

x = cbind(x1, x2)
fit = lm(y~x); summary(fit)

summary(fit)

# Linear model for each variable
fit1 = lm(y~x1); summary(fit1)
fit2 = lm(y~x2); summary(fit2)

pairs(cbind(x,y))

x3 = 1*y + rnorm(N, 0, 4)
x4 = -6*x2 + rnorm(N, 0, 3)
x5 = 5*x1 + rnorm(N, 0, 5)
x6 = 0.3*x3 + rnorm(N, 0, 4)
x = cbind(x1, x2, x3, x4, x5, x6)
fit=lm(y~x); summary(fit)

pairs(cbind(x,y))

# Dividing data sets in train and test of same size
indices = sample(c(1:N), size=0.5*N)  # getting indices randmonly
x1_train = x1[indices]
x2_train = x2[indices]
x3_train = x3[indices]
x4_train = x4[indices]
x5_train = x5[indices]
x6_train = x6[indices]
y_train = y[indices]
x1_test = x1[-indices]
x2_test = x2[-indices]
x3_test = x3[-indices]
x4_test = x4[-indices]
x5_test = x5[-indices]
x6_test = x6[-indices]
y_test = y[-indices]

# Creating dataframe

data_train <- data.frame(x1_train, x2_train, x3_train, x4_train, x5_train, x6_train, y_train)
data_test <- data.frame(x1_test, x2_test, x3_test, x4_test, x5_test, x6_test, y_test)

### SELECCIÓN SECUENCIAL FORWARD ###

reg_subset_seq=regsubsets(y_train~.,data_train,nvmax=6,method="forward")

#Los resultados quedan en "reg_sub_summary"
reg_sub_summary_seq=summary(reg_subset_seq)

(reg_sub_summary_seq)

#Se pueden ver varios argumentos del resultado
reg_sub_summary_seq$cp  #(los Cp mallows para cada mejor modelo con cada k)
reg_sub_summary_seq$bic
reg_sub_summary_seq$adjr2

#Se pueden graficar los resultados:
plot(reg_sub_summary_seq$cp,type="b") #El cp de mallows cambiando k
plot(reg_sub_summary_seq$bic,type="b",col="red")  #El BIC
plot(reg_sub_summary_seq$adjr2,type="b",col="blue")  #El R2ajustado

# El cp para el mejor modelo (mínimo de la curva)
min(reg_sub_summary_seq$cp)

# Sanity check
# The idea is to check coefficients are the same as before
lm_best_seq = lm(y_train~x1_train+x3_train+x4_train, data=data_train)
summary(lm_best_seq)

# Prediction - MSE
pred_seq = predict(lm_best_seq, data_test)
mse_seq = mean((data_test$y_test - pred_seq)^2)

### SELECCIÓN EXHAUSTIVA ###

reg_subset_exh=regsubsets(y_train~.,data_train,nvmax=6,method="exhaustive")

#Los resultados quedan en "reg_sub_summary"
reg_sub_summary_exh=summary(reg_subset_exh)

(reg_sub_summary_exh)

#Se pueden ver varios argumentos del resultado
reg_sub_summary_exh$cp  #(los Cp mallows para cada mejor modelo con cada k)
reg_sub_summary_exh$bic
reg_sub_summary_exh$adjr2

#Se pueden graficar los resultados:
plot(reg_sub_summary_exh$cp,type="b") #El cp de mallows cambiando k
plot(reg_sub_summary_exh$bic,type="b",col="red")  #El BIC
plot(reg_sub_summary_exh$adjr2,type="b",col="blue")  #El R2ajustado

# Sanity check
# The idea is to check coefficients are the same as before
lm_best_exh = lm(y_train~x1_train+x2_train+x3_train, data=data_train)
summary(lm_best_exh)

# Prediction - MSE
pred_exh = predict(lm_best_exh, data_test)
mse_exh = mean((data_test$y_test - pred_exh)^2)

### PCA ###

### PLS ###

### Ridge ###

### Lasso ###


##########################################################################
###                         loops
##########################################################################

# basic for loop ======================================================================

for(i in 1:10){
  print(paste('hello' , i,  sep = ' '))
}
print(i)

# basic while loop ====================================================================

start.time <- Sys.time() # get sys.time
comp.time <- 0 # initialize computing time allowed
n <- 0 # create variable n
while(comp.time < 10){
  n <- n + 1 # increment n
  comp.time <- as.numeric(difftime(Sys.time(),  start.time, units = 's')) # update time spent computing
}
print(n)

# nested for loops: multiplication table ===============================================================

mymat <- matrix(nrow = 20, ncol = 20) # create a 20 x 20 matrix

for(i in 1:dim(mymat)[1]){  # for each row
  for(j in 1:dim(mymat)[2]){ # for each column
    mymat[i, j] = i * j # assign values based on position: product of two indexes
  }
}

print(mymat)

# nested for and if loops : multiplication table ======================================================

mymat <- matrix(nrow = 20, ncol = 20) # create a 20 x 20 matrix

for(i in 1:dim(mymat)[1]){  # for each row
  for(j in 1:dim(mymat)[2]){ # for each column
    if(i * j < 20){
      mymat[i, j] = i * j # assign values based on position: product of two indexes
    }else{
      mymat[i, j] <- 'BIG'
      #break()
      #next()
    }
  }
}

print(mymat)


# libraries and data
library(tidyverse)
library(dslabs)
data(murders)

# Demonstrate the use of groupby
# compute separate average and standard deviation for male/female heights
heights %>%
    group_by(sex) %>%
    summarize(average = mean(height), standard_deviation = sd(height))

# compute median murder rate in 4 regions of country
murders <- murders %>%
    mutate(murder_rate = total/population * 100000)
murders %>%
    group_by(region) %>%
    summarize(median_rate = median(murder_rate))

# calculate and extract the murder rate with one pipe
us_murder_rate <- murders %>%
    summarize(rate = sum(total) / sum(population * 100000) %>%
    .$rate

#Demonstrate the sorting of data
# set up murders object
murders <- murders %>%
    mutate(murder_rate = total/population * 100000)

# arrange by population column, smallest to largest
murders %>% arrange(population) %>% head()

# arrange by murder rate, smallest to largest
murders %>% arrange(murder_rate) %>% head()

# arrange by murder rate in descending order
murders %>% arrange(desc(murder_rate)) %>% head()

# arrange by region alphabetically, then by murder rate within each region
murders %>% arrange(region, murder_rate) %>% head()

# show the top 10 states with highest murder rate, not ordered by rate
murders %>% top_n(10, murder_rate)

# show the top 10 states with highest murder rate, ordered by rate
murders %>% arrange(desc(murder_rate)) %>% top_n(10)


#'@title Get the outliers for a given time series
#'
#'@description The outliers are computed using different methods based on the \code{outlierType} parameter
#'
#'@usage  tsData.out <- getOutliers(tsData)
#'
#'@param tsData  A time series object.
#'@param outlierType  A string that determines the way to compute the outliers.  outlierType = c("iqr","stl","firstdiff").  Default is "iqr".
#'@details
#'	iqr: Find outliers using the interquartile range of the given time series (boxplot method).
#'  stl: Use stl weights.
#'  firstdiff: Use the points three standard deviations from the mean of the time series of first diffs.
#'
#'@return A vector of indices which represents the location of the outliers within the time series
#'
#'@export

getOutliers <- function(tsData, outlierType = "iqr")
{

	tsObj <- tsData

	if (outlierType == "iqr") {
		tsObj.outliers <-  which(tsObj > quantile(tsObj,probs=.75) + 3*IQR(tsObj))
	} else if (outlierType == "stl") {
		tsObj          <- tsData
		tsObj.stl      <- stats::stl(tsObj,s.window="periodic",robust=T)
		tsObj.outliers <- which(tsObj.stl$weights < 1e-8)
	} else if (outlierType == "firstdiff") {
		tsObj.diff    <- diff(tsObj)
		tsObj.diff.mu <- mean(tsObj.diff)
		tsObj.diff.sd <- sd(tsObj.diff)
		tsObj.outliers <- which(tsObj.diff > tsObj.diff.mu + 3*tsObj.diff.sd)
		tsObj.outliers <- c(tsObj.outliers,which(tsObj.diff < tsObj.diff.mu - 3*tsObj.diff.sd))
	} else {
		stop("Invalid outlier type specified. Valid values are \"iqr\" and \"stl\"")
	}

	return (tsObj.outliers)
}


# Numerical_Integration.r
# Date: 28.06.2019. Created by Joshua Simon.

# Create some functions you want to integrate

f <- function(x) {
    return(sin(x))
}

com_simpson <- function(f, a, b, n) {
    # Composite Simpson's rule
    # Integration of function f over interval [a,b] where n is
	# the number of subintervals. Accuracy only depends on the
	# number of subintervals.

    sum <- 0

    # Step length h
    h <- (b - a) / n

    # Calculate integral value with composite simpson's rule
    for (k in 1:n) {
        x_k <- a + k * h
		x_k1 <- a + (k-1) * h

		simpson <- h/6 * ( f(x_k1) + 4* f((x_k1 + x_k)/2) + f(x_k) )

        sum <- sum + simpson
    }

    return(sum)
}

integral <- com_simpson(f, 0.0, 2.0 * 3.141592654, 100000)

message(integral)


library(readr)
library(dplyr)
library(knitr)
library(ggpubr)
books <- read_csv("STAT_Assignment_4/books.csv")
View(books)
books$author <- ordered(books$author,
                         levels = c("Clancy", "Rowling", "Tolstoy"))

# (a) Side by side box plots
boxplot(books$score ~ books$author, main="Boxplot by Authors")

# (b) mean and standard deviation
# Method 1:
# Calculating mean
tapply(books$score, INDEX = books$author, FUN = mean)
# Calculating standard deviation
tapply(books$score, INDEX = books$author, FUN = sd)
# Method 2:
group_by(books, author) %>%
  summarise(
    count = n(),
    mean = mean(score, na.rm = TRUE),
    sd = sd(score, na.rm = TRUE)
  )
# 95% confidence intervals for mean for three levels separately
tapply(books$score, INDEX = books$author, FUN = t.test)

# One way ANOVA
res.aov <- aov(score ~ author, data = books)
# Summary of the analysis
summary(res.aov)

# Draw histogram
tapply(books$score, INDEX = books$author, FUN = hist)

tapply(books$score, INDEX = books$author, FUN = qqnorm)
tapply(books$score, INDEX = books$author, FUN = qqline)


# Example : 4.2B   Chapter : 4.2     Page No: 213
# Find best Possible solution

solution<-function(A,b){
  ATA<-t(A)%*%A
  ATb<-t(A)%*%b
  x<-solve(ATA,ATb)
  return(x)
}

A<-matrix(c(1,1,1),ncol=1)
b<-matrix(c(70,80,120),ncol=1)
x<-solution(A,b)
print("The best possible solution is ")
print(x)


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

#lambda = 0, logaritmica
t1 = BoxCox(AirPassengers,lambda =0 )
autoplot(t1)

#lambda = 0.34
t2 = BoxCox(AirPassengers,lambda =.1 )
autoplot(t2)

#gera labda automático
lbd = BoxCox.lambda(AirPassengers)
print(lbd)
t3 = BoxCox(AirPassengers,lambda =lbd )
autoplot(t3)

#diferenciacao
t4 = diff(AirPassengers)
autoplot(t4)

#logaritmica
t5 = log10(AirPassengers)
autoplot(t5)

split.screen( figs = c( 2, 2 ) )
screen(1)
plot(t1)
screen(2)
plot(t2)
screen(3)
plot(t3)
screen(4)
plot(t5)
close.screen( all = TRUE )

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.5.Transformacoes.r


# loads the library urca, which contains the command ur.df()
# and applies Unit-Root Testing based on Dickey-Fuller test
library(urca)
library(tseries)

# Importing data into R can be carried out in various ways. Below, the command read.table is used:
data_all = read.table('/home/george/AUEB/TimeSeries/time_series_in_r/Data-Assignment-Feb-2018.txt')

head(data_all)

y1 <- data_all$V1

j1 = ts(y1, frequency=12, start = c(1991, 1), end = c(2004, 12))
j1

# set up the graphics
par(mfrow=c(2, 1))
plot(j1, type="l", col='red', lwd=1, main="Time Series plot of Y1", ylab="Monthly returns")
hist(j1, nclass=20, main="Histogram of Y1")

# Create Autocorrelation and partial autocorrelation plots
par(mfrow=c(3, 2)) # set up the graphics
acf(j1, 48, main="ACF of Y1") # autocorrelation function plot
pacf(j1, 48, main="PACF of Y1") # partial autocorrelation function
acf(ts(j1, freq=1), 48, main="ACF of returns of Y1")        # autocorrelation function plot
pacf(ts(j1, freq=1), 48, main="PACF of returns of Y1")
acf(ts(j1^2, freq=1), 48, main="ACF of squared returns of Y1")        # autocorrelation function plot
pacf(ts(j1^2, freq=1), 48, main="PACF of squared returns of Y1")

# Shapiro test of normality
shapiro.test(j1)

par(mfrow=c(2,1))
hist(j1, prob=TRUE, 20) # histogram

lines(density(j1))
# smooth it - ?density for details
qqnorm(j1, main="Normal QQplot of Y1") # normal Q-Q plot
qqline(j1) # add a line

# Unit root testing for the Y1 series
# Fits an autoregressive model, and selects the best AR order based on AIC
m1 = ar(j1)
m1
paste('Order:', m1$order)

m11 <- ur.df(j1, type='none', lags=m1$order-1)
m11
summary(m11)

# Unit root testing for the Y1 series
# Fits an autoregressive model, and selects the best AR order based on AIC
m12 <- ur.df(j1, type="drift", lags=m1$order-1)
m12
summary(m12)

m13 <- ur.df(j1, type="trend", lags=m1$order-1)
m13
summary(m13)

ar1fit <- arima(j1, order=c(1,0,0))
ar1fit

ma1fit=arima(j1, order=c(0,0,1))
ma1fit

arma11fit <- arima(j1, order=c(1,0,1))
arma11fit

ar1residualsTS <- ts(ar1fit$residuals, frequency=12, start = c(1991, 1), end = c(2004, 12))

par(mfrow=c(3,2))

# set up the graphics
acf(ts(ar1residualsTS,freq=1), 48, main="ACF of residuals")
pacf(ts(ar1residualsTS,freq=1), 48, main="PACF of residuals")
acf(ts(ar1residualsTS^2,freq=1), 48, main="ACF of squared residuals")
pacf(ts(ar1residualsTS^2,freq=1), 48, main="PACF of squared residuals")
qqnorm(ar1residualsTS,main="Normal QQplot of residuals")
qqline(ar1residualsTS)

forecast <- predict(ar1fit, 12)

# plot of forecasts with 1 standard error
par(mfrow=c(1,1))
UL <- forecast$pred + forecast$se
LL <- forecast$pred - forecast$se

predTS <- ts(forecast$pred, frequency=12, start = c(2004, 12))
UL_TS <- ts(forecast$pred, frequency=12, start = c(2004, 12))
LL_TS <- ts(forecast$pred, frequency=12, start = c(2004, 12))

min_x <- min(ar1residualsTS, LL)
max_x <- max(ar1residualsTS, UL)

ts.plot(ar1residualsTS, predTS)
lines(predTS, col="red", type="o")
lines(UL_TS, col="blue", lty="dashed")
lines(LL_TS, col="blue", lty="dashed")

library(hydroGOF)
MSE <- mse(forecast$pred, forecast$se)
MSE


## Author: Sergio García Prado
## Title: Exercises with Solutions 6

rm(list = ls())

P <- matrix(c(  0, 1/3, 2/3,
              1/3,   0, 2/3,
                1,   0,   0),
            3, 3, byrow = TRUE)

lambdas <- 1 / c(8, 3, 6)

(Q <- P * lambdas + diag(-lambdas))
# -0.1250000	 0.04166667  0.08333333
#  0.1111111	-0.33333333	 0.22222222
#  0.1666667	 0.00000000	-0.16666667

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -0.1250000	 0.04166667	1
#  0.1111111	-0.33333333	1
#  0.1666667	 0.00000000	1

(stationary <- solve(A)[nrow(A), ])
# 0.558139534883721 0.0697674418604651 0.372093023255814

(non.playing.ratio <- stationary[3])
# 0.372093023255814

(mean.pay <- sum(stationary * c(40, 30, 20)))
# 31.8604651162791


data(stackloss)
str(stackloss)
summary(stackloss)

pairs(stackloss, panel = panel.smooth)

LModel <- lm(stack.loss ~ Air.Flow + Water.Temp + Acid.Conc., data=stackloss)
summary(LModel)

par(mfcol = c (2,2))
plot(LModel)

library(mgcv)

GAMModel <- gam(stack.loss ~ s(Air.Flow, k=7) +
                  + s(Water.Temp, k=7) + s(Acid.Conc., k=7), data=stackloss)
summary(GAMModel)

par(mfcol = c (1,1))
plot(GAMModel,select=2)

anova(LModel,GAMModel)


# install car package by writing install.packages("car") command in console
library(car)
y=c(4.2,2.9,0.2,25.7,6.3,7.2,2.3,9.9,5.3,6.5,0.2,11.3,0.3,17.1,51.0,10.1,0.3,0.6,7.9,7.2,7.2,6.4,9.9,3.5,10.6,10.8,10.6,8.4,6.0,11.9)
additive=c(1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3)
leveneTest(y,additive)
critical_value=qf(1-0.05,2,27)
critical_value
# L < critical value  we fail to reject and conclude that there is insufficient evidence of a difference in the population variances of the percentage increase in mpg for the three additives.


##Loading the necessary libraries
library(deSolve)

### Rosenzweig-MacArthur model###

## ODE system to be integrated
RM <- function(t, y, parms){
    with(as.list(c(y, parms)),
         {
             dR = r*R*(1-R/K) - a*R*C/(1+a*h*R)
             dC = e*a*R*C/(1 + a*h*R) - d*C
             return(list(c(R=dR,C=dC)))
         })
}

##initial parameters
parms1 = c(r=1, K=10, a=1, h=0.1, e=0.1, d=0.1)

##initial population sizes
y0 = c(R=1,C=1)

##running the numerical solution from time 1 to 1000
out = ode(y=y0, times = seq(from=1, to=1000, by=0.5), func = RM, parms = parms1)

##plotting the solution
## In a R console the code enclosed between #'s are enough.
## For the current version of ipython it is necessary to enclose it within
## a with() statement, see https://github.com/takluyver/IRkernel/issues/23
with(.GlobalEnv, {
    #########################################################################
    matplot(x=out[,1], y=out[,2:3], type = "l", lwd=2, lty=1,
            col=c("blue", "darkgreen"), xlab="Time", ylab="Population size")
    legend("topright", legend = c("Resource","Consumer"),
           lty = 1, lwd=2, col=c("blue", "darkgreen"))
    #########################################################################
}
     )

## Phase space flow and fixed points
##first we need to calculate the coordinates for the vectors
xs = seq(from=0.9, to=1.3, length.out=7)
ys = seq(from=0.94, to=1.04, length.out=7)
coords = expand.grid(R=xs, C=ys)
## And then loop over all coordinates to calculate the derivatives at that points
dvs = matrix(NA, ncol=2, nrow=nrow(coords))
for(i in 1:nrow(coords))
    dvs[i,] = unlist(RM(t=1, y = coords[i,], parms = parms1))

##now we plot the trajectory
    plot(x=out[,2], y=out[,3], type="l", lwd=2, col="blue",
        xlab="Resource",ylab="Consumer", xlim=c(0.9,1.3), ylim=c(0.94,1.04))
    ##and add the vector field
    arrows(x0=coords[,1], y0=coords[,2], x1=coords[,1]+dvs[,1]*0.5,
           y1=coords[,2]+dvs[,2]*0.5, length=0.1, lwd=2)

# now K = 15
##Messing a little with the parameters
parms2 = c(r=1, K=15, a=1, h=0.1, e=0.1, d=0.1)

out2 = ode(y=y0, times = seq(from = 1, to = 1000, by=0.5), func = RM, parms = parms2)

##plotting the solution
with(.GlobalEnv,{
    #####################################################################################
    matplot(x=out2[,1], y=out2[,2:3], type = "l", lwd=2, lty=1,col=c("blue", "darkgreen"),
            xlab="Time", ylab="Population size")
    legend("topleft", legend = c("Resource","Consumer"), lty = 1, lwd=2,
           col=c("blue", "darkgreen"))
    #####################################################################################
    })

##calculating the vectors again
xs = seq(from=0,to=6,length.out=8)
ys = seq(from=0,to=2,length.out=8)
coords = expand.grid(R=xs,C=ys)
dvs = matrix(NA, ncol=2, nrow=nrow(coords))
for(i in 1:nrow(coords))
    dvs[i,] = unlist(RM(t=1, y = coords[i,], parms = parms2))

##The trajectory
with(.GlobalEnv,{
    #####################################################################################
    plot(x=out2[,2],y=out2[,3], type="l", lwd=2, col="blue",
         xlab="Resource", ylab="Consumer", xlim=c(0,6),ylim=c(0,2))
    ##and vectors
    arrows(x0=coords[,1], y0=coords[,2], x1=coords[,1]+dvs[,1]*0.5,
           y1=coords[,2]+dvs[,2]*0.5, length=0.1, lwd=2)
    #####################################################################################
    })

##plotting minimum and maximum population sizes with different K values

##object with the line numbers we will use for the following plot
lines = (nrow(out)-500):nrow(out)

##creating an empty plot
with(.GlobalEnv,{
    #####################################################################################
    plot(0.1, type="n", xlim=c(0,20), ylim=range(out2[lines,2:3]), log="y",
         xlab="K", ylab="Min and Max population")

##points for the K = 10
    points(x = c(10,10), y = range(out[lines,3]), pch=21,bg="darkgreen", cex=3)
    points(x = c(10,10), y = range(out[lines,2]), pch=21,bg="blue", cex=3)

##points for the K = 15
    points(c(15,15), range(out2[lines,3]), pch=21,bg="darkgreen", cex=3)
    points(c(15,15), range(out2[lines,2]), pch=21,bg="blue", cex=3)
    #####################################################################################
    })

## this block calculates solutions for many K's, it should take some time
KK = seq(from = 0.5, to=25, by=0.5)
rminmax = matrix(NA, ncol=2, nrow=length(KK))#resource minimum and maximum
cminmax = matrix(NA, ncol=2, nrow=length(KK))#consumer minimux ans maximum

## Loop over all values of K andd get min and max population sizes
for(i in 1:length(KK)){
    parmsi = c(r=1, K=KK[i], a=1, h=0.1, e=0.1, d=0.1)
    y0 = c(R=1,C=1)
    out3 = ode(y=y0, times = seq(from = 1, to = 1000, by=0.5), func = RM, parms = parmsi)
    rminmax[i,] = range(out3[(nrow(out3)-500):nrow(out3),2])
    cminmax[i,] = range(out3[(nrow(out3)-500):nrow(out3),3])
}
with(.GlobalEnv,{
    #####################################################################################
    ## Plot of bifurcation digram with min and max population sizes
    plot(x=KK, y=rminmax[,1], type="l", lwd=2, col="blue",ylim=range(rminmax), log="y",
         xlab="K", ylab="Min and Max population")
    points(x=KK, y=rminmax[,2], type="l", lwd=2, col="blue")
    points(x=KK, y=cminmax[,1], type="l", lwd=2, col="darkgreen",ylim=range(rminmax))
    points(x=KK, y=cminmax[,2], type="l", lwd=2, col="darkgreen",ylim=range(rminmax))
    #####################################################################################
    })

### Consumer-resource dynamics in a seasonal environment ###
## time sequence
time <- seq(0, 2000, by = .5)

## parameters: a named vector
parameters <- c(r0=1, alpha=0.1, T=80, K=10, a=1, h=0.1, e=0.1, d=0.1)

## initial conditions: a named vector
state <- c(R = 1, C = 1)

## R function to calculate the value of the derivatives at each time value
## Use the names of the variables as defined in the vectors above
RM2 <- function(t, state, parameters){
    with(as.list(c(state, parameters)), {
        r = r0 * (1 + alpha*sin(2*pi*t/T))
        dR = R * ( r*(1 - R/K) - a*C / (1 + a*h*R) )
        dC = e*a*R*C / (1 + a*h*R) - d*C
        return(list(c(dR, dC)))
    })
}

## Integration with 'ode'
out <- ode(y = state, times = time, func = RM2, parms = parameters)

## Ploting with matplot
with(.GlobalEnv,{
    #####################################################################################
    matplot(x = out[,1], y = out[,2:3], type="l", lwd=2, lty = 1,
            col=c("blue", "darkgreen"), xlab = "Time", ylab = "Population size")
    legend("topright", c("Resource", "Consumer"), lty=1, lwd=2, col=c("blue", "darkgreen"))
    #####################################################################################
    })

## A resonance diagram ##
## New time sequence
time <- seq(0, 6000, by = 1)
## Sequence of values of T
TT <- seq(1, 80, by = 2)
## A matrix to store the results
results <- matrix(ncol=4, nrow=length(TT),
                  dimnames=list(NULL, c("R.min","R.max","C.min","C.max")))
## Loop over all values in TT
for(i in 1:length(TT)){
    parameters <- c(r0=1, alpha=0.1, T=TT[i], K=10, a=1, h=0.1, e=0.1, d=0.1)
    tmp1 <- ode(y = state, times = time, func = RM2, parms = parameters)
    results[i,1:2] <- range(tmp1[1001:nrow(tmp1), 2])
    results[i,3:4] <- range(tmp1[1001:nrow(tmp1), 3])
}

## Plot of resonance diagram
with(.GlobalEnv,{
    #####################################################################################
    plot(R.min ~ TT , data=results, type="l", lwd=2, lty = 1,
         col="blue", xlab = "T", ylab = "Min / Max population size",
         log="y", ylim = range(results))
    lines(R.max ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("blue"))
    lines(C.min ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("darkgreen"))
    lines(C.max ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("darkgreen"))
    legend("topright", c("Resource", "Consumer"), lty=1, lwd=2, col=c("blue", "darkgreen"))
    #####################################################################################
    })

Qualitative analysis and Bifurcation diagram Tutorial - R.r


## 1. Calculating Grades In R ##

print((90 + 81 + 92)/3)

## 2. Performing Multiple Calculations ##

print((84 + 95 + 79)/3)
print((95 + 86 + 93)/3)

## 3. Performing Calculations using Arithmetic Operators ##

print((77 + 85 + 90)/3)
print((92 + 90 + 91)/3)
print((85 + 88 + 95)/3)

## 4. Performing Calculations with Order of Operations ##

print(88 - ((88 + 87.66667 + 86 + 91.33333 + 84 + 91 + 89.33333)/7))

## 5. Creating Comments ##

# Operations

print(
    88 - ((88 + 87.66667 + 86 + 91.33333 + 84 + 91 + 89.33333)/7)
)

## 6. Assigning Values to a Variable ##

math <- 88

# Add your code below
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

## 7. Performing Calculations Using Variables ##

math <- 88
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

gpa <- (math + chemistry + writing + art + history + music + physical_education)/7

history_difference <- history - gpa

## 8. Creating Vectors ##

math <- 88
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

## 9. Calculating the Mean ##

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

gpa <- mean(final_scores)

## 10. Performing Operations on Vectors ##

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

highest_score <- max(final_scores)
lowest_score <- min(final_scores)
num_classes <- length(final_scores)

R Fundamentals/Introduction to R Programming-310.r


# 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 : 4   Chapter : 6.4     Page No: 334
# Pivots and Eigen values have same signs for the Symmetric matrices
library(pracma)
A<-matrix(c(1,3,3,1),ncol=2)
u<-lu(A)$U
pivots<-c(u[1,1],u[2,2])
eigenvalues<-eigen(A)$values
print("Eigen values and pivots have same signs for symmetric matrix")
print(pivots)
print(eigenvalues)
print("This is not true if the matrix is not symmetric")
B<-matrix(c(1,-1,6,-4),ncol=2)
Bu<-lu(B)$U
Bpivots<-c(Bu[1,1],Bu[2,2])
Beigenvalues<-eigen(B)$values
print(Bpivots)
print(Beigenvalues)


y=c(4.3,5.5,6.8,8.0,4.0,5.2,6.6,7.5,2.0,4.0,5.7,6.5)
x1=c(4,5,6,7,4,5,6,7,4,5,6,7)
x2=c(.20,.20,.20,.20,.30,.30,.30,.30,.40,.40,.40,.40)

cbind(sum(y),sum(x1),sum(x2),sum(y*x1),sum(y*x2),sum(x1*x2),sum(x1^2),sum(x2^2))
#  three normal equations for this model
# 66.1=12*beta0+66*beta1+3.6*beta2
# 383.3=66*beta0+378*beta1+19.8*beta2
#  19.19=3.6*beta0+19.8*beta1+1.16*beta2
relation = lm(y~x1+x2)
print(summary(relation))
anova(relation)
# linear regression model : y=0.667+1.316*x1-8.000*x2
x1=6.5
x2=.35
y=0.667+1.316*x1-8.000*x2
print(y)


# Case diagnostics

brain <- read.table('brain.txt',as.is=T, header=T)

brain$loggest <- log(brain$gest)
brain$logbrain <- log(brain$brain)
brain$logbody <- log(brain$body)
brain$loglitter <- log(brain$litter)

brain.lm <- lm(logbrain ~ logbody + loglitter + loggest, data=brain)

rstandard(brain.lm)
# internally standardized residuals

rstudent(brain.lm)
#  externally studentized residuals (use MSE(-i))

influence.measures(brain.lm)
# computes (and prints) DFBETA's, DFFITS, Cook's D and Hii
#  also computes the covariance ratio, which I don't use,
#  but it's there if in case you want it.

# result of influence.measures has class infl.
# can access each bit (e.g. to plot) by burrowing into the infl
#  class structure, or you can access each diagnostic by specific
#  functions.

# N.B. A plot of only one thing uses 1:N as the X axis

plot(dffits(brain.lm))
plot(cooks.distance(brain.lm))
plot(hatvalues(brain.lm))

dfb <- dfbetas(brain.lm)
# there are four columns because k=3,
# plot each column of dfbetas
oldpar <- par(mfrow=c(2,2), mar=c(3,4,2,1)+0.1)
for (i in 1:4) { plot(dfb[,i]); title(dimnames(dfb)[[2]][i])}
par(oldpar)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/brain2.r


library(deSolve)
library(rootSolve)
library(phaseR)

sirmod = function(t, y, parms) {
    # Pull state variables from y vector
    S = y[1]
    I = y[2]
    R = y[3]
    # Pull parameter values from parms vector
    beta = parms["beta"]
    mu = parms["mu"]
    gamma = parms["gamma"]
    N = parms["N"]
    # Define equations
    dS = mu * (N - S) - beta * S * I/N
    dI = beta * S * I/N - (mu + gamma) * I
    dR = gamma * I - mu * R
    res = c(dS, dI, dR)
    # Return list of gradients
    list(res)
}

times = seq(0, 26, by = 1/10)
parms = c(mu = 0, N = 1, beta = 2, gamma = 1/2)
start = c(S = 0.999, I = 0.001, R = 0)

out = ode(y = start, times = times, func = sirmod,
     parms = parms)
out=as.data.frame(out)
head(round(out, 3))

plot(x = out$time, y = out$S, ylab = "Fraction",
     xlab = "Time", type = "l")
lines(x = out$time, y = out$I, col = "red")
lines(x = out$time, y = out$R, col = "green")

#Calculate R0
R0 = parms["beta"]/(parms["gamma"]+parms["mu"])

#Adjust margins to accommodate a second right axis
par(mar = c(5,5,2,5))
#Plot state variables
plot(x = out$time, y = out$S, ylab = "Fraction",
     xlab = "Time",  type = "l")
lines(x = out$time, y = out$I, col = "red")
lines(x = out$time, y = out$R, col = "green")

#Add vertical line at turnover point
xx = out$time[which.max(out$I)]
lines(c(xx,xx), c(1/R0,max(out$I)), lty = 3)

#prepare to superimpose 2nd plot
par(new = TRUE)
#plot effective reproductive ratio (w/o axes)
plot(x = out$time, y = R0*out$S, type = "l", lty = 2,
     lwd = 2, col = "black", axes = FALSE, xlab = NA,
     ylab = NA, ylim = c(-.5, 4.5))
lines(c(xx, 26), c(1,1), lty = 3)
#Add right-hand axis for RE
axis(side = 4)
mtext(side = 4, line = 4, expression(R[E]))
#Add legend
legend("right", legend = c("S", "I", "R",
     expression(R[E])), lty = c(1,1,1, 2),
     col = c("black", "red", "green", "black"))

equil=runsteady(y=c(S=1-1E-5, I=1E-5, R=0),
times=c(0,1E5), func=sirmod, parms=parms)
round(equil$y, 3)

#Candidate values for R0 and beta
R0 = seq(0.1, 5, length=50)
betas= R0 * 1/2
#Vector of NAs to be filled with numbers
f = rep(NA, 50)
#Loop over i from 1, 2, ..., 50
for(i in seq(from=1, to=50, by=1)){
     equil=runsteady(y=c(S=1-1E-5, I=1E-5,
       R=0), times=c(0,1E5), func=sirmod,
       parms=c(mu=0, N=1, beta=betas[i], gamma=1/2))
     f[i]=equil$y["R"]
}
plot(R0, f, type="l", xlab=expression(R[0]))
curve(1-exp(-x), from=1, to=5, add=TRUE, col="red")

#Define function
fn=function(x, R0){
 exp(-(R0*(1-x))) - x
}
1-uniroot(fn, lower = 0, upper = 1-1E-9,
     tol = 1e-9, R0=2)$root
#check accuracy of approximation:
exp(-2)-uniroot(fn, lower = 0, upper = 1-1E-9,
     tol = 1e-9, R0=2)$root

times  = seq(0, 52*50, by=.1)
parms  = c(mu = 1/(50*52), N = 1, beta =  2,
     gamma = 1/2)
start = c(S=0.19, I=0.01, R = 0.8)
out = as.data.frame(ode(y=start, times=times,
     func=sirmod, parms=parms))
par(mfrow=c(1,2)) #Make room for side-by-side plots
plot(times, out$I, ylab="Fraction", xlab="Time",
     type="l")
plot(out$S, out$I, type="l", xlab="Susceptible",
     ylab="Infected")

simod = function(t, y, parameters) {
    S = y[1]
    I = y[2]

    beta = parameters["beta"]
    mu = parameters["mu"]
    gamma = parameters["gamma"]
    N = parameters["N"]

    dS = mu * (N - S) - beta * S * I/N
    dI = beta * S * I/N - (mu + gamma) * I
    res = c(dS, dI)
    list(res)
}

#Plot vector field
fld = flowField(simod, xlim = c(0.15,0.35),
     ylim = c(0,.01), parameters = parms, system = "two.dim",
     add = FALSE, ylab = "I", xlab = "S")
#Add trajectory
out = as.data.frame(ode(y = c(S = 0.19, I = 0.01),
     times =  seq(0, 52*100, by = .1), func = simod, parms = parms))
 lines(out$S, out$I, col = "red")
#Add S-isocline
curve(parms["mu"]*(1/x-1)/parms["beta"], 0.15, 0.35,
     xlab = "S", ylab = "I", add = TRUE)
#Add I-isocline
icline = (parms["gamma"] + parms["mu"])/parms["beta"]
lines(rep(icline, 2), c(0,0.01))
legend("topright", legend = c("Transient", "Isoclines"),
     lty = c(1, 1), col = c("red", "black"))

# Pull values from parms vector
gamma = parms["gamma"]
beta = parms["beta"]
mu = parms["mu"]
N = parms["N"]
# Endemic equilibrium
Sstar = (gamma + mu)/beta
Istar = mu * (beta/(gamma + mu) - 1)/beta
eq1 = list(S = Sstar, I = Istar)

# Define equations
dS = expression(mu * (N - S) - beta * S * I/N)
dI = expression(beta * S * I/N - (mu + gamma) * I)
# Differentiate w.r.t. S and I
j11 = D(dS, "S")
j12 = D(dS, "I")
j21 = D(dI, "S")
j22 = D(dI, "I")

#Evaluate Jacobian at equilibrium
J=with(data=eq1, expr=matrix(c(eval(j11),eval(j12),
     eval(j21),eval(j22)), nrow=2, byrow=TRUE))
#Calculate eigenvalues
eigen(J)$values

2 * pi/(Im(eigen(J)$values[1]))

eq2=list(S=1,I=0)
J=with(eq2,
     matrix(c(eval(j11),eval(j12),eval(j21),
     eval(j22)), nrow=2, byrow=TRUE))
eigen(J)$values

chainSIR = function(t, logx, params){
x = exp(logx)
u = params["u"]
S = x[1]
I = x[2:(u+1)]
R = x[u+2]
with(as.list(params),{
  dS = mu * (N - S)  - sum(beta * S * I) / N
  dI = rep(0, u)
  dI[1] = sum(beta * S * I) / N - (mu + u*gamma) * I[1]
  if(u>1){
     for(i in 2:u){
         dI[i] = u*gamma * I[i-1] - (mu+u*gamma)* I[i]
      }
   }
  dR = u*gamma * I[u] - mu * R
  res = c(dS/S, dI/I, dR/R)
  list(res)
})
}

times = seq(0, 10, by=1/52)
paras2 = c(mu = 1/75, N = 1, beta =  625,
     gamma = 365/14, u=1)
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001,
     paras2["u"]-1)), R = 0.0001))
out = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
plot(times, exp(out[,3]), ylab = "Infected", xlab =
     "Time", ylim = c(0, 0.01), type = 'l')

paras2["u"] = 2
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out2 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out2[,-c(1:2,length(out2))]),
     1 ,sum), col = 'blue')

paras2["u"] = 73
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out3 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out3[,-c(1:2,length(out3))]),
     1, sum), col='red', lwd=2, lty=2)

paras2["u"] = 500
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out4 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out4[,-c(1:2,length(out4))]),
     1,sum, na.rm = TRUE), col = 'green')

legend("topright", legend = c("SIR", "u=2", "u=500",
     "u=73 (H-S)"), lty = c(1,1,1,2), lwd = c(1,1,1, 2),
     col = c("black", "blue", "green", "red"))


# Goals: Scare the hell out of children with the Cauchy distribution.

# A function which simulates N draws from one of two distributions,
# and returns the mean obtained thusly.
one.simulation <- function(N=100, distribution="normal") {
  if (distribution == "normal") {
    x <- rnorm(N)
  } else {
    x <- rcauchy(N)
  }
  mean(x)
}

k1 <- density(replicate(1000, one.simulation(20)))
k2 <- density(replicate(1000, one.simulation(20, distribution="cauchy")))

xrange <- range(k1$x, k2$x)
plot(k1$x, k1$y, xlim=xrange, type="l", xlab="Estimated value", ylab="")
grid()
lines(k2$x, k2$y, col="red")
abline(v=.5)
legend(x="topleft", bty="n",
       lty=c(1,1),
       col=c("black", "red"),
       legend=c("Mean of Normal", "Mean of Cauchy"))
# The distribution of the mean of normals collapses into a point;
# that of the cauchy does not.

# Here's more scary stuff --
for (i in 1:10) {
  cat("Sigma of distribution of 1000 draws from mean of normal - ",
      sd(replicate(1000, one.simulation(20))), "\n")
}
for (i in 1:10) {
  cat("Sigma of distribution of 1000 draws from mean of cauchy - ",
      sd(replicate(1000, one.simulation(20, distribution="cauchy"))), "\n")
}

# Exercise for the reader: Compare the distribution of the median of
# the Normal against the distribution of the median of the Cauchy.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/p7.r


n <- 1000 # assigns the value of one thousand to n
+ x <- seq(1,n) # the above is how a sequence is created
+ sum(x) # this is a list of numbers and sum adds them together

# what I've in math and more in programming is that we say we evaluate a function when arguments are replaced specific values
# for example if we type log2(16) we evaluate the log2 function to get the log base 2 of 16 which will return 4
log2(16)

# from experience in R it is useful to evaluate a function inside another function
# for example sqrt(log2(16)) which will calculate the log to the base 2 of 16 and then compute the square root of that returned value
sqrt(log2(16))

# so the first evaluation returns 4 and this is then evaluated by sqrt to give the final answer of 2

x <-5 # 5 is a random number that I chose for testing
log(exp(x)) # this will always return the numeric value stored in x


## coef effect sizes from association tests of features
## se standard errors of the coefficients
## mat input data matrix (features x samples)
ivwfe.stats <- function(coef, se, mat=NULL, rho=NULL) {
    ## From James Staley:
    ##     Here is the link to Stephen Burgess’ paper we discussed on
    ## Thursday last week:
    ## http://onlinelibrary.wiley.com/doi/10.1002/sim.6835/full
    ##     I have taken a look at the maths and Stouffer’s test statistic
    ## weighted by 1/SE is the same as IVW FE meta-analysis beta/SE. So, the
    ## generalised linear model approach in Stephen’s paper which is based on
    ## IVW FE meta-analysis would probably be very similar to your Stouffer’s
    ## method corrected for correlated Z-statistics.
    ##     The test statistic would be: T = B/S ~ N(0,1)
    ## where B = (1^TΩ^-11)^-11^TΩ^-1β and S = sqrt((1^TΩ^-11)^-1) where β are
    ## the effect estimates, Ω is the variance-covariance matrix of the CpGs
    ## and 1 is a vector of 1’s the same length as the number of CpGs.

    if (is.null(rho)) {
        stopifnot(!is.null(mat))
        rho <- ivwfe.rho(mat)
    }
    ## The second diagonal matrix is the 'nudge' matrix to ensure matrix inversion

    ## remove missing values
    na <- is.na(coef) | is.na(se)
    if (sum(na) > 0) {
        if (sum(na) == length(coef))
            return(c(B=NA, S=NA))

        coef <- coef[!na]
        se <- se[!na]
        rho <- rho[!na,!na,drop=F]
    }

    omega <- (se%*%t(se))*rho
    omega.inv <- solve(omega)
    one <- matrix(1,nrow=nrow(omega.inv), ncol=1)
    S2 <- 1/(t(one) %*% omega.inv %*% one)
    c(B=S2 * (t(one) %*% omega.inv) %*% coef,
      S=sqrt(S2))
}

ivwfe.getz <- function(coef, se, mat=NULL, rho=NULL) {
    stats <- ivwfe.stats(coef, se, mat, rho)
    as.vector(stats["B"]/stats["S"])
}

ivwfe.rho <- function(mat) {
    mat <- t(mat)
    rho <- cor(mat, use="p") + diag(x=0.05,ncol(mat),ncol(mat))
}

ivwfe.ma <- function(estimates, se) {
    weights <- 1/se^2
    se <- sqrt(1/rowSums(weights, na.rm=T))
    estimates <- rowSums(estimates * weights, na.rm=T)/rowSums(weights, na.rm=T)
    z <- estimates/se
    p <- 2*pnorm(-abs(z), lower.tail=T)
    data.frame(estimate=estimates,
               se=se,
               z=z,
               p.value=p)
}


source('./libraries.R')

#### Functions ----
T_hotelling_radial <- function(r, phi, critical, norm_data, n, p){
  n * r^2 * (t(c(cos(phi), sin(phi))) %*% solve(cov(norm_data)) %*% (c(cos(phi), sin(phi)))) * ((n - p)/(p * (n - 1))) - critical
}

T_likelihood_phi <- function(r, phi, rho, sigma_x, sigma_y, n, critical){
  ((n) / (1 - rho**2)) *
    (((r * cos(phi)) / (sigma_x))**2 +
       ((r * sin(phi)) / (sigma_y))**2 -
       (2 * rho * ((r * cos(phi)) / (sigma_x)) * ((r * sin(phi)) / (sigma_y)))
    ) - critical
}

mvnormSample_2d <- function(mu_x = 0, mu_y = 0, n = 20, rho = 0.5, sigma_x = 1, sigma_y = 1){
  mu <- c(mu_x , mu_y)
  names(mu) <- c('mu_x', 'mu_y')
  Sigma <- matrix(c(sigma_x^2,
                    sigma_x * sigma_y * rho,
                    sigma_x * sigma_y * rho,
                    sigma_y^2),
                  2, 2, byrow = TRUE)
  sample <- mvrnorm(n = n, mu = mu, Sigma = Sigma) %>% as.data.frame()
  names(sample) <- c('x', 'y')
  return(sample)
}

Hotelling_radial_cr <- function(data, len_out=180, signf_lvl = 0.05){
  n <- nrow(data)
  p <- ncol(data)
  critical <- qf(1 - signf_lvl, df1 = p, df2 = n - p)
  col_means <- colMeans(data)

  vred <- data.frame(phi = seq(0, 2 * pi, length.out = len_out)) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = T_hotelling_radial,
      phi = phi,
      critical = critical,
      norm_data = data,
      n = n,
      p = p,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi), y = col_means[2] + r * sin(phi))
  return(vred)
}

Likelihood_radial_cr <- function(data, len_out = 180, signf_lvl = 0.05){
  n = nrow(data)
  col_sd <- apply(data, 2, sd)
  col_means <- colMeans(data)
  hat_rho <- cor(data)[1,2]
  critical <- qchisq(1 - signf_lvl, df = 2)
  vred <- data.frame(phi = seq(0, 2 * pi, length.out = len_out)) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = T_likelihood_phi,
      phi = phi,
      rho = hat_rho,
      sigma_x = col_sd[1],
      sigma_y = col_sd[2],
      n = n,
      critical = critical,
      interval = c(0,400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi), y = col_means[2] + r * sin(phi))
  # return points to plot
  return(vred)
}

# 3D sample
mvnormSample_3d <- function(n = 20){
  mu <- c(0,0,0)
  names(mu) <- c('mu_x', 'mu_y', 'mu_z')
  Sigma <- matrix(c(1, 0.5, 0.5,
                    0.5, 1, 0.5,
                    0.5, 0.5, 1),
                  3, 3, byrow = TRUE)
  sample <- mvrnorm(n = n, mu = mu, Sigma = Sigma) %>% as.data.frame()
  names(sample) <- c('x', 'y', 'z')
  return(sample)
}

# Hotelling 3D
Hot_pivot <-  function(r, phi_1, phi_2, n, p, data, critical){
  n * r^2 *
     t(c(
       cos(phi_1),
       sin(phi_1) * cos(phi_2),
       sin(phi_1) * sin(phi_2)
     )) %*%
     solve(cov(data)) %*%
     c(
       cos(phi_1),
       sin(phi_1) * cos(phi_2),
       sin(phi_1) * sin(phi_2)
     ) *
     ((n - p)/(p * (n - 1))) - critical
}

Hot_cr_3d <- function(data, len_out=180, signf_lvl = 0.05){
  len_2 <- floor(sqrt(len_out/2))
  len_1 <- 2 * len_2
  n <- nrow(data)
  p <- ncol(data)
  critical <- qf(1-signf_lvl, df1 = p, df2 = n-p)
  col_means <- colMeans(data)
  phi_1 = seq(0, pi, length.out = len_1)
  phi_2 = seq(0, 2 * pi, length.out = len_2)
  vred <- expand_grid(phi_1, phi_2) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = Hot_pivot,
      phi_1 = phi_1,
      phi_2 = phi_2,
      critical = critical,
      data = data,
      n = n,
      p = p,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi_1), y = col_means[2] + r * sin(phi_1) * cos(phi_2), z = col_means[3] + r * sin(phi_1) * sin(phi_2))
  return(vred)
}

# Likelihood  3D
ell_0 <- function(x, mu_hat, k, Sigma_inv, Sigma_det){
  -(1/2) * (
    t(x - mu_hat) %*%
      Sigma_inv %*%
      (x - mu_hat)
  ) -
    (k/2) * log(2* pi) - (1/2) * log(Sigma_det)
}

ell <- function(r, x, phi_1, phi_2, mu_hat, k, Sigma_inv, Sigma_det){
  -(1/2) * (
    t(x - mu_hat - r *
        c(
          cos(phi_1),
          sin(phi_1) * cos(phi_2),
          sin(phi_1) * sin(phi_2)
        )
      ) %*%
      Sigma_inv %*%
      (x - mu_hat - r *
         c(
           cos(phi_1),
           sin(phi_1) * cos(phi_2),
           sin(phi_1) * sin(phi_2)
         )
      )
    ) -
    (k/2) * log(2* pi) - (1/2) * log(Sigma_det)
}

Lik_pivot <- function(r, phi_1, phi_2, mu_hat, k, critical, Sigma_inv, Sigma_det, data){

  ells <- data %>%
    rowwise() %>%
    transmute(
      var_ell = ell(
        r = r,
        x = c(x, y, z),
        phi_1 = phi_1,
        phi_2 = phi_2,
        mu_hat = mu_hat,
        k = k,
        Sigma_inv = Sigma_inv,
        Sigma_det = Sigma_det
      ),
      var_ell_0 = ell_0(
        x = c(x, y, z),
        mu_hat = mu_hat,
        k = k,
        Sigma_inv = Sigma_inv,
        Sigma_det = Sigma_det
      )
    ) %>%
    ungroup() %>%
    summarise(sum_ell = sum(var_ell),
              sum_ell_0 = sum(var_ell_0))
  value <- -2 * (ells$sum_ell - ells$sum_ell_0) - critical
  return(value)
}

Lik_cr_3d <- function(data, len_out=180, signf_lvl=0.05){
  k <- ncol(data)
  n <- nrow(data)
  cov_mtrx <- cov(data)
  Sigma_inv <- solve(cov_mtrx)
  Sigma_det <- det(cov_mtrx)
  critical <- qchisq(1-signf_lvl, df = k)
  mu_hat <- colMeans(data)
  len_2 <- floor(sqrt(len_out/2))
  len_1 <- 2 * len_2

  phi_1 = seq(0, pi, length.out = len_1)
  phi_2 = seq(0, 2 * pi, length.out = len_2)
  vred <- expand_grid(phi_1, phi_2) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = Lik_pivot,
      phi_1 = phi_1,
      phi_2 = phi_2,
      mu_hat = mu_hat,
      k = k,
      critical = critical,
      Sigma_inv = Sigma_inv,
      Sigma_det = Sigma_det,
      data = data,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = mu_hat[1] + r * cos(phi_1), y = mu_hat[2] + r * sin(phi_1) * cos(phi_2), z = mu_hat[3] + r * sin(phi_1) * sin(phi_2))
  return(vred)

}

#### 2D example ----
# Generate 2D data

data_2d <- mvnormSample_2d(n = 20)
mu_hat <- colMeans(data_2d)
cr_2d_hot <- Hotelling_radial_cr(data = data_2d, len_out = 180) %>% slice(chull(x, y))
cr_2d_lik <- Likelihood_radial_cr(data = data_2d, len_out = 180) %>% slice(chull(x, y))

data_2d %>% ggplot(aes(x = x, y = y)) +
  geom_point() +
  geom_point(aes(x = mu_hat[1], y = mu_hat[2]), size = 3, alpha = .5, color = 'red') +
  geom_polygon(data = cr_2d_hot, alpha = 0.3, fill='darkgreen') +
  geom_polygon(data = cr_2d_lik, alpha = 0.3, fill='yellow')

#### 3D example ----
cr_plot <- function(data, colour){
  chul_3d <- convhulln(data, options = 'FA')
  mesh_3d <- mesh3d(chul_3d$p)
  mesh_3d$it <- chul_3d$hull %>% t()
  mesh_3d$ib <- NULL
  wire3d(mesh_3d, col = colour, alpha = 0.4)
  shade3d(mesh_3d, col = colour, alpha = 0.1, override = T)
}

run_3d <- function(n_pts, n_bnry_pts){

  data_3d <- mvnormSample_3d(n = n_pts)
  mean_3d <- colMeans(data_3d) %>% t()

  # confidence regions
  data_3d_cr_hot <-
    Hot_cr_3d(data = data_3d,
              len_out = n_bnry_pts,
              signf_lvl = 0.05)
  data_3d_cr_lik <-
    Lik_cr_3d(data = data_3d,
              len_out = n_bnry_pts,
              signf_lvl = 0.05)

  # plot points, mu and estimates
  points3d(data_3d, alpha = 0.5)
  axes3d(c('x', 'y', 'z'))
  points3d(data_3d,
           size = 20,
           alpha = 0.2,
           col = 'grey')
  points3d(mean_3d, size = 3, col = 'red')
  points3d(mean_3d,
           size = 20,
           alpha = 0.3,
           col = 'red')

  # original
  points3d(data.frame(x = 0, y = 0, z = 0), size = 3, col = 'orange')
  points3d(
    data.frame(x = 0, y = 0, z = 0),
    size = 20,
    alpha = 0.3,
    col = 'orange'
  )

  # CR
  cr_plot(data = data_3d_cr_hot, colour = 'green')
  cr_plot(data = data_3d_cr_lik, colour = 'blue')
}
run_3d(n_pts = 20, n_bnry_pts = 180)


qqplot_nwj <- function(x, type='nw') {
    ## creates side by side, normal and Weibull qq plots
    if (type == 'nw') {
        par(mfrow=c(1,2))
        qualityTools::qqPlot(x, "normal",  col='black')
        qualityTools::qqPlot(x, "Weibull", col='black')
    } else {
        par(mfrow=c(1,3))
        qualityTools::qqPlot(x, "normal",  col='black')
        qualityTools::qqPlot(x, "Weibull", col='black')
        library(SuppDists) # need for Johnson distribution
        jparms  <- JohnsonFit(x)
        quantiles_john <- qJohnson(ppoints(length(x)), jparms)
        stats::qqplot(
            x = x,
            xlab = "Data",
            y = quantiles_john,
            ylab = 'Quantiles from "Johnson" Distribution',
            main = expression('Q-Q plot for "Johnson" Distribution'),
            col='black')
        qqline(x, distribution = function(p) qJohnson(p, jparms), col=2)
    }
}
## qqplot_nwj(mtcars$mpg)

## ## comparisons for normal qq plot
## par(mfrow=c(1,2))
## qualityTools::qqPlot(x, "normal",  col='black')
## quantiles_norm <- qnorm(ppoints(length(x)), mean = mean(x), sd = sd(x))
## stats::qqplot(
##            x = x,
##            xlab = "Data",
##            y = quantiles_norm,
##            ylab = 'Quantiles from Normal Distribution',
##            main = expression('Q-Q plot for Normal Distribution'),
##            col='black')
## qqline(x, distribution = function(p) qnorm(p, mean=mean(x), sd=sd(x)), col=2)
##
## ## comparisons for Weibull qq plot
## par(mfrow=c(1,2))
## qualityTools::qqPlot(x, "Weibull",  col='black')
## tol_out <-  exttol.int(x, alpha =0.1, P=0.99, side=1)
## shape <- tol_out$'shape.1'
## scale <- tol_out$'shape.2'
## quantiles_weib <- qweibull(ppoints(length(x)), shape = shape, scale = scale)
## stats::qqplot(
##            x = x,
##            xlab = "Data",
##            y = quantiles_weib,
##            ylab = 'Quantiles from Weibull Distribution',
##            main = expression('Q-Q plot for Weibull Distribution'),
##            col='black')
## qqline(x, distribution = function(p) qweibull(p, shape = shape, scale = scale), col=2)


# Writing functions in R

# A. Why you should use functions?
# 1. Calling functions
# Look at the gold medals data
gold_medals

# Note the arguments to median()
args(median)

# Rewrite this function call, following best practices. For best practice, only require to outline less often used arguments
median(gold_medals, na.rm = TRUE)

# Note the arguments to rank()
args(rank)

# Rewrite this function call, following best practices. na.last = "keep", means keep the rank of NA values as NA
rank(-gold_medals, na.last = "keep", ties.method = "min")

# B. Converting scripts into functions
# 1. First function: tossing a coin
coin_sides <- c("head", "tail")

# Sample from coin_sides once
sample(coin_sides, 1)

# Write a template for your function, toss_coin()
toss_coin <- function() {
  # (Leave the contents of the body for later)
# Add punctuation to finish the body
}

# Your functions, from previous steps
toss_coin <- function() {
  coin_sides <- c("head", "tail")
  sample(coin_sides, 1)
}

# Call your function
toss_coin()

# 2. Providing input arguments to a function
# Update the function to return n coin tosses
toss_coin <- function(n_flips) {
  coin_sides <- c("head", "tail")
  sample(coin_sides, n_flips, replace = TRUE)
}

# Generate 10 coin tosses
toss_coin(10)

# 3. Multiple inputs to functions
# Update the function so heads have probability p_head. Additional elements added to function signature are separated by comma
toss_coin <- function(n_flips, p_head) {
  coin_sides <- c("head", "tail")
  # Define a vector of weights
  weights <- c(p_head, 1 - p_head)
  # Modify the sampling to be weighted
  sample(coin_sides, n_flips, replace = TRUE, prob = weights)
}

# Generate 10 coin tosses
toss_coin(10, 0.8)

# C. Renaming functions
# In order to allow for better readability, be careful with function naming convention
# 1. Renaming GLM
# Run a generalized linear regression
glm(
  # Model no. of visits vs. gender, income, travel
  n_visits ~ gender + income + travel,
  # Use the snake_river_visits dataset
  data = snake_river_visits,
  # Make it a Poisson regression
  family = poisson
)

# Create the function to better apply the regression method
run_poisson_regression <- function(data, formula) {
  glm(formula, data, family = poisson)
}

# Re-run the Poisson regression, using your function. The pipe operation allows for the data to be passed through without explicitly calling it
model <- snake_river_visits %>%
  run_poisson_regression(n_visits ~ gender + income + travel)

# Run this to see the predictions
snake_river_explanatory %>%
  mutate(predicted_n_visits = predict(model, ., type = "response"))%>%
  arrange(desc(predicted_n_visits))


Y <- matrix(c(25,19,33,23),4,1)
X <- matrix(c(1,1,1,1,-2,-2,2,2,5,-5,5,-5),4,3)
transpose_X=t(X)
transpose_X_X=transpose_X%*%X
transpose_X_Y=transpose_X%*%Y
inverse_transpose_X_X=solve(transpose_X_X)

beta=inverse_transpose_X_X%*%transpose_X_Y
beta
# prediction equation is
y=25.0+1.5*x1+0.8*x2


#Example  :  2.2A    Chapter  :   2.2    page no : 50
#Pivots and Multipliers in converting matrix to upper traingular system
matrix(c(1,-1,0,-1,2,-1,0,-1,2),ncol=3)->A
A
print(paste("First pivot is",A[1,1]))
l21<-A[2,1]/A[1,1]
print(paste("Multiplier L21 to convert the second row first element to 0 is",l21))
A[2,]<-A[2,]-l21*A[1,]
A
print(paste("The second pivot is ",A[2,2]))
l32<-A[3,2]/A[2,2]
A[3,]<-A[3,]-l32*A[2,]
print("The equivalent Upper traingular system for the matrix A is ")
A


'''
1.17 (Brockwell et al., 2016, p. 36)

Load the dataset deaths in R using the read.table function. Plot the data. Also create a histogram of
the data using the R function hist. Plot the sample autocorrelation function using the acf function. The
presence of a strong seasonal component with period 12 is evident in the graph of the data and in the sample
autocorrelation function.
'''

data = read.table("C:/prosjekt/Time_Series_stat211/data/deaths.txt", skip = 9, header=FALSE)
names(data) = c("month","year","deaths")
data$time = as.Date(paste(data$year,data$month,"15",sep="-"))
attach(data)
plot(time,deaths/1000, type="l", xlab="", ylab = "deaths (thousands)")

acf(deaths ,lag.max = 24) #computes (and by default plots) estimates of the autocovariance or autocorrelation function

hist(deaths, breaks = 15)

'''
Problem 1.6
[BD, Exercise 1.18, page 37]
We are still studying the dataset deaths. In this exercise, you are supposed to reproduce the figures 1-24 and 1-25 in [BD, pp. 27-28] .
In 1.17, we found a period of length 12.
Fit a seasonal component using the procedure described in section 1.5.2.1 on page 26.
You may use the following functions or write your own:
'''
# Function for calculating a moving average when d is even
ma <- function(x, n=12){filter(x,c(.5,rep(1,n-1),.5)/n, sides=2)}
# Function for finding the seasonal component
seasonal.component <- function(x){ # x-  deaths
	# First step: detrending
	detrended <- x - ma(x)
	# Second step: Calculating sesonal component from detrended data
	wt <- rowMeans(matrix(detrended[!is.na(detrended)], nrow=12,byrow=FALSE))
	st<-(wt - mean(wt))[c(7:12,1:6)] #seasonal component
	return(st)
}

#sol
library(itsmr)
detrended <- deaths - seasonal.component(deaths) #season(deaths, 12) #removing season

'''
Plot the deseasonalized data (as in figure 1-24). Fit a quadratic trend (polynomial of
order two) to the deseasonalized data and add the curve to the plot you just created. The
trend should be mb = 9952 − 71.82t + 0.8260t2 for 1 ≤ t ≤ 72. This can be done using the
following code:
'''

M <- poly(1:72, degree=2, raw=TRUE)
trend <- lm(detrended ~ M) # Re-estimating trend of the detrended data
'''
Plot the sample autocorrelation function of Yt. Forecast the data for the next 24 months
without allowing for this dependence, based on the assumption that the estimated seasonal
and trend components are true values and that Yt is a white noise sequence with zero
mean. Calculate sb72+k for k = 1, . . . , 24 and do the forecasting by
Xbt = mb 72+k + sb72+k, k = 1, . . . , 24.
'''

#solution
plot(data$time, detrended/1000, type="b", xlab="",ylab="(thousands)") #plotting deseasonalized data

lines(data$time, trend(detrended, 2)/1000, col=2)

plot(data$time,season(deaths,12)/1000, type="b",xlab="",ylab="(thousands)") # Plotting seasonal component
abline(h=0) # adding horizontal line at zero

##########
'''
Plot the original data with the forecasts appended. Later we shall see how to improve on
these forecasts by taking into account the dependence in the series Yt. Hint: To calculate
mb 72+k the following code may be useful:
'''
M <- poly(72 + 1:24, 2, raw=TRUE)
yhat <- predict(trend, newdata= M)

#######
p.time <- seq(as.Date("1979-01-15"),by="month",length.out=24)

#plot(time,deaths/1000,xlim=range(time,p.time),type="b",
plot(time,detrended/1000,xlim=range(time,p.time),type="b",
	#ylim = range(deaths, yhat)/1000,
	ylim = range(trend(detrended, 2), yhat)/1000,
	ylab = "(thousands)", xlab ="")

lines(data$time, trend(detrended, 2)/1000, col=2)
lines(p.time,yhat/1000, type="b", col = "blue")

'''
References
Peter J Brockwell and Richard A Davis. Introduction to time series and forecasting;
3rd ed. Springer texts in statistics. Springer, Cham, 2016. doi: 10.1007/
'''


# Case Study - grain yields

# A. Grain yields and unit conversion
# 1. Converting areas to metric 1
# Write a function to convert acres to sq. yards
acres_to_sq_yards <- function(acres) {
  acres * 4840
}

# Write a function to convert yards to meters
yards_to_meters <- function(yards) {
    yards * 36 * 0.0254
}

# Write a function to convert sq. meters to hectares
sq_meters_to_hectares <- function(sq_meters) {
    sq_meters / 10000
}

# 2. Converting areas to metric 2
# Write a function to convert sq. yards to sq. meters
sq_yards_to_sq_meters <- function(sq_yards) {
  sq_yards %>%
    # Take the square root
    sqrt() %>%
    # Convert yards to meters
    yards_to_meters() %>%
    # Square it
    raise_to_power(2)
}

# Load the function from the previous step
load_step2()

# Write a function to convert acres to hectares
acres_to_hectares <- function(acres) {
  acres %>%
    # Convert acres to sq yards
    acres_to_sq_yards() %>%
    # Convert sq yards to sq meters
    sq_yards_to_sq_meters() %>%
    # Convert sq meters to hectares
    sq_meters_to_hectares()
}

# Load the functions from the previous steps
load_step3()

# Define a harmonic acres to hectares function
harmonic_acres_to_hectares <- function(acres) {
  acres %>%
    # Get the reciprocal
    get_reciprocal() %>%
    # Convert acres to hectares
    acres_to_hectares() %>%
    # Get the reciprocal again
    get_reciprocal()
}

# 3. Converting yields to metric
# Write a function to convert lb to kg
lbs_to_kgs <- function(lbs) {
    lbs * 0.45359237
}

# Write a function to convert bushels to lbs
bushels_to_lbs <- function(bushels, crop) {
  # Define a lookup table of scale factors
  c(barley = 48, corn = 56, wheat = 60) %>%
    # Extract the value for the crop
    extract(crop) %>%
    # Multiply by the no. of bushels
    multiply_by(bushels)
}

# Load fns defined in previous steps
load_step3()

# Write a function to convert bushels to kg
bushels_to_kgs <- function(bushels, crop) {
  bushels %>%
    # Convert bushels to lbs for this crop
    bushels_to_lbs(crop) %>%
    # Convert lbs to kgs
    lbs_to_kgs()
}

# Load fns defined in previous steps
load_step4()

# Write a function to convert bushels/acre to kg/ha
bushels_per_acre_to_kgs_per_hectare <- function(bushels_per_acre, crop = c("barley", "corn", "wheat")) {
  # Match the crop argument
  crop <- match.arg(crop)
  bushels_per_acre %>%
    # Convert bushels to kgs for this crop
    bushels_to_kgs(crop) %>%
    # Convert harmonic acres to ha
    harmonic_acres_to_hectares()
}

# 4. Applying the unit conversion
# Wrap this code into a function
fortify_with_metric_units <- function(data, crop) {
  data %>%
    mutate(
      farmed_area_ha = acres_to_hectares(farmed_area_acres),
      yield_kg_per_ha = bushels_per_acre_to_kgs_per_hectare(
        yield_bushels_per_acre,
        crop = crop
      )
    )
}

# Try it on the wheat dataset
fortify_with_metric_units(wheat, "wheat")

# B. Visualizing grain yields
# 1. Plotting yields over time
# Wrap this plotting code into a function
plot_yield_vs_year <- function(data) {
  ggplot(data, aes(x = year, y = yield_kg_per_ha)) +
    geom_line(aes(group = state)) +
    geom_smooth()
}

# Test it on the wheat dataset
plot_yield_vs_year(wheat)

# 2. A nation divided
# Inner join the corn dataset to usa_census_regions by state
corn %>%
  inner_join(usa_census_regions, by = "state")

# Wrap this code into a function
fortify_with_census_region <- function(data) {
  data %>%
    inner_join(usa_census_regions, by = "state")
}

# Try it on the wheat dataset
fortify_with_census_region(wheat)

# 3. Plotting yields over time by region
# Wrap this code into a function
plot_yield_vs_year_by_region <- function(data) {
  plot_yield_vs_year(data) +
    facet_wrap(vars(census_region))
}

# Try it on the wheat dataset
plot_yield_vs_year_by_region(wheat)

# C. Modeling grain yields
# 1. Running a model
# Run a generalized additive model of
# yield vs. smoothed year and census region
# s() means "make the variable smooth", where smooth very roughly means nonlinear.
gam(yield_kg_per_ha ~ s(year) + census_region, data = corn)

# Wrap the model code into a function
run_gam_yield_vs_year_by_region <- function(data) {
  gam(yield_kg_per_ha ~ s(year) + census_region, data = data)
}

# Try it on the wheat dataset
run_gam_yield_vs_year_by_region(wheat)

# 2. Making yield predictions
# predict(model, cases_to_predict, type = "response")
# Wrap this prediction code into a function
predict_yields <- function(model, year) {
  predict_this <- data.frame(
    year = year,
    census_region = census_regions
  )
  pred_yield_kg_per_ha <- predict(model, predict_this, type = "response")
  predict_this %>%
    mutate(pred_yield_kg_per_ha = pred_yield_kg_per_ha)
}

# Try it on the wheat dataset
predict_yields(wheat_model, 2050)

# 3. Bringing it all together for barley crop
# From previous step
fortified_barley <- barley %>%
  fortify_with_metric_units() %>%
  fortify_with_census_region()

# Plot yield vs. year by region
plot_yield_vs_year_by_region(fortified_barley)

# Create the model parameters and make predictions
fortified_barley %>%
  # Run a GAM of yield vs. year by region
  run_gam_yield_vs_year_by_region()  %>%
  # Make predictions of yields in 2050
  predict_yields(2050)


is_in <- function(x, l, u){
  below <- x >= l
  above <- x <= u
  result <- as.logical(below * above)
  return(result)
}
get_ci <- function(x){
  y1 <- min(x)
  y2 <- max(x)
  return(
    data.frame(
      lwr = y1,
      upr = y2,
      width = y2-y1
    )
  )
}

######################
theta <- 10 # -pi^2/6
ll <- 1/2
M <- 10000

amostras <- matrix(runif(2*M, min = theta-ll, max = theta + ll),
                   nrow = M, ncol = 2)
cis <- apply(amostras, 1, get_ci)
cis.dt <- do.call(rbind, cis)
inclusion <- unlist(
  lapply(cis,
         function(x) is_in(x = theta, l = x[1], u = x[2]))
)
mean(inclusion)
sum(inclusion)
head(cis.dt)

theta

hist(cis.dt$width)
abline(v = ll, lwd = 3, lty = 2)

boxplot(cis.dt$width~inclusion)
abline(h = ll, lwd = 3, lty = 2)

head(cis.dt)
theta

smaller <- which(cis.dt$width < 1/2)
includes <- which(inclusion)

length(
  intersect(smaller, includes)
)